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
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
80 # - finish tr/// changes
81 # - add option for even more parens (generalize \&foo change)
82 # - {} around variables in strings ("${var}letters")
85 # - left/right context
86 # - recognize `use utf8', `use integer', etc
87 # - treat top-level block specially for incremental output
88 # - interpret in high bit chars in string as utf8 \x{...} (when?)
89 # - copy comments (look at real text with $^P)
90 # - avoid semis in one-statement blocks
91 # - associativity of &&=, ||=, ?:
92 # - ',' => '=>' (auto-unquote?)
93 # - break long lines ("\r" as discretionary break?)
94 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
95 # - more style options: brace style, hex vs. octal, quotes, ...
96 # - print big ints as hex/octal instead of decimal (heuristic?)
97 # - include values of variables (e.g. set in BEGIN)
98 # - coordinate with Data::Dumper (both directions? see previous)
99 # - version using op_next instead of op_first/sibling?
100 # - avoid string copies (pass arrays, one big join?)
102 # - while{} with one-statement continue => for(; XXX; XXX) {}?
103 # - -uPackage:: descend recursively?
107 # Tests that will always fail:
108 # comp/redef.t -- all (redefinition happens at compile time)
110 # Object fields (were globals):
113 # (local($a), local($b)) and local($a, $b) have the same internal
114 # representation but the short form looks better. We notice we can
115 # use a large-scale local when checking the list, but need to prevent
116 # individual locals too. This hash holds the addresses of OPs that
117 # have already had their local-ness accounted for. The same thing
121 # CV for current sub (or main program) being deparsed
124 # name of the current package for deparsed code
127 # array of [cop_seq, GV, is_format?] for subs and formats we still
131 # as above, but [name, prototype] for subs that never got a GV
133 # subs_done, forms_done:
134 # keys are addresses of GVs for subs and formats we've already
135 # deparsed (or at least put into subs_todo)
140 # cuddle: ` ' or `\n', depending on -sC
145 # A little explanation of how precedence contexts and associativity
148 # deparse() calls each per-op subroutine with an argument $cx (short
149 # for context, but not the same as the cx* in the perl core), which is
150 # a number describing the op's parents in terms of precedence, whether
151 # they're inside an expression or at statement level, etc. (see
152 # chart below). When ops with children call deparse on them, they pass
153 # along their precedence. Fractional values are used to implement
154 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
155 # parentheses hacks. The major disadvantage of this scheme is that
156 # it doesn't know about right sides and left sides, so say if you
157 # assign a listop to a variable, it can't tell it's allowed to leave
158 # the parens off the listop.
161 # 26 [TODO] inside interpolation context ("")
162 # 25 left terms and list operators (leftward)
166 # 21 right ! ~ \ and unary + and -
171 # 16 nonassoc named unary operators
172 # 15 nonassoc < > <= >= lt gt le ge
173 # 14 nonassoc == != <=> eq ne cmp
180 # 7 right = += -= *= etc.
182 # 5 nonassoc list operators (rightward)
186 # 1 statement modifiers
189 # Nonprinting characters with special meaning:
190 # \cS - steal parens (see maybe_parens_unop)
191 # \n - newline and indent
192 # \t - increase indent
193 # \b - decrease indent (`outdent')
194 # \f - flush left (no indent)
195 # \cK - kill following semicolon, if any
199 return class($op) eq "NULL";
204 my($gv, $cv, $is_form) = @_;
206 if (!null($cv->START) and is_state($cv->START)) {
207 $seq = $cv->START->cop_seq;
211 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
216 my $ent = shift @{$self->{'subs_todo'}};
217 my $name = $self->gv_name($ent->[1]);
219 return "format $name =\n"
220 . $self->deparse_format($ent->[1]->FORM). "\n";
222 return "sub $name " .
223 $self->deparse_sub($ent->[1]->CV);
230 if ($op->flags & OPf_KIDS) {
232 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
233 walk_tree($kid, $sub);
242 $op = shift if null $op;
243 return if !$op or null $op;
246 if ($op->ppaddr eq "pp_gv") {
247 if ($op->next->ppaddr eq "pp_entersub") {
248 next if $self->{'subs_done'}{$ {$op->gv}}++;
249 next if class($op->gv->CV) eq "SPECIAL";
250 $self->todo($op->gv, $op->gv->CV, 0);
251 $self->walk_sub($op->gv->CV);
252 } elsif ($op->next->ppaddr eq "pp_enterwrite"
253 or ($op->next->ppaddr eq "pp_rv2gv"
254 and $op->next->next->ppaddr eq "pp_enterwrite")) {
255 next if $self->{'forms_done'}{$ {$op->gv}}++;
256 next if class($op->gv->FORM) eq "SPECIAL";
257 $self->todo($op->gv, $op->gv->FORM, 1);
258 $self->walk_sub($op->gv->FORM);
268 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
269 if ($pack eq "main") {
272 $pack = $pack . "::";
275 while (($key, $val) = each %stash) {
276 my $class = class($val);
277 if ($class eq "PV") {
279 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
280 } elsif ($class eq "IV") {
282 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
283 } elsif ($class eq "GV") {
284 if (class($val->CV) ne "SPECIAL") {
285 next if $self->{'subs_done'}{$$val}++;
286 $self->todo($val, $val->CV, 0);
287 $self->walk_sub($val->CV);
289 if (class($val->FORM) ne "SPECIAL") {
290 next if $self->{'forms_done'}{$$val}++;
291 $self->todo($val, $val->FORM, 1);
292 $self->walk_sub($val->FORM);
302 foreach $ar (@{$self->{'protos_todo'}}) {
303 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
304 push @ret, "sub " . $ar->[0] . "$proto;\n";
306 delete $self->{'protos_todo'};
314 while (length($opt = substr($opts, 0, 1))) {
316 $self->{'cuddle'} = " ";
317 $opts = substr($opts, 1);
318 } elsif ($opt eq "i") {
319 $opts =~ s/^i(\d+)//;
320 $self->{'indent_size'} = $1;
321 } elsif ($opt eq "T") {
322 $self->{'use_tabs'} = 1;
323 $opts = substr($opts, 1);
324 } elsif ($opt eq "v") {
325 $opts =~ s/^v([^.]*)(.|$)//;
326 $self->{'ex_const'} = $1;
333 my $self = bless {}, $class;
334 $self->{'subs_todo'} = [];
335 $self->{'curstash'} = "main";
336 $self->{'cuddle'} = "\n";
337 $self->{'indent_size'} = 4;
338 $self->{'use_tabs'} = 0;
339 $self->{'ex_const'} = "'???'";
340 while (my $arg = shift @_) {
341 if (substr($arg, 0, 2) eq "-u") {
342 $self->stash_subs(substr($arg, 2));
343 } elsif ($arg eq "-p") {
344 $self->{'parens'} = 1;
345 } elsif ($arg eq "-l") {
346 $self->{'linenums'} = 1;
347 } elsif ($arg eq "-q") {
348 $self->{'unquote'} = 1;
349 } elsif (substr($arg, 0, 2) eq "-s") {
350 $self->style_opts(substr $arg, 2);
359 my $self = B::Deparse->new(@args);
360 $self->stash_subs("main");
361 $self->{'curcv'} = main_cv;
362 $self->walk_sub(main_cv, main_start);
363 print $self->print_protos;
364 @{$self->{'subs_todo'}} =
365 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
366 print $self->indent($self->deparse(main_root, 0)), "\n"
367 unless null main_root;
369 while (scalar(@{$self->{'subs_todo'}})) {
370 push @text, $self->next_todo;
372 print indent(join("", @text)), "\n" if @text;
379 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
380 return $self->indent($self->deparse_sub(svref_2object($sub)));
386 # cluck if class($op) eq "NULL";
387 # return $self->$ {\$op->ppaddr}($op, $cx);
388 my $meth = $op->ppaddr;
389 return $self->$meth($op, $cx);
395 my @lines = split(/\n/, $txt);
400 my $cmd = substr($line, 0, 1);
401 if ($cmd eq "\t" or $cmd eq "\b") {
402 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
403 if ($self->{'use_tabs'}) {
404 $leader = "\t" x ($level / 8) . " " x ($level % 8);
406 $leader = " " x $level;
408 $line = substr($line, 1);
410 if (substr($line, 0, 1) eq "\f") {
411 $line = substr($line, 1); # no indent
413 $line = $leader . $line;
417 return join("\n", @lines);
424 if ($cv->FLAGS & SVf_POK) {
425 $proto = "(". $cv->PV . ") ";
427 local($self->{'curcv'}) = $cv;
428 local($self->{'curstash'}) = $self->{'curstash'};
429 if (not null $cv->ROOT) {
431 return $proto . "{\n\t" .
432 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
434 return $proto . "{}\n";
442 local($self->{'curcv'}) = $form;
443 local($self->{'curstash'}) = $self->{'curstash'};
444 my $op = $form->ROOT;
446 $op = $op->first->first; # skip leavewrite, lineseq
447 while (not null $op) {
448 $op = $op->sibling; # skip nextstate
450 $kid = $op->first->sibling; # skip pushmark
451 push @text, $kid->sv->PV;
452 $kid = $kid->sibling;
453 for (; not null $kid; $kid = $kid->sibling) {
454 push @exprs, $self->deparse($kid, 0);
456 push @text, join(", ", @exprs)."\n" if @exprs;
459 return join("", @text) . ".";
464 return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope"
465 || $op->ppaddr eq "pp_lineseq"
466 || ($op->ppaddr eq "pp_null" && class($op) eq "UNOP"
467 && (is_scope($op->first) || $op->first->ppaddr eq "pp_enter"));
471 my $name = $_[0]->ppaddr;
472 return $name eq "pp_nextstate" || $name eq "pp_dbstate";
475 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
477 return (!null($op) and null($op->sibling)
478 and $op->ppaddr eq "pp_null" and class($op) eq "UNOP"
479 and (($op->first->ppaddr =~ /^pp_(and|or)$/
480 and $op->first->first->sibling->ppaddr eq "pp_lineseq")
481 or ($op->first->ppaddr eq "pp_lineseq"
482 and not null $op->first->first->sibling
483 and $op->first->first->sibling->ppaddr eq "pp_unstack")
489 return ($op->ppaddr eq "pp_rv2sv" or
490 $op->ppaddr eq "pp_padsv" or
491 $op->ppaddr eq "pp_gv" or # only in array/hash constructs
492 $op->flags & OPf_KIDS && !null($op->first)
493 && $op->first->ppaddr eq "pp_gvsv");
498 my($text, $cx, $prec) = @_;
499 if ($prec < $cx # unary ops nest just fine
500 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
501 or $self->{'parens'})
504 # In a unop, let parent reuse our parens; see maybe_parens_unop
505 $text = "\cS" . $text if $cx == 16;
512 # same as above, but get around the `if it looks like a function' rule
513 sub maybe_parens_unop {
515 my($name, $kid, $cx) = @_;
516 if ($cx > 16 or $self->{'parens'}) {
517 return "$name(" . $self->deparse($kid, 1) . ")";
519 $kid = $self->deparse($kid, 16);
520 if (substr($kid, 0, 1) eq "\cS") {
522 return $name . substr($kid, 1);
523 } elsif (substr($kid, 0, 1) eq "(") {
524 # avoid looks-like-a-function trap with extra parens
525 # (`+' can lead to ambiguities)
526 return "$name(" . $kid . ")";
533 sub maybe_parens_func {
535 my($func, $text, $cx, $prec) = @_;
536 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
537 return "$func($text)";
539 return "$func $text";
545 my($op, $cx, $text) = @_;
546 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
547 return $self->maybe_parens_func("local", $text, $cx, 16);
556 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
561 my($op, $cx, $text) = @_;
562 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
563 return $self->maybe_parens_func("my", $text, $cx, 16);
569 # The following OPs don't have functions:
571 # pp_padany -- does not exist after parsing
572 # pp_rcatline -- does not exist
574 sub pp_enter { # see also leave
575 cluck "unexpected OP_ENTER";
579 sub pp_pushmark { # see also list
580 cluck "unexpected OP_PUSHMARK";
584 sub pp_leavesub { # see also deparse_sub
585 cluck "unexpected OP_LEAVESUB";
589 sub pp_leavewrite { # see also deparse_format
590 cluck "unexpected OP_LEAVEWRITE";
594 sub pp_method { # see also entersub
595 cluck "unexpected OP_METHOD";
599 sub pp_regcmaybe { # see also regcomp
600 cluck "unexpected OP_REGCMAYBE";
604 sub pp_regcreset { # see also regcomp
605 cluck "unexpected OP_REGCRESET";
609 sub pp_substcont { # see also subst
610 cluck "unexpected OP_SUBSTCONT";
614 sub pp_grepstart { # see also grepwhile
615 cluck "unexpected OP_GREPSTART";
619 sub pp_mapstart { # see also mapwhile
620 cluck "unexpected OP_MAPSTART";
624 sub pp_flip { # see also flop
625 cluck "unexpected OP_FLIP";
629 sub pp_iter { # see also leaveloop
630 cluck "unexpected OP_ITER";
634 sub pp_enteriter { # see also leaveloop
635 cluck "unexpected OP_ENTERITER";
639 sub pp_enterloop { # see also leaveloop
640 cluck "unexpected OP_ENTERLOOP";
644 sub pp_leaveeval { # see also entereval
645 cluck "unexpected OP_LEAVEEVAL";
649 sub pp_entertry { # see also leavetry
650 cluck "unexpected OP_ENTERTRY";
654 # leave and scope/lineseq should probably share code
660 local($self->{'curstash'}) = $self->{'curstash'};
661 $kid = $op->first->sibling; # skip enter
662 if (is_miniwhile($kid)) {
663 my $top = $kid->first;
664 my $name = $top->ppaddr;
665 if ($name eq "pp_and") {
667 } elsif ($name eq "pp_or") {
669 } else { # no conditional -> while 1 or until 0
670 return $self->deparse($top->first, 1) . " while 1";
672 my $cond = $top->first;
673 my $body = $cond->sibling->first; # skip lineseq
674 $cond = $self->deparse($cond, 1);
675 $body = $self->deparse($body, 1);
676 return "$body $name $cond";
678 for (; !null($kid); $kid = $kid->sibling) {
681 $expr = $self->deparse($kid, 0);
682 $kid = $kid->sibling;
685 $expr .= $self->deparse($kid, 0);
686 push @exprs, $expr if length $expr;
688 if ($cx > 0) { # inside an expression
689 return "do { " . join(";\n", @exprs) . " }";
691 return join(";\n", @exprs) . ";";
700 for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
703 $expr = $self->deparse($kid, 0);
704 $kid = $kid->sibling;
707 $expr .= $self->deparse($kid, 0);
708 push @exprs, $expr if length $expr;
710 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
711 return "do { " . join(";\n", @exprs) . " }";
713 return join(";\n", @exprs) . ";";
717 sub pp_lineseq { pp_scope(@_) }
719 # The BEGIN {} is used here because otherwise this code isn't executed
720 # when you run B::Deparse on itself.
722 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
723 "ENV", "ARGV", "ARGVOUT", "_"); }
728 my $stash = $gv->STASH->NAME;
729 my $name = $gv->NAME;
730 if ($stash eq $self->{'curstash'} or $globalnames{$name}
731 or $name =~ /^[^A-Za-z_]/)
735 $stash = $stash . "::";
737 if ($name =~ /^([\cA-\cZ])$/) {
738 $name = "^" . chr(64 + ord($1));
740 return $stash . $name;
743 # Notice how subs and formats are inserted between statements here
748 @text = $op->label . ": " if $op->label;
749 my $seq = $op->cop_seq;
750 while (scalar(@{$self->{'subs_todo'}})
751 and $seq > $self->{'subs_todo'}[0][0]) {
752 push @text, $self->next_todo;
754 my $stash = $op->stash->NAME;
755 if ($stash ne $self->{'curstash'}) {
756 push @text, "package $stash;\n";
757 $self->{'curstash'} = $stash;
759 if ($self->{'linenums'}) {
760 push @text, "\f#line " . $op->line .
761 ' "' . substr($op->filegv->NAME, 2), qq'"\n';
763 return join("", @text);
766 sub pp_dbstate { pp_nextstate(@_) }
768 sub pp_unstack { return "" } # see also leaveloop
772 my($op, $cx, $name) = @_;
776 sub pp_stub { baseop(@_, "()") }
777 sub pp_wantarray { baseop(@_, "wantarray") }
778 sub pp_fork { baseop(@_, "fork") }
779 sub pp_wait { baseop(@_, "wait") }
780 sub pp_getppid { baseop(@_, "getppid") }
781 sub pp_time { baseop(@_, "time") }
782 sub pp_tms { baseop(@_, "times") }
783 sub pp_ghostent { baseop(@_, "gethostent") }
784 sub pp_gnetent { baseop(@_, "getnetent") }
785 sub pp_gprotoent { baseop(@_, "getprotoent") }
786 sub pp_gservent { baseop(@_, "getservent") }
787 sub pp_ehostent { baseop(@_, "endhostent") }
788 sub pp_enetent { baseop(@_, "endnetent") }
789 sub pp_eprotoent { baseop(@_, "endprotoent") }
790 sub pp_eservent { baseop(@_, "endservent") }
791 sub pp_gpwent { baseop(@_, "getpwent") }
792 sub pp_spwent { baseop(@_, "setpwent") }
793 sub pp_epwent { baseop(@_, "endpwent") }
794 sub pp_ggrent { baseop(@_, "getgrent") }
795 sub pp_sgrent { baseop(@_, "setgrent") }
796 sub pp_egrent { baseop(@_, "endgrent") }
797 sub pp_getlogin { baseop(@_, "getlogin") }
801 # I couldn't think of a good short name, but this is the category of
802 # symbolic unary operators with interesting precedence
806 my($op, $cx, $name, $prec, $flags) = (@_, 0);
807 my $kid = $op->first;
808 $kid = $self->deparse($kid, $prec);
809 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
813 sub pp_preinc { pfixop(@_, "++", 23) }
814 sub pp_predec { pfixop(@_, "--", 23) }
815 sub pp_postinc { pfixop(@_, "++", 23, POSTFIX) }
816 sub pp_postdec { pfixop(@_, "--", 23, POSTFIX) }
817 sub pp_i_preinc { pfixop(@_, "++", 23) }
818 sub pp_i_predec { pfixop(@_, "--", 23) }
819 sub pp_i_postinc { pfixop(@_, "++", 23, POSTFIX) }
820 sub pp_i_postdec { pfixop(@_, "--", 23, POSTFIX) }
821 sub pp_complement { pfixop(@_, "~", 21) }
826 if ($op->first->ppaddr =~ /^pp_(i_)?negate$/) {
828 $self->pfixop($op, $cx, "-", 21.5);
830 $self->pfixop($op, $cx, "-", 21);
833 sub pp_i_negate { pp_negate(@_) }
839 $self->pfixop($op, $cx, "not ", 4);
841 $self->pfixop($op, $cx, "!", 21);
847 my($op, $cx, $name) = @_;
849 if ($op->flags & OPf_KIDS) {
851 return $self->maybe_parens_unop($name, $kid, $cx);
853 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
857 sub pp_chop { unop(@_, "chop") }
858 sub pp_chomp { unop(@_, "chomp") }
859 sub pp_schop { unop(@_, "chop") }
860 sub pp_schomp { unop(@_, "chomp") }
861 sub pp_defined { unop(@_, "defined") }
862 sub pp_undef { unop(@_, "undef") }
863 sub pp_study { unop(@_, "study") }
864 sub pp_ref { unop(@_, "ref") }
865 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
867 sub pp_sin { unop(@_, "sin") }
868 sub pp_cos { unop(@_, "cos") }
869 sub pp_rand { unop(@_, "rand") }
870 sub pp_srand { unop(@_, "srand") }
871 sub pp_exp { unop(@_, "exp") }
872 sub pp_log { unop(@_, "log") }
873 sub pp_sqrt { unop(@_, "sqrt") }
874 sub pp_int { unop(@_, "int") }
875 sub pp_hex { unop(@_, "hex") }
876 sub pp_oct { unop(@_, "oct") }
877 sub pp_abs { unop(@_, "abs") }
879 sub pp_length { unop(@_, "length") }
880 sub pp_ord { unop(@_, "ord") }
881 sub pp_chr { unop(@_, "chr") }
883 sub pp_each { unop(@_, "each") }
884 sub pp_values { unop(@_, "values") }
885 sub pp_keys { unop(@_, "keys") }
886 sub pp_pop { unop(@_, "pop") }
887 sub pp_shift { unop(@_, "shift") }
889 sub pp_caller { unop(@_, "caller") }
890 sub pp_reset { unop(@_, "reset") }
891 sub pp_exit { unop(@_, "exit") }
892 sub pp_prototype { unop(@_, "prototype") }
894 sub pp_close { unop(@_, "close") }
895 sub pp_fileno { unop(@_, "fileno") }
896 sub pp_umask { unop(@_, "umask") }
897 sub pp_binmode { unop(@_, "binmode") }
898 sub pp_untie { unop(@_, "untie") }
899 sub pp_tied { unop(@_, "tied") }
900 sub pp_dbmclose { unop(@_, "dbmclose") }
901 sub pp_getc { unop(@_, "getc") }
902 sub pp_eof { unop(@_, "eof") }
903 sub pp_tell { unop(@_, "tell") }
904 sub pp_getsockname { unop(@_, "getsockname") }
905 sub pp_getpeername { unop(@_, "getpeername") }
907 sub pp_chdir { unop(@_, "chdir") }
908 sub pp_chroot { unop(@_, "chroot") }
909 sub pp_readlink { unop(@_, "readlink") }
910 sub pp_rmdir { unop(@_, "rmdir") }
911 sub pp_readdir { unop(@_, "readdir") }
912 sub pp_telldir { unop(@_, "telldir") }
913 sub pp_rewinddir { unop(@_, "rewinddir") }
914 sub pp_closedir { unop(@_, "closedir") }
915 sub pp_getpgrp { unop(@_, "getpgrp") }
916 sub pp_localtime { unop(@_, "localtime") }
917 sub pp_gmtime { unop(@_, "gmtime") }
918 sub pp_alarm { unop(@_, "alarm") }
919 sub pp_sleep { unop(@_, "sleep") }
921 sub pp_dofile { unop(@_, "do") }
922 sub pp_entereval { unop(@_, "eval") }
924 sub pp_ghbyname { unop(@_, "gethostbyname") }
925 sub pp_gnbyname { unop(@_, "getnetbyname") }
926 sub pp_gpbyname { unop(@_, "getprotobyname") }
927 sub pp_shostent { unop(@_, "sethostent") }
928 sub pp_snetent { unop(@_, "setnetent") }
929 sub pp_sprotoent { unop(@_, "setprotoent") }
930 sub pp_sservent { unop(@_, "setservent") }
931 sub pp_gpwnam { unop(@_, "getpwnam") }
932 sub pp_gpwuid { unop(@_, "getpwuid") }
933 sub pp_ggrnam { unop(@_, "getgrnam") }
934 sub pp_ggrgid { unop(@_, "getgrgid") }
936 sub pp_lock { unop(@_, "lock") }
941 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
949 if ($op->private & OPpSLICE) {
950 return $self->maybe_parens_func("delete",
951 $self->pp_hslice($op->first, 16),
954 return $self->maybe_parens_func("delete",
955 $self->pp_helem($op->first, 16),
963 if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const"
964 and $op->first->private & OPpCONST_BARE)
966 my $name = $op->first->sv->PV;
969 return "require($name)";
971 $self->unop($op, $cx, "require");
978 my $kid = $op->first;
979 if (not null $kid->sibling) {
981 return $self->dquote($op);
983 $self->unop(@_, "scalar");
990 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
996 my $kid = $op->first;
997 if ($kid->ppaddr eq "pp_null") {
999 if ($kid->ppaddr eq "pp_anonlist" || $kid->ppaddr eq "pp_anonhash") {
1000 my($pre, $post) = @{{"pp_anonlist" => ["[","]"],
1001 "pp_anonhash" => ["{","}"]}->{$kid->ppaddr}};
1003 $kid = $kid->first->sibling; # skip pushmark
1004 for (; !null($kid); $kid = $kid->sibling) {
1005 $expr = $self->deparse($kid, 6);
1008 return $pre . join(", ", @exprs) . $post;
1009 } elsif (!null($kid->sibling) and
1010 $kid->sibling->ppaddr eq "pp_anoncode") {
1012 $self->deparse_sub($self->padval($kid->sibling->targ));
1013 } elsif ($kid->ppaddr eq "pp_pushmark") {
1014 my $sib_ppaddr = $kid->sibling->ppaddr;
1015 if ($sib_ppaddr =~ /^pp_(pad|rv2)[ah]v$/
1016 and not $kid->sibling->flags & OPf_REF)
1018 # The @a in \(@a) isn't in ref context, but only when the
1020 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1021 } elsif ($sib_ppaddr eq 'pp_entersub') {
1022 my $text = $self->deparse($kid->sibling, 1);
1023 # Always show parens for \(&func()), but only with -p otherwise
1024 $text = "($text)" if $self->{'parens'}
1025 or $kid->sibling->private & OPpENTERSUB_AMPER;
1030 $self->pfixop($op, $cx, "\\", 20);
1033 sub pp_srefgen { pp_refgen(@_) }
1038 my $kid = $op->first;
1039 $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh>
1040 return "<" . $self->deparse($kid, 1) . ">";
1043 # Unary operators that can occur as pseudo-listops inside double quotes
1046 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1048 if ($op->flags & OPf_KIDS) {
1050 # If there's more than one kid, the first is an ex-pushmark.
1051 $kid = $kid->sibling if not null $kid->sibling;
1052 return $self->maybe_parens_unop($name, $kid, $cx);
1054 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1058 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1059 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1060 sub pp_uc { dq_unop(@_, "uc") }
1061 sub pp_lc { dq_unop(@_, "lc") }
1062 sub pp_quotemeta { dq_unop(@_, "quotemeta") }
1066 my ($op, $cx, $name) = @_;
1067 if (class($op) eq "PVOP") {
1068 return "$name " . $op->pv;
1069 } elsif (class($op) eq "OP") {
1071 } elsif (class($op) eq "UNOP") {
1072 # Note -- loop exits are actually exempt from the
1073 # looks-like-a-func rule, but a few extra parens won't hurt
1074 return $self->maybe_parens_unop($name, $op->first, $cx);
1078 sub pp_last { loopex(@_, "last") }
1079 sub pp_next { loopex(@_, "next") }
1080 sub pp_redo { loopex(@_, "redo") }
1081 sub pp_goto { loopex(@_, "goto") }
1082 sub pp_dump { loopex(@_, "dump") }
1086 my($op, $cx, $name) = @_;
1087 if (class($op) eq "UNOP") {
1088 # Genuine `-X' filetests are exempt from the LLAFR, but not
1089 # l?stat(); for the sake of clarity, give'em all parens
1090 return $self->maybe_parens_unop($name, $op->first, $cx);
1091 } elsif (class($op) eq "GVOP") {
1092 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1093 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1098 sub pp_lstat { ftst(@_, "lstat") }
1099 sub pp_stat { ftst(@_, "stat") }
1100 sub pp_ftrread { ftst(@_, "-R") }
1101 sub pp_ftrwrite { ftst(@_, "-W") }
1102 sub pp_ftrexec { ftst(@_, "-X") }
1103 sub pp_fteread { ftst(@_, "-r") }
1104 sub pp_ftewrite { ftst(@_, "-r") }
1105 sub pp_fteexec { ftst(@_, "-r") }
1106 sub pp_ftis { ftst(@_, "-e") }
1107 sub pp_fteowned { ftst(@_, "-O") }
1108 sub pp_ftrowned { ftst(@_, "-o") }
1109 sub pp_ftzero { ftst(@_, "-z") }
1110 sub pp_ftsize { ftst(@_, "-s") }
1111 sub pp_ftmtime { ftst(@_, "-M") }
1112 sub pp_ftatime { ftst(@_, "-A") }
1113 sub pp_ftctime { ftst(@_, "-C") }
1114 sub pp_ftsock { ftst(@_, "-S") }
1115 sub pp_ftchr { ftst(@_, "-c") }
1116 sub pp_ftblk { ftst(@_, "-b") }
1117 sub pp_ftfile { ftst(@_, "-f") }
1118 sub pp_ftdir { ftst(@_, "-d") }
1119 sub pp_ftpipe { ftst(@_, "-p") }
1120 sub pp_ftlink { ftst(@_, "-l") }
1121 sub pp_ftsuid { ftst(@_, "-u") }
1122 sub pp_ftsgid { ftst(@_, "-g") }
1123 sub pp_ftsvtx { ftst(@_, "-k") }
1124 sub pp_fttty { ftst(@_, "-t") }
1125 sub pp_fttext { ftst(@_, "-T") }
1126 sub pp_ftbinary { ftst(@_, "-B") }
1128 sub SWAP_CHILDREN () { 1 }
1129 sub ASSIGN () { 2 } # has OP= variant
1135 my $name = $op->ppaddr;
1136 if ($name eq "pp_concat" and $op->first->ppaddr eq "pp_concat") {
1137 # avoid spurious `=' -- see comment in pp_concat
1140 if ($name eq "pp_null" and class($op) eq "UNOP"
1141 and $op->first->ppaddr =~ /^pp_(and|x?or)$/
1142 and null $op->first->sibling)
1144 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1145 # with a null that's used as the common end point of the two
1146 # flows of control. For precedence purposes, ignore it.
1147 # (COND_EXPRs have these too, but we don't bother with
1148 # their associativity).
1149 return assoc_class($op->first);
1151 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1154 # Left associative operators, like `+', for which
1155 # $a + $b + $c is equivalent to ($a + $b) + $c
1158 %left = ('pp_multiply' => 19, 'pp_i_multiply' => 19,
1159 'pp_divide' => 19, 'pp_i_divide' => 19,
1160 'pp_modulo' => 19, 'pp_i_modulo' => 19,
1162 'pp_add' => 18, 'pp_i_add' => 18,
1163 'pp_subtract' => 18, 'pp_i_subtract' => 18,
1165 'pp_left_shift' => 17, 'pp_right_shift' => 17,
1167 'pp_bit_or' => 12, 'pp_bit_xor' => 12,
1169 'pp_or' => 2, 'pp_xor' => 2,
1173 sub deparse_binop_left {
1175 my($op, $left, $prec) = @_;
1176 if ($left{assoc_class($op)}
1177 and $left{assoc_class($op)} == $left{assoc_class($left)})
1179 return $self->deparse($left, $prec - .00001);
1181 return $self->deparse($left, $prec);
1185 # Right associative operators, like `=', for which
1186 # $a = $b = $c is equivalent to $a = ($b = $c)
1189 %right = ('pp_pow' => 22,
1190 'pp_sassign=' => 7, 'pp_aassign=' => 7,
1191 'pp_multiply=' => 7, 'pp_i_multiply=' => 7,
1192 'pp_divide=' => 7, 'pp_i_divide=' => 7,
1193 'pp_modulo=' => 7, 'pp_i_modulo=' => 7,
1195 'pp_add=' => 7, 'pp_i_add=' => 7,
1196 'pp_subtract=' => 7, 'pp_i_subtract=' => 7,
1198 'pp_left_shift=' => 7, 'pp_right_shift=' => 7,
1200 'pp_bit_or=' => 7, 'pp_bit_xor=' => 7,
1201 'pp_andassign' => 7,
1206 sub deparse_binop_right {
1208 my($op, $right, $prec) = @_;
1209 if ($right{assoc_class($op)}
1210 and $right{assoc_class($op)} == $right{assoc_class($right)})
1212 return $self->deparse($right, $prec - .00001);
1214 return $self->deparse($right, $prec);
1220 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1221 my $left = $op->first;
1222 my $right = $op->last;
1224 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1228 if ($flags & SWAP_CHILDREN) {
1229 ($left, $right) = ($right, $left);
1231 $left = $self->deparse_binop_left($op, $left, $prec);
1232 $right = $self->deparse_binop_right($op, $right, $prec);
1233 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1236 sub pp_add { binop(@_, "+", 18, ASSIGN) }
1237 sub pp_multiply { binop(@_, "*", 19, ASSIGN) }
1238 sub pp_subtract { binop(@_, "-",18, ASSIGN) }
1239 sub pp_divide { binop(@_, "/", 19, ASSIGN) }
1240 sub pp_modulo { binop(@_, "%", 19, ASSIGN) }
1241 sub pp_i_add { binop(@_, "+", 18, ASSIGN) }
1242 sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) }
1243 sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) }
1244 sub pp_i_divide { binop(@_, "/", 19, ASSIGN) }
1245 sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) }
1246 sub pp_pow { binop(@_, "**", 22, ASSIGN) }
1248 sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) }
1249 sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) }
1250 sub pp_bit_and { binop(@_, "&", 13, ASSIGN) }
1251 sub pp_bit_or { binop(@_, "|", 12, ASSIGN) }
1252 sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) }
1254 sub pp_eq { binop(@_, "==", 14) }
1255 sub pp_ne { binop(@_, "!=", 14) }
1256 sub pp_lt { binop(@_, "<", 15) }
1257 sub pp_gt { binop(@_, ">", 15) }
1258 sub pp_ge { binop(@_, ">=", 15) }
1259 sub pp_le { binop(@_, "<=", 15) }
1260 sub pp_ncmp { binop(@_, "<=>", 14) }
1261 sub pp_i_eq { binop(@_, "==", 14) }
1262 sub pp_i_ne { binop(@_, "!=", 14) }
1263 sub pp_i_lt { binop(@_, "<", 15) }
1264 sub pp_i_gt { binop(@_, ">", 15) }
1265 sub pp_i_ge { binop(@_, ">=", 15) }
1266 sub pp_i_le { binop(@_, "<=", 15) }
1267 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1269 sub pp_seq { binop(@_, "eq", 14) }
1270 sub pp_sne { binop(@_, "ne", 14) }
1271 sub pp_slt { binop(@_, "lt", 15) }
1272 sub pp_sgt { binop(@_, "gt", 15) }
1273 sub pp_sge { binop(@_, "ge", 15) }
1274 sub pp_sle { binop(@_, "le", 15) }
1275 sub pp_scmp { binop(@_, "cmp", 14) }
1277 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1278 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1280 # `.' is special because concats-of-concats are optimized to save copying
1281 # by making all but the first concat stacked. The effect is as if the
1282 # programmer had written `($a . $b) .= $c', except legal.
1286 my $left = $op->first;
1287 my $right = $op->last;
1290 if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") {
1294 $left = $self->deparse_binop_left($op, $left, $prec);
1295 $right = $self->deparse_binop_right($op, $right, $prec);
1296 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1299 # `x' is weird when the left arg is a list
1303 my $left = $op->first;
1304 my $right = $op->last;
1307 if ($op->flags & OPf_STACKED) {
1311 if (null($right)) { # list repeat; count is inside left-side ex-list
1312 my $kid = $left->first->sibling; # skip pushmark
1314 for (; !null($kid->sibling); $kid = $kid->sibling) {
1315 push @exprs, $self->deparse($kid, 6);
1318 $left = "(" . join(", ", @exprs). ")";
1320 $left = $self->deparse_binop_left($op, $left, $prec);
1322 $right = $self->deparse_binop_right($op, $right, $prec);
1323 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1328 my ($op, $cx, $type) = @_;
1329 my $left = $op->first;
1330 my $right = $left->sibling;
1331 $left = $self->deparse($left, 9);
1332 $right = $self->deparse($right, 9);
1333 return $self->maybe_parens("$left $type $right", $cx, 9);
1339 my $flip = $op->first;
1340 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1341 return $self->range($flip->first, $cx, $type);
1344 # one-line while/until is handled in pp_leave
1348 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1349 my $left = $op->first;
1350 my $right = $op->first->sibling;
1351 if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
1352 $left = $self->deparse($left, 1);
1353 $right = $self->deparse($right, 0);
1354 return "$blockname ($left) {\n\t$right\n\b}\cK";
1355 } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
1356 $right = $self->deparse($right, 1);
1357 $left = $self->deparse($left, 1);
1358 return "$right $blockname $left";
1359 } elsif ($cx > $lowprec and $highop) { # $a && $b
1360 $left = $self->deparse_binop_left($op, $left, $highprec);
1361 $right = $self->deparse_binop_right($op, $right, $highprec);
1362 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1363 } else { # $a and $b
1364 $left = $self->deparse_binop_left($op, $left, $lowprec);
1365 $right = $self->deparse_binop_right($op, $right, $lowprec);
1366 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1370 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1371 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1372 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1376 my ($op, $cx, $opname) = @_;
1377 my $left = $op->first;
1378 my $right = $op->first->sibling->first; # skip sassign
1379 $left = $self->deparse($left, 7);
1380 $right = $self->deparse($right, 7);
1381 return $self->maybe_parens("$left $opname $right", $cx, 7);
1384 sub pp_andassign { logassignop(@_, "&&=") }
1385 sub pp_orassign { logassignop(@_, "||=") }
1389 my($op, $cx, $name) = @_;
1391 my $parens = ($cx >= 5) || $self->{'parens'};
1392 my $kid = $op->first->sibling;
1393 return $name if null $kid;
1394 my $first = $self->deparse($kid, 6);
1395 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1396 push @exprs, $first;
1397 $kid = $kid->sibling;
1398 for (; !null($kid); $kid = $kid->sibling) {
1399 push @exprs, $self->deparse($kid, 6);
1402 return "$name(" . join(", ", @exprs) . ")";
1404 return "$name " . join(", ", @exprs);
1408 sub pp_bless { listop(@_, "bless") }
1409 sub pp_atan2 { listop(@_, "atan2") }
1410 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1411 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1412 sub pp_index { listop(@_, "index") }
1413 sub pp_rindex { listop(@_, "rindex") }
1414 sub pp_sprintf { listop(@_, "sprintf") }
1415 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1416 sub pp_crypt { listop(@_, "crypt") }
1417 sub pp_unpack { listop(@_, "unpack") }
1418 sub pp_pack { listop(@_, "pack") }
1419 sub pp_join { listop(@_, "join") }
1420 sub pp_splice { listop(@_, "splice") }
1421 sub pp_push { listop(@_, "push") }
1422 sub pp_unshift { listop(@_, "unshift") }
1423 sub pp_reverse { listop(@_, "reverse") }
1424 sub pp_warn { listop(@_, "warn") }
1425 sub pp_die { listop(@_, "die") }
1426 # Actually, return is exempt from the LLAFR (see examples in this very
1427 # module!), but for consistency's sake, ignore that fact
1428 sub pp_return { listop(@_, "return") }
1429 sub pp_open { listop(@_, "open") }
1430 sub pp_pipe_op { listop(@_, "pipe") }
1431 sub pp_tie { listop(@_, "tie") }
1432 sub pp_dbmopen { listop(@_, "dbmopen") }
1433 sub pp_sselect { listop(@_, "select") }
1434 sub pp_select { listop(@_, "select") }
1435 sub pp_read { listop(@_, "read") }
1436 sub pp_sysopen { listop(@_, "sysopen") }
1437 sub pp_sysseek { listop(@_, "sysseek") }
1438 sub pp_sysread { listop(@_, "sysread") }
1439 sub pp_syswrite { listop(@_, "syswrite") }
1440 sub pp_send { listop(@_, "send") }
1441 sub pp_recv { listop(@_, "recv") }
1442 sub pp_seek { listop(@_, "seek") }
1443 sub pp_fcntl { listop(@_, "fcntl") }
1444 sub pp_ioctl { listop(@_, "ioctl") }
1445 sub pp_flock { listop(@_, "flock") }
1446 sub pp_socket { listop(@_, "socket") }
1447 sub pp_sockpair { listop(@_, "sockpair") }
1448 sub pp_bind { listop(@_, "bind") }
1449 sub pp_connect { listop(@_, "connect") }
1450 sub pp_listen { listop(@_, "listen") }
1451 sub pp_accept { listop(@_, "accept") }
1452 sub pp_shutdown { listop(@_, "shutdown") }
1453 sub pp_gsockopt { listop(@_, "getsockopt") }
1454 sub pp_ssockopt { listop(@_, "setsockopt") }
1455 sub pp_chown { listop(@_, "chown") }
1456 sub pp_unlink { listop(@_, "unlink") }
1457 sub pp_chmod { listop(@_, "chmod") }
1458 sub pp_utime { listop(@_, "utime") }
1459 sub pp_rename { listop(@_, "rename") }
1460 sub pp_link { listop(@_, "link") }
1461 sub pp_symlink { listop(@_, "symlink") }
1462 sub pp_mkdir { listop(@_, "mkdir") }
1463 sub pp_open_dir { listop(@_, "opendir") }
1464 sub pp_seekdir { listop(@_, "seekdir") }
1465 sub pp_waitpid { listop(@_, "waitpid") }
1466 sub pp_system { listop(@_, "system") }
1467 sub pp_exec { listop(@_, "exec") }
1468 sub pp_kill { listop(@_, "kill") }
1469 sub pp_setpgrp { listop(@_, "setpgrp") }
1470 sub pp_getpriority { listop(@_, "getpriority") }
1471 sub pp_setpriority { listop(@_, "setpriority") }
1472 sub pp_shmget { listop(@_, "shmget") }
1473 sub pp_shmctl { listop(@_, "shmctl") }
1474 sub pp_shmread { listop(@_, "shmread") }
1475 sub pp_shmwrite { listop(@_, "shmwrite") }
1476 sub pp_msgget { listop(@_, "msgget") }
1477 sub pp_msgctl { listop(@_, "msgctl") }
1478 sub pp_msgsnd { listop(@_, "msgsnd") }
1479 sub pp_msgrcv { listop(@_, "msgrcv") }
1480 sub pp_semget { listop(@_, "semget") }
1481 sub pp_semctl { listop(@_, "semctl") }
1482 sub pp_semop { listop(@_, "semop") }
1483 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1484 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1485 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1486 sub pp_gsbyname { listop(@_, "getservbyname") }
1487 sub pp_gsbyport { listop(@_, "getservbyport") }
1488 sub pp_syscall { listop(@_, "syscall") }
1493 my $text = $self->dq($op->first->sibling); # skip pushmark
1494 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1495 or $text =~ /[<>]/) {
1496 return 'glob(' . single_delim('qq', '"', $text) . ')';
1498 return '<' . $text . '>';
1502 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1503 # be a filehandle. This could probably be better fixed in the core
1504 # by moving the GV lookup into ck_truc.
1510 my $parens = ($cx >= 5) || $self->{'parens'};
1511 my $kid = $op->first->sibling;
1513 if ($op->flags & OPf_SPECIAL) {
1514 # $kid is an OP_CONST
1517 $fh = $self->deparse($kid, 6);
1518 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1520 my $len = $self->deparse($kid->sibling, 6);
1522 return "truncate($fh, $len)";
1524 return "truncate $fh, $len";
1530 my($op, $cx, $name) = @_;
1532 my $kid = $op->first->sibling;
1534 if ($op->flags & OPf_STACKED) {
1536 $indir = $indir->first; # skip rv2gv
1537 if (is_scope($indir)) {
1538 $indir = "{" . $self->deparse($indir, 0) . "}";
1540 $indir = $self->deparse($indir, 24);
1542 $indir = $indir . " ";
1543 $kid = $kid->sibling;
1545 for (; !null($kid); $kid = $kid->sibling) {
1546 $expr = $self->deparse($kid, 6);
1549 return $self->maybe_parens_func($name,
1550 $indir . join(", ", @exprs),
1554 sub pp_prtf { indirop(@_, "printf") }
1555 sub pp_print { indirop(@_, "print") }
1556 sub pp_sort { indirop(@_, "sort") }
1560 my($op, $cx, $name) = @_;
1562 my $kid = $op->first; # this is the (map|grep)start
1563 $kid = $kid->first->sibling; # skip a pushmark
1564 my $code = $kid->first; # skip a null
1565 if (is_scope $code) {
1566 $code = "{" . $self->deparse($code, 0) . "} ";
1568 $code = $self->deparse($code, 24) . ", ";
1570 $kid = $kid->sibling;
1571 for (; !null($kid); $kid = $kid->sibling) {
1572 $expr = $self->deparse($kid, 6);
1573 push @exprs, $expr if $expr;
1575 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1578 sub pp_mapwhile { mapop(@_, "map") }
1579 sub pp_grepwhile { mapop(@_, "grep") }
1585 my $kid = $op->first->sibling; # skip pushmark
1587 my $local = "either"; # could be local(...) or my(...)
1588 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1589 # This assumes that no other private flags equal 128, and that
1590 # OPs that store things other than flags in their op_private,
1591 # like OP_AELEMFAST, won't be immediate children of a list.
1592 unless ($lop->private & OPpLVAL_INTRO or $lop->ppaddr eq "pp_undef")
1594 $local = ""; # or not
1597 if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my()
1598 ($local = "", last) if $local eq "local";
1600 } elsif ($lop->ppaddr ne "pp_undef") { # local()
1601 ($local = "", last) if $local eq "my";
1605 $local = "" if $local eq "either"; # no point if it's all undefs
1606 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
1607 for (; !null($kid); $kid = $kid->sibling) {
1609 if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") {
1614 $self->{'avoid_local'}{$$lop}++;
1615 $expr = $self->deparse($kid, 6);
1616 delete $self->{'avoid_local'}{$$lop};
1618 $expr = $self->deparse($kid, 6);
1623 return "$local(" . join(", ", @exprs) . ")";
1625 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1632 my $cond = $op->first;
1633 my $true = $cond->sibling;
1634 my $false = $true->sibling;
1635 my $cuddle = $self->{'cuddle'};
1636 unless ($cx == 0 and is_scope($true) and is_scope($false)) {
1637 $cond = $self->deparse($cond, 8);
1638 $true = $self->deparse($true, 8);
1639 $false = $self->deparse($false, 8);
1640 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1642 $cond = $self->deparse($cond, 1);
1643 $true = $self->deparse($true, 0);
1644 if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif
1645 my $head = "if ($cond) {\n\t$true\n\b}";
1647 while (!null($false) and $false->ppaddr eq "pp_lineseq") {
1648 my $newop = $false->first->sibling->first;
1649 my $newcond = $newop->first;
1650 my $newtrue = $newcond->sibling;
1651 $false = $newtrue->sibling; # last in chain is OP_AND => no else
1652 $newcond = $self->deparse($newcond, 1);
1653 $newtrue = $self->deparse($newtrue, 0);
1654 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1656 if (!null($false)) {
1657 $false = $cuddle . "else {\n\t" .
1658 $self->deparse($false, 0) . "\n\b}\cK";
1662 return $head . join($cuddle, "", @elsifs) . $false;
1664 $false = $self->deparse($false, 0);
1665 return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
1671 my $enter = $op->first;
1672 my $kid = $enter->sibling;
1673 local($self->{'curstash'}) = $self->{'curstash'};
1676 if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop
1677 if (is_state $kid->last) { # infinite
1678 $head = "for (;;) "; # shorter than while (1)
1682 } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach
1683 my $ary = $enter->first->sibling; # first was pushmark
1684 my $var = $ary->sibling;
1685 if ($enter->flags & OPf_STACKED
1686 and not null $ary->first->sibling->sibling)
1688 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1689 $self->deparse($ary->first->sibling->sibling, 9);
1691 $ary = $self->deparse($ary, 1);
1694 if ($enter->flags & OPf_SPECIAL) { # thread special var
1695 $var = $self->pp_threadsv($enter, 1);
1696 } else { # regular my() variable
1697 $var = $self->pp_padsv($enter, 1);
1698 if ($self->padname_sv($enter->targ)->IVX ==
1699 $kid->first->first->sibling->last->cop_seq)
1701 # If the scope of this variable closes at the last
1702 # statement of the loop, it must have been
1704 $var = "my " . $var;
1707 } elsif ($var->ppaddr eq "pp_rv2gv") {
1708 $var = $self->pp_rv2sv($var, 1);
1709 } elsif ($var->ppaddr eq "pp_gv") {
1710 $var = "\$" . $self->deparse($var, 1);
1712 $head = "foreach $var ($ary) ";
1713 $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1714 } elsif ($kid->ppaddr eq "pp_null") { # while/until
1716 my $name = {"pp_and" => "while", "pp_or" => "until"}
1718 $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
1719 $kid = $kid->first->sibling;
1720 } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty
1721 return "{;}"; # {} could be a hashref
1723 # The third-to-last kid is the continue block if the pointer used
1724 # by `next BLOCK' points to its first OP, which happens to be the
1725 # the op_next of the head of the _previous_ statement.
1726 # Unless it's a bare loop, in which case it's last, since there's
1727 # no unstack or extra nextstate.
1728 # Except if the previous head isn't null but the first kid is
1729 # (because it's a nulled out nextstate in a scope), in which
1730 # case the head's next is advanced past the null but the nextop's
1731 # isn't, so we need to try nextop->next.
1733 my $cont = $kid->first;
1735 while (!null($cont->sibling)) {
1737 $cont = $cont->sibling;
1740 while (!null($cont->sibling->sibling->sibling)) {
1742 $cont = $cont->sibling;
1745 if ($precont and $ {$precont->next} == $ {$enter->nextop}
1746 || $ {$precont->next} == $ {$enter->nextop->next} )
1748 my $state = $kid->first;
1749 my $cuddle = $self->{'cuddle'};
1751 for (; $$state != $$cont; $state = $state->sibling) {
1753 if (is_state $state) {
1754 $expr = $self->deparse($state, 0);
1755 $state = $state->sibling;
1758 $expr .= $self->deparse($state, 0);
1759 push @exprs, $expr if $expr;
1761 $kid = join(";\n", @exprs);
1762 $cont = $cuddle . "continue {\n\t" .
1763 $self->deparse($cont, 0) . "\n\b}\cK";
1766 $kid = $self->deparse($kid, 0);
1768 return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1773 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1776 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
1777 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
1782 if (class($op) eq "OP") {
1784 return $self->{'ex_const'} if $op->targ == OP_CONST;
1785 } elsif ($op->first->ppaddr eq "pp_pushmark") {
1786 return $self->pp_list($op, $cx);
1787 } elsif ($op->first->ppaddr eq "pp_enter") {
1788 return $self->pp_leave($op, $cx);
1789 } elsif ($op->targ == OP_STRINGIFY) {
1790 return $self->dquote($op);
1791 } elsif (!null($op->first->sibling) and
1792 $op->first->sibling->ppaddr eq "pp_readline" and
1793 $op->first->sibling->flags & OPf_STACKED) {
1794 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1795 . $self->deparse($op->first->sibling, 7),
1797 } elsif (!null($op->first->sibling) and
1798 $op->first->sibling->ppaddr eq "pp_trans" and
1799 $op->first->sibling->flags & OPf_STACKED) {
1800 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1801 . $self->deparse($op->first->sibling, 20),
1804 return $self->deparse($op->first, $cx);
1808 # the aassign in-common check messes up SvCUR (always setting it
1809 # to a value >= 100), but it's probably safe to assume there
1810 # won't be any NULs in the names of my() variables. (with
1811 # stash variables, I wouldn't be so sure)
1814 $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
1821 my $str = $self->padname_sv($targ)->PV;
1822 return padname_fix($str);
1828 return substr($self->padname($op->targ), 1); # skip $/@/%
1834 return $self->maybe_my($op, $cx, $self->padname($op->targ));
1837 sub pp_padav { pp_padsv(@_) }
1838 sub pp_padhv { pp_padsv(@_) }
1843 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1844 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1845 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1852 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
1858 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
1864 return $self->gv_name($op->gv);
1871 return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1876 my($op, $cx, $type) = @_;
1877 my $kid = $op->first;
1878 my $str = $self->deparse($kid, 0);
1879 return $type . (is_scalar($kid) ? $str : "{$str}");
1882 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1883 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1884 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1890 if ($op->first->ppaddr eq "pp_padav") {
1891 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1893 return $self->maybe_local($op, $cx,
1894 $self->rv2x($op->first, $cx, '$#'));
1898 # skip down to the old, ex-rv2cv
1899 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
1904 my $kid = $op->first;
1905 if ($kid->ppaddr eq "pp_const") { # constant list
1907 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1909 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
1916 my ($op, $cx, $left, $right, $padname) = @_;
1917 my($array, $idx) = ($op->first, $op->first->sibling);
1918 unless ($array->ppaddr eq $padname) { # Maybe this has been fixed
1919 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1921 if ($array->ppaddr eq $padname) {
1922 $array = $self->padany($array);
1923 } elsif (is_scope($array)) { # ${expr}[0]
1924 $array = "{" . $self->deparse($array, 0) . "}";
1925 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
1926 $array = $self->deparse($array, 24);
1928 # $x[20][3]{hi} or expr->[20]
1930 $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/;
1931 return $self->deparse($array, 24) . $arrow .
1932 $left . $self->deparse($idx, 1) . $right;
1934 $idx = $self->deparse($idx, 1);
1935 return "\$" . $array . $left . $idx . $right;
1938 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) }
1939 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) }
1944 my($glob, $part) = ($op->first, $op->last);
1945 $glob = $glob->first; # skip rv2gv
1946 $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug
1947 my $scope = is_scope($glob);
1948 $glob = $self->deparse($glob, 0);
1949 $part = $self->deparse($part, 1);
1950 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
1955 my ($op, $cx, $left, $right, $regname, $padname) = @_;
1957 my(@elems, $kid, $array, $list);
1958 if (class($op) eq "LISTOP") {
1960 } else { # ex-hslice inside delete()
1961 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
1965 $array = $array->first
1966 if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null";
1967 if (is_scope($array)) {
1968 $array = "{" . $self->deparse($array, 0) . "}";
1969 } elsif ($array->ppaddr eq $padname) {
1970 $array = $self->padany($array);
1972 $array = $self->deparse($array, 24);
1974 $kid = $op->first->sibling; # skip pushmark
1975 if ($kid->ppaddr eq "pp_list") {
1976 $kid = $kid->first->sibling; # skip list, pushmark
1977 for (; !null $kid; $kid = $kid->sibling) {
1978 push @elems, $self->deparse($kid, 6);
1980 $list = join(", ", @elems);
1982 $list = $self->deparse($kid, 1);
1984 return "\@" . $array . $left . $list . $right;
1987 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]",
1988 "pp_rv2av", "pp_padav")) }
1989 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
1990 "pp_rv2hv", "pp_padhv")) }
1995 my $idx = $op->first;
1996 my $list = $op->last;
1998 $list = $self->deparse($list, 1);
1999 $idx = $self->deparse($idx, 1);
2000 return "($list)" . "[$idx]";
2005 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2010 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2016 my $kid = $op->first->sibling; # skip pushmark
2017 my($meth, $obj, @exprs);
2018 if ($kid->ppaddr eq "pp_list" and want_list $kid) {
2019 # When an indirect object isn't a bareword but the args are in
2020 # parens, the parens aren't part of the method syntax (the LLAFR
2021 # doesn't apply), but they make a list with OPf_PARENS set that
2022 # doesn't get flattened by the append_elem that adds the method,
2023 # making a (object, arg1, arg2, ...) list where the object
2024 # usually is. This can be distinguished from
2025 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2026 # object) because in the later the list is in scalar context
2027 # as the left side of -> always is, while in the former
2028 # the list is in list context as method arguments always are.
2029 # (Good thing there aren't method prototypes!)
2030 $meth = $kid->sibling->first;
2031 $kid = $kid->first->sibling; # skip pushmark
2033 $kid = $kid->sibling;
2034 for (; not null $kid; $kid = $kid->sibling) {
2035 push @exprs, $self->deparse($kid, 6);
2039 $kid = $kid->sibling;
2040 for (; not null $kid->sibling; $kid = $kid->sibling) {
2041 push @exprs, $self->deparse($kid, 6);
2043 $meth = $kid->first;
2045 $obj = $self->deparse($obj, 24);
2046 if ($meth->ppaddr eq "pp_const") {
2047 $meth = $meth->sv->PV; # needs to be bare
2049 $meth = $self->deparse($meth, 1);
2051 my $args = join(", ", @exprs);
2052 $kid = $obj . "->" . $meth;
2054 return $kid . "(" . $args . ")"; # parens mandatory
2060 # returns "&" if the prototype doesn't match the args,
2061 # or ("", $args_after_prototype_demunging) if it does.
2064 my($proto, @args) = @_;
2068 # An unbackslashed @ or % gobbles up the rest of the args
2069 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2071 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2074 return "&" if @args;
2075 } elsif ($chr eq ";") {
2077 } elsif ($chr eq "@" or $chr eq "%") {
2078 push @reals, map($self->deparse($_, 6), @args);
2084 if (want_scalar $arg) {
2085 push @reals, $self->deparse($arg, 6);
2089 } elsif ($chr eq "&") {
2090 if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
2091 push @reals, $self->deparse($arg, 6);
2095 } elsif ($chr eq "*") {
2096 if ($arg->ppaddr =~ /^pp_s?refgen$/
2097 and $arg->first->first->ppaddr eq "pp_rv2gv")
2099 $real = $arg->first->first; # skip refgen, null
2100 if ($real->first->ppaddr eq "pp_gv") {
2101 push @reals, $self->deparse($real, 6);
2103 push @reals, $self->deparse($real->first, 6);
2108 } elsif (substr($chr, 0, 1) eq "\\") {
2109 $chr = substr($chr, 1);
2110 if ($arg->ppaddr =~ /^pp_s?refgen$/ and
2111 !null($real = $arg->first) and
2112 ($chr eq "\$" && is_scalar($real->first)
2114 && $real->first->sibling->ppaddr
2115 =~ /^pp_(rv2|pad)av$/)
2117 && $real->first->sibling->ppaddr
2118 =~ /^pp_(rv2|pad)hv$/)
2119 #or ($chr eq "&" # This doesn't work
2120 # && $real->first->ppaddr eq "pp_rv2cv")
2122 && $real->first->ppaddr eq "pp_rv2gv")))
2124 push @reals, $self->deparse($real, 6);
2131 return "&" if $proto and !$doneok; # too few args and no `;'
2132 return "&" if @args; # too many args
2133 return ("", join ", ", @reals);
2139 return $self->method($op, $cx) unless null $op->first->sibling;
2143 if ($op->flags & OPf_SPECIAL) {
2145 } elsif ($op->private & OPpENTERSUB_AMPER) {
2149 $kid = $kid->first->sibling; # skip ex-list, pushmark
2150 for (; not null $kid->sibling; $kid = $kid->sibling) {
2155 if (is_scope($kid)) {
2157 $kid = "{" . $self->deparse($kid, 0) . "}";
2158 } elsif ($kid->first->ppaddr eq "pp_gv") {
2159 my $gv = $kid->first->gv;
2160 if (class($gv->CV) ne "SPECIAL") {
2161 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2163 $simple = 1; # only calls of named functions can be prototyped
2164 $kid = $self->deparse($kid, 24);
2165 } elsif (is_scalar $kid->first) {
2167 $kid = $self->deparse($kid, 24);
2170 $kid = $self->deparse($kid, 24) . "->";
2173 if (defined $proto and not $amper) {
2174 ($amper, $args) = $self->check_proto($proto, @exprs);
2175 if ($amper eq "&") {
2176 $args = join(", ", map($self->deparse($_, 6), @exprs));
2179 $args = join(", ", map($self->deparse($_, 6), @exprs));
2181 if ($prefix or $amper) {
2182 if ($op->flags & OPf_STACKED) {
2183 return $prefix . $amper . $kid . "(" . $args . ")";
2185 return $prefix . $amper. $kid;
2188 if (defined $proto and $proto eq "") {
2190 } elsif ($proto eq "\$") {
2191 return $self->maybe_parens_func($kid, $args, $cx, 16);
2192 } elsif ($proto or $simple) {
2193 return $self->maybe_parens_func($kid, $args, $cx, 5);
2195 return "$kid(" . $args . ")";
2200 sub pp_enterwrite { unop(@_, "write") }
2202 # escape things that cause interpolation in double quotes,
2203 # but not character escapes
2206 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2210 # the same, but treat $|, $), and $ at the end of the string differently
2213 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2214 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2218 # character escapes, but not delimiters that might need to be escaped
2219 sub escape_str { # ASCII
2222 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2228 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2229 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2233 # Don't do this for regexen
2236 $str =~ s/\\/\\\\/g;
2240 sub balanced_delim {
2242 my @str = split //, $str;
2243 my($ar, $open, $close, $fail, $c, $cnt);
2244 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2245 ($open, $close) = @$ar;
2246 $fail = 0; $cnt = 0;
2250 } elsif ($c eq $close) {
2259 $fail = 1 if $cnt != 0;
2260 return ($open, "$open$str$close") if not $fail;
2266 my($q, $default, $str) = @_;
2267 return "$default$str$default" if $default and index($str, $default) == -1;
2268 my($succeed, $delim);
2269 ($succeed, $str) = balanced_delim($str);
2270 return "$q$str" if $succeed;
2271 for $delim ('/', '"', '#') {
2272 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2275 $str =~ s/$default/\\$default/g;
2276 return "$default$str$default";
2285 if (class($sv) eq "SPECIAL") {
2286 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2287 } elsif ($sv->FLAGS & SVf_IOK) {
2289 } elsif ($sv->FLAGS & SVf_NOK) {
2291 } elsif ($sv->FLAGS & SVf_ROK) {
2292 return "\\(" . const($sv->RV) . ")"; # constant folded
2295 if ($str =~ /[^ -~]/) { # ASCII for non-printing
2296 return single_delim("qq", '"', uninterp escape_str unback $str);
2298 return single_delim("q", "'", unback $str);
2306 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2307 # return $op->sv->PV;
2309 return const($op->sv);
2315 my $type = $op->ppaddr;
2316 if ($type eq "pp_const") {
2317 return uninterp(escape_str(unback($op->sv->PV)));
2318 } elsif ($type eq "pp_concat") {
2319 return $self->dq($op->first) . $self->dq($op->last);
2320 } elsif ($type eq "pp_uc") {
2321 return '\U' . $self->dq($op->first->sibling) . '\E';
2322 } elsif ($type eq "pp_lc") {
2323 return '\L' . $self->dq($op->first->sibling) . '\E';
2324 } elsif ($type eq "pp_ucfirst") {
2325 return '\u' . $self->dq($op->first->sibling);
2326 } elsif ($type eq "pp_lcfirst") {
2327 return '\l' . $self->dq($op->first->sibling);
2328 } elsif ($type eq "pp_quotemeta") {
2329 return '\Q' . $self->dq($op->first->sibling) . '\E';
2330 } elsif ($type eq "pp_join") {
2331 return $self->deparse($op->last, 26); # was join($", @ary)
2333 return $self->deparse($op, 26);
2341 return single_delim("qx", '`', $self->dq($op->first->sibling));
2346 my($op, $cx) = shift;
2347 return $self->deparse($op->first->sibling, $cx) if $self->{'unquote'};
2348 # skip ex-stringify, pushmark
2349 return single_delim("qq", '"', $self->dq($op->first->sibling));
2352 # OP_STRINGIFY is a listop, but it only ever has one arg
2353 sub pp_stringify { dquote(@_) }
2355 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2356 # note that tr(from)/to/ is OK, but not tr/from/(to)
2358 my($from, $to) = @_;
2359 my($succeed, $delim);
2360 if ($from !~ m[/] and $to !~ m[/]) {
2361 return "/$from/$to/";
2362 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2363 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2366 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2367 return "$from$delim$to$delim" if index($to, $delim) == -1;
2370 return "$from/$to/";
2373 for $delim ('/', '"', '#') { # note no '
2374 return "$delim$from$delim$to$delim"
2375 if index($to . $from, $delim) == -1;
2377 $from =~ s[/][\\/]g;
2379 return "/$from/$to/";
2385 if ($n == ord '\\') {
2387 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2389 } elsif ($n == ord "\a") {
2391 } elsif ($n == ord "\b") {
2393 } elsif ($n == ord "\t") {
2395 } elsif ($n == ord "\n") {
2397 } elsif ($n == ord "\e") {
2399 } elsif ($n == ord "\f") {
2401 } elsif ($n == ord "\r") {
2403 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2404 return '\\c' . chr(ord("@") + $n);
2406 # return '\x' . sprintf("%02x", $n);
2407 return '\\' . sprintf("%03o", $n);
2414 for ($c = 0; $c < @chars; $c++) {
2417 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2418 $chars[$c + 2] == $tr + 2)
2420 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2423 $str .= pchr($chars[$c]);
2429 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2432 sub tr_decode_byte {
2433 my($table, $flags) = @_;
2434 my(@table) = unpack("s256", $table);
2435 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2436 if ($table[ord "-"] != -1 and
2437 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2439 $tr = $table[ord "-"];
2440 $table[ord "-"] = -1;
2444 } else { # -2 ==> delete
2448 for ($c = 0; $c < 256; $c++) {
2451 push @from, $c; push @to, $tr;
2452 } elsif ($tr == -2) {
2456 @from = (@from, @delfrom);
2457 if ($flags & OPpTRANS_COMPLEMENT) {
2460 @from{@from} = (1) x @from;
2461 for ($c = 0; $c < 256; $c++) {
2462 push @newfrom, $c unless $from{$c};
2466 unless ($flags & OPpTRANS_DELETE) {
2467 pop @to while $#to and $to[$#to] == $to[$#to -1];
2470 $from = collapse(@from);
2471 $to = collapse(@to);
2472 $from .= "-" if $delhyphen;
2473 return ($from, $to);
2478 if ($x == ord "-") {
2485 # XXX This doesn't yet handle all cases correctly either
2487 sub tr_decode_utf8 {
2488 my($swash_hv, $flags) = @_;
2489 my %swash = $swash_hv->ARRAY;
2491 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
2492 my $none = $swash{"NONE"}->IV;
2493 my $extra = $none + 1;
2494 my(@from, @delfrom, @to);
2496 foreach $line (split /\n/, $swash{'LIST'}->PV) {
2497 my($min, $max, $result) = split(/\t/, $line);
2504 $result = hex $result;
2505 if ($result == $extra) {
2506 push @delfrom, [$min, $max];
2508 push @from, [$min, $max];
2509 push @to, [$result, $result + $max - $min];
2512 for my $i (0 .. $#from) {
2513 if ($from[$i][0] == ord '-') {
2514 unshift @from, splice(@from, $i, 1);
2515 unshift @to, splice(@to, $i, 1);
2517 } elsif ($from[$i][1] == ord '-') {
2520 unshift @from, ord '-';
2521 unshift @to, ord '-';
2525 for my $i (0 .. $#delfrom) {
2526 if ($delfrom[$i][0] == ord '-') {
2527 push @delfrom, splice(@delfrom, $i, 1);
2529 } elsif ($delfrom[$i][1] == ord '-') {
2531 push @delfrom, ord '-';
2535 if (defined $final and $to[$#to][1] != $final) {
2536 push @to, [$final, $final];
2538 push @from, @delfrom;
2539 if ($flags & OPpTRANS_COMPLEMENT) {
2542 for my $i (0 .. $#from) {
2543 push @newfrom, [$next, $from[$i][0] - 1];
2544 $next = $from[$i][1] + 1;
2547 for my $range (@newfrom) {
2548 if ($range->[0] <= $range->[1]) {
2553 my($from, $to, $diff);
2554 for my $chunk (@from) {
2555 $diff = $chunk->[1] - $chunk->[0];
2557 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2558 } elsif ($diff == 1) {
2559 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2561 $from .= tr_chr($chunk->[0]);
2564 for my $chunk (@to) {
2565 $diff = $chunk->[1] - $chunk->[0];
2567 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2568 } elsif ($diff == 1) {
2569 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2571 $to .= tr_chr($chunk->[0]);
2574 #$final = sprintf("%04x", $final) if defined $final;
2575 #$none = sprintf("%04x", $none) if defined $none;
2576 #$extra = sprintf("%04x", $extra) if defined $extra;
2577 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
2578 #print STDERR $swash{'LIST'}->PV;
2579 return (escape_str($from), escape_str($to));
2586 if (class($op) eq "PVOP") {
2587 ($from, $to) = tr_decode_byte($op->pv, $op->private);
2588 } else { # class($op) eq "SVOP"
2589 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
2592 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
2593 $flags .= "d" if $op->private & OPpTRANS_DELETE;
2594 $to = "" if $from eq $to and $flags eq "";
2595 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2596 return "tr" . double_delim($from, $to) . $flags;
2599 # Like dq(), but different
2603 my $type = $op->ppaddr;
2604 if ($type eq "pp_const") {
2605 return uninterp($op->sv->PV);
2606 } elsif ($type eq "pp_concat") {
2607 return $self->re_dq($op->first) . $self->re_dq($op->last);
2608 } elsif ($type eq "pp_uc") {
2609 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2610 } elsif ($type eq "pp_lc") {
2611 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2612 } elsif ($type eq "pp_ucfirst") {
2613 return '\u' . $self->re_dq($op->first->sibling);
2614 } elsif ($type eq "pp_lcfirst") {
2615 return '\l' . $self->re_dq($op->first->sibling);
2616 } elsif ($type eq "pp_quotemeta") {
2617 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2618 } elsif ($type eq "pp_join") {
2619 return $self->deparse($op->last, 26); # was join($", @ary)
2621 return $self->deparse($op, 26);
2628 my $kid = $op->first;
2629 $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe";
2630 $kid = $kid->first if $kid->ppaddr eq "pp_regcreset";
2631 return $self->re_dq($kid);
2634 # osmic acid -- see osmium tetroxide
2637 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2638 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2639 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2643 my($op, $cx, $name, $delim) = @_;
2644 my $kid = $op->first;
2645 my ($binop, $var, $re) = ("", "", "");
2646 if ($op->flags & OPf_STACKED) {
2648 $var = $self->deparse($kid, 20);
2649 $kid = $kid->sibling;
2652 $re = re_uninterp(escape_str($op->precomp));
2654 $re = $self->deparse($kid, 1);
2657 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2658 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2659 $flags .= "i" if $op->pmflags & PMf_FOLD;
2660 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2661 $flags .= "o" if $op->pmflags & PMf_KEEP;
2662 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2663 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2664 $flags = $matchwords{$flags} if $matchwords{$flags};
2665 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2669 $re = single_delim($name, $delim, $re);
2673 return $self->maybe_parens("$var =~ $re", $cx, 20);
2679 sub pp_match { matchop(@_, "m", "/") }
2680 sub pp_pushre { matchop(@_, "m", "/") }
2681 sub pp_qr { matchop(@_, "qr", "") }
2686 my($kid, @exprs, $ary, $expr);
2688 if ($ {$kid->pmreplroot}) {
2689 $ary = '@' . $self->gv_name($kid->pmreplroot);
2691 for (; !null($kid); $kid = $kid->sibling) {
2692 push @exprs, $self->deparse($kid, 6);
2694 $expr = "split(" . join(", ", @exprs) . ")";
2696 return $self->maybe_parens("$ary = $expr", $cx, 7);
2702 # oxime -- any of various compounds obtained chiefly by the action of
2703 # hydroxylamine on aldehydes and ketones and characterized by the
2704 # bivalent grouping C=NOH [Webster's Tenth]
2707 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2708 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2709 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2710 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2715 my $kid = $op->first;
2716 my($binop, $var, $re, $repl) = ("", "", "", "");
2717 if ($op->flags & OPf_STACKED) {
2719 $var = $self->deparse($kid, 20);
2720 $kid = $kid->sibling;
2723 if (null($op->pmreplroot)) {
2724 $repl = $self->dq($kid);
2725 $kid = $kid->sibling;
2727 $repl = $op->pmreplroot->first; # skip substcont
2728 while ($repl->ppaddr eq "pp_entereval") {
2729 $repl = $repl->first;
2732 if ($op->pmflags & PMf_EVAL) {
2733 $repl = $self->deparse($repl, 0);
2735 $repl = $self->dq($repl);
2739 $re = re_uninterp(escape_str($op->precomp));
2741 $re = $self->deparse($kid, 1);
2743 $flags .= "e" if $op->pmflags & PMf_EVAL;
2744 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2745 $flags .= "i" if $op->pmflags & PMf_FOLD;
2746 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2747 $flags .= "o" if $op->pmflags & PMf_KEEP;
2748 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2749 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2750 $flags = $substwords{$flags} if $substwords{$flags};
2752 return $self->maybe_parens("$var =~ s"
2753 . double_delim($re, $repl) . $flags,
2756 return "s". double_delim($re, $repl) . $flags;
2765 B::Deparse - Perl compiler backend to produce perl code
2769 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>]
2774 B::Deparse is a backend module for the Perl compiler that generates
2775 perl source code, based on the internal compiled structure that perl
2776 itself creates after parsing a program. The output of B::Deparse won't
2777 be exactly the same as the original source, since perl doesn't keep
2778 track of comments or whitespace, and there isn't a one-to-one
2779 correspondence between perl's syntactical constructions and their
2780 compiled form, but it will often be close. When you use the B<-p>
2781 option, the output also includes parentheses even when they are not
2782 required by precedence, which can make it easy to see if perl is
2783 parsing your expressions the way you intended.
2785 Please note that this module is mainly new and untested code and is
2786 still under development, so it may change in the future.
2790 As with all compiler backend options, these must follow directly after
2791 the '-MO=Deparse', separated by a comma but not any white space.
2797 Add '#line' declarations to the output based on the line and file
2798 locations of the original code.
2802 Print extra parentheses. Without this option, B::Deparse includes
2803 parentheses in its output only when they are needed, based on the
2804 structure of your program. With B<-p>, it uses parentheses (almost)
2805 whenever they would be legal. This can be useful if you are used to
2806 LISP, or if you want to see how perl parses your input. If you say
2808 if ($var & 0x7f == 65) {print "Gimme an A!"}
2809 print ($which ? $a : $b), "\n";
2810 $name = $ENV{USER} or "Bob";
2812 C<B::Deparse,-p> will print
2815 print('Gimme an A!')
2817 (print(($which ? $a : $b)), '???');
2818 (($name = $ENV{'USER'}) or '???')
2820 which probably isn't what you intended (the C<'???'> is a sign that
2821 perl optimized away a constant value).
2825 Expand double-quoted strings into the corresponding combinations of
2826 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
2829 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
2833 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
2834 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
2836 Note that the expanded form represents the way perl handles such
2837 constructions internally -- this option actually turns off the reverse
2838 translation that B::Deparse usually does. On the other hand, note that
2839 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
2840 of $y into a string before doing the assignment.
2842 =item B<-u>I<PACKAGE>
2844 Normally, B::Deparse deparses the main code of a program, all the subs
2845 called by the main program (and all the subs called by them,
2846 recursively), and any other subs in the main:: package. To include
2847 subs in other packages that aren't called directly, such as AUTOLOAD,
2848 DESTROY, other subs called automatically by perl, and methods (which
2849 aren't resolved to subs until runtime), use the B<-u> option. The
2850 argument to B<-u> is the name of a package, and should follow directly
2851 after the 'u'. Multiple B<-u> options may be given, separated by
2852 commas. Note that unlike some other backends, B::Deparse doesn't
2853 (yet) try to guess automatically when B<-u> is needed -- you must
2856 =item B<-s>I<LETTERS>
2858 Tweak the style of B::Deparse's output. The letters should follow
2859 directly after the 's', with no space or punctuation. The following
2860 options are available:
2866 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2883 The default is not to cuddle.
2887 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
2891 Use tabs for each 8 columns of indent. The default is to use only spaces.
2892 For instance, if the style options are B<-si4T>, a line that's indented
2893 3 times will be preceded by one tab and four spaces; if the options were
2894 B<-si8T>, the same line would be preceded by three tabs.
2896 =item B<v>I<STRING>B<.>
2898 Print I<STRING> for the value of a constant that can't be determined
2899 because it was optimized away (mnemonic: this happens when a constant
2900 is used in B<v>oid context). The end of the string is marked by a period.
2901 The string should be a valid perl expression, generally a constant.
2902 Note that unless it's a number, it probably needs to be quoted, and on
2903 a command line quotes need to be protected from the shell. Some
2904 conventional values include 0, 1, 42, '', 'foo', and
2905 'Useless use of constant omitted' (which may need to be
2906 B<-sv"'Useless use of constant omitted'.">
2907 or something similar depending on your shell). The default is '???'.
2908 If you're using B::Deparse on a module or other file that's require'd,
2909 you shouldn't use a value that evaluates to false, since the customary
2910 true constant at the end of a module will be in void context when the
2911 file is compiled as a main program.
2917 =head1 USING B::Deparse AS A MODULE
2922 $deparse = B::Deparse->new("-p", "-sC");
2923 $body = $deparse->coderef2text(\&func);
2924 eval "sub func $body"; # the inverse operation
2928 B::Deparse can also be used on a sub-by-sub basis from other perl
2933 $deparse = B::Deparse->new(OPTIONS)
2935 Create an object to store the state of a deparsing operation and any
2936 options. The options are the same as those that can be given on the
2937 command line (see L</OPTIONS>); options that are separated by commas
2938 after B<-MO=Deparse> should be given as separate strings. Some
2939 options, like B<-u>, don't make sense for a single subroutine, so
2944 $body = $deparse->coderef2text(\&func)
2945 $body = $deparse->coderef2text(sub ($$) { ... })
2947 Return source code for the body of a subroutine (a block, optionally
2948 preceded by a prototype in parens), given a reference to the
2949 sub. Because a subroutine can have no names, or more than one name,
2950 this method doesn't return a complete subroutine definition -- if you
2951 want to eval the result, you should prepend "sub subname ", or "sub "
2952 for an anonymous function constructor. Unless the sub was defined in
2953 the main:: package, the code will include a package declaration.
2957 See the 'to do' list at the beginning of the module file.
2961 Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier
2962 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
2963 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
2964 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.