2 # Copyright (c) 1998 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.
11 use B qw(class main_root main_start main_cv svref_2object);
15 # Changes between 0.50 and 0.51:
16 # - fixed nulled leave with live enter in sort { }
17 # - fixed reference constants (\"str")
18 # - handle empty programs gracefully
19 # - handle infinte loops (for (;;) {}, while (1) {})
20 # - differentiate between `for my $x ...' and `my $x; for $x ...'
21 # - various minor cleanups
22 # - moved globals into an object
23 # - added `-u', like B::C
24 # - package declarations using cop_stash
25 # - subs, formats and code sorted by cop_seq
26 # Changes between 0.51 and 0.52:
27 # - added pp_threadsv (special variables under USE_THREADS)
28 # - added documentation
29 # Changes between 0.52 and 0.53
30 # - many changes adding precedence contexts and associativity
31 # - added `-p' and `-s' output style options
32 # - various other minor fixes
33 # Changes between 0.53 and 0.54
34 # - added support for new `for (1..100)' optimization,
36 # Changes between 0.54 and 0.55
37 # - added support for new qr// construct
38 # - added support for new pp_regcreset OP
39 # Changes between 0.55 and 0.56
40 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
41 # - fixed $# on non-lexicals broken in last big rewrite
42 # - added temporary fix for change in opcode of OP_STRINGIFY
43 # - fixed problem in 0.54's for() patch in `for (@ary)'
44 # - fixed precedence in conditional of ?:
45 # - tweaked list paren elimination in `my($x) = @_'
46 # - made continue-block detection trickier wrt. null ops
47 # - fixed various prototype problems in pp_entersub
48 # - added support for sub prototypes that never get GVs
49 # - added unquoting for special filehandle first arg in truncate
50 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
51 # - added semicolons at the ends of blocks
52 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
55 # - {} around variables in strings ("${var}letters")
58 # - generate symbolic constants directly from core source
59 # - left/right context
60 # - avoid semis in one-statement blocks
61 # - associativity of &&=, ||=, ?:
62 # - ',' => '=>' (auto-unquote?)
63 # - break long lines ("\r" as discretionary break?)
64 # - include values of variables (e.g. set in BEGIN)
65 # - coordinate with Data::Dumper (both directions? see previous)
66 # - version using op_next instead of op_first/sibling?
67 # - avoid string copies (pass arrays, one big join?)
69 # - while{} with one-statement continue => for(; XXX; XXX) {}?
70 # - -uPackage:: descend recursively?
74 # Tests that will always fail:
75 # comp/redef.t -- all (redefinition happens at compile time)
77 # Object fields (were globals):
80 # (local($a), local($b)) and local($a, $b) have the same internal
81 # representation but the short form looks better. We notice we can
82 # use a large-scale local when checking the list, but need to prevent
83 # individual locals too. This hash holds the addresses of OPs that
84 # have already had their local-ness accounted for. The same thing
88 # CV for current sub (or main program) being deparsed
91 # name of the current package for deparsed code
94 # array of [cop_seq, GV, is_format?] for subs and formats we still
98 # as above, but [name, prototype] for subs that never got a GV
100 # subs_done, forms_done:
101 # keys are addresses of GVs for subs and formats we've already
102 # deparsed (or at least put into subs_todo)
106 # cuddle: ` ' or `\n', depending on -sC
108 # A little explanation of how precedence contexts and associativity
111 # deparse() calls each per-op subroutine with an argument $cx (short
112 # for context, but not the same as the cx* in the perl core), which is
113 # a number describing the op's parents in terms of precedence, whether
114 # they're inside an expression or at statement level, etc. (see
115 # chart below). When ops with children call deparse on them, they pass
116 # along their precedence. Fractional values are used to implement
117 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
118 # parentheses hacks. The major disadvantage of this scheme is that
119 # it doesn't know about right sides and left sides, so say if you
120 # assign a listop to a variable, it can't tell it's allowed to leave
121 # the parens off the listop.
124 # 26 [TODO] inside interpolation context ("")
125 # 25 left terms and list operators (leftward)
129 # 21 right ! ~ \ and unary + and -
134 # 16 nonassoc named unary operators
135 # 15 nonassoc < > <= >= lt gt le ge
136 # 14 nonassoc == != <=> eq ne cmp
143 # 7 right = += -= *= etc.
145 # 5 nonassoc list operators (rightward)
149 # 1 statement modifiers
152 # Nonprinting characters with special meaning:
153 # \cS - steal parens (see maybe_parens_unop)
154 # \n - newline and indent
155 # \t - increase indent
156 # \b - decrease indent (`outdent')
157 # \f - flush left (no indent)
158 # \cK - kill following semicolon, if any
162 return class($op) eq "NULL";
167 my($gv, $cv, $is_form) = @_;
169 if (!null($cv->START) and is_state($cv->START)) {
170 $seq = $cv->START->cop_seq;
174 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
179 my $ent = shift @{$self->{'subs_todo'}};
180 my $name = $self->gv_name($ent->[1]);
182 return "format $name =\n"
183 . $self->deparse_format($ent->[1]->FORM). "\n";
185 return "sub $name " .
186 $self->deparse_sub($ent->[1]->CV);
190 sub OPf_KIDS () { 4 }
195 if ($op->flags & OPf_KIDS) {
197 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
198 walk_tree($kid, $sub);
207 $op = shift if null $op;
208 return if !$op or null $op;
211 if ($op->ppaddr eq "pp_gv") {
212 if ($op->next->ppaddr eq "pp_entersub") {
213 next if $self->{'subs_done'}{$ {$op->gv}}++;
214 next if class($op->gv->CV) eq "SPECIAL";
215 $self->todo($op->gv, $op->gv->CV, 0);
216 $self->walk_sub($op->gv->CV);
217 } elsif ($op->next->ppaddr eq "pp_enterwrite"
218 or ($op->next->ppaddr eq "pp_rv2gv"
219 and $op->next->next->ppaddr eq "pp_enterwrite")) {
220 next if $self->{'forms_done'}{$ {$op->gv}}++;
221 next if class($op->gv->FORM) eq "SPECIAL";
222 $self->todo($op->gv, $op->gv->FORM, 1);
223 $self->walk_sub($op->gv->FORM);
233 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
234 if ($pack eq "main") {
237 $pack = $pack . "::";
240 while (($key, $val) = each %stash) {
241 my $class = class($val);
242 if ($class eq "PV") {
244 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
245 } elsif ($class eq "IV") {
247 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
248 } elsif ($class eq "GV") {
249 if (class($val->CV) ne "SPECIAL") {
250 next if $self->{'subs_done'}{$$val}++;
251 $self->todo($val, $val->CV, 0);
252 $self->walk_sub($val->CV);
254 if (class($val->FORM) ne "SPECIAL") {
255 next if $self->{'forms_done'}{$$val}++;
256 $self->todo($val, $val->FORM, 1);
257 $self->walk_sub($val->FORM);
267 foreach $ar (@{$self->{'protos_todo'}}) {
268 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
269 push @ret, "sub " . $ar->[0] . "$proto;\n";
271 delete $self->{'protos_todo'};
279 while (length($opt = substr($opts, 0, 1))) {
281 $self->{'cuddle'} = " ";
283 $opts = substr($opts, 1);
292 $self->{'subs_todo'} = [];
293 $self->stash_subs("main");
294 $self->{'curcv'} = main_cv;
295 $self->{'curstash'} = "main";
296 $self->{'cuddle'} = "\n";
297 while ($arg = shift @args) {
298 if (substr($arg, 0, 2) eq "-u") {
299 $self->stash_subs(substr($arg, 2));
300 } elsif ($arg eq "-p") {
301 $self->{'parens'} = 1;
302 } elsif ($arg eq "-l") {
303 $self->{'linenums'} = 1;
304 } elsif (substr($arg, 0, 2) eq "-s") {
305 $self->style_opts(substr $arg, 2);
308 $self->walk_sub(main_cv, main_start);
309 print $self->print_protos;
310 @{$self->{'subs_todo'}} =
311 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
312 print indent($self->deparse(main_root, 0)), "\n" unless null main_root;
314 while (scalar(@{$self->{'subs_todo'}})) {
315 push @text, $self->next_todo;
317 print indent(join("", @text)), "\n" if @text;
324 # cluck if class($op) eq "NULL";
325 my $meth = $op->ppaddr;
326 return $self->$meth($op, $cx);
331 my @lines = split(/\n/, $txt);
335 if (substr($line, 0, 1) eq "\t") {
336 $leader = $leader . " ";
337 $line = substr($line, 1);
338 } elsif (substr($line, 0, 1) eq "\b") {
339 $leader = substr($leader, 0, length($leader) - 4);
340 $line = substr($line, 1);
342 if (substr($line, 0, 1) eq "\f") {
343 $line = substr($line, 1); # no indent
345 $line = $leader . $line;
349 return join("\n", @lines);
352 sub SVf_POK () {0x40000}
358 if ($cv->FLAGS & SVf_POK) {
359 $proto = "(". $cv->PV . ") ";
361 local($self->{'curcv'}) = $cv;
362 local($self->{'curstash'}) = $self->{'curstash'};
363 if (not null $cv->ROOT) {
365 return $proto . "{\n\t" .
366 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
368 return $proto . "{}\n";
376 local($self->{'curcv'}) = $form;
377 local($self->{'curstash'}) = $self->{'curstash'};
378 my $op = $form->ROOT;
380 $op = $op->first->first; # skip leavewrite, lineseq
381 while (not null $op) {
382 $op = $op->sibling; # skip nextstate
384 $kid = $op->first->sibling; # skip pushmark
385 push @text, $kid->sv->PV;
386 $kid = $kid->sibling;
387 for (; not null $kid; $kid = $kid->sibling) {
388 push @exprs, $self->deparse($kid, 0);
390 push @text, join(", ", @exprs)."\n" if @exprs;
393 return join("", @text) . ".";
396 # the aassign in-common check messes up SvCUR (always setting it
397 # to a value >= 100), but it's probably safe to assume there
398 # won't be any NULs in the names of my() variables. (with
399 # stash variables, I wouldn't be so sure)
402 $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
408 return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope"
409 || $op->ppaddr eq "pp_lineseq"
410 || ($op->ppaddr eq "pp_null" && class($op) eq "UNOP"
411 && (is_scope($op->first) || $op->first->ppaddr eq "pp_enter"));
415 my $name = $_[0]->ppaddr;
416 return $name eq "pp_nextstate" || $name eq "pp_dbstate";
419 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
421 return (!null($op) and null($op->sibling)
422 and $op->ppaddr eq "pp_null" and class($op) eq "UNOP"
423 and (($op->first->ppaddr =~ /^pp_(and|or)$/
424 and $op->first->first->sibling->ppaddr eq "pp_lineseq")
425 or ($op->first->ppaddr eq "pp_lineseq"
426 and not null $op->first->first->sibling
427 and $op->first->first->sibling->ppaddr eq "pp_unstack")
433 return ($op->ppaddr eq "pp_rv2sv" or
434 $op->ppaddr eq "pp_padsv" or
435 $op->ppaddr eq "pp_gv" or # only in array/hash constructs
436 !null($op->first) && $op->first->ppaddr eq "pp_gvsv");
441 my($text, $cx, $prec) = @_;
442 if ($prec < $cx # unary ops nest just fine
443 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
444 or $self->{'parens'})
447 # In a unop, let parent reuse our parens; see maybe_parens_unop
448 $text = "\cS" . $text if $cx == 16;
455 # same as above, but get around the `if it looks like a function' rule
456 sub maybe_parens_unop {
458 my($name, $kid, $cx) = @_;
459 if ($cx > 16 or $self->{'parens'}) {
460 return "$name(" . $self->deparse($kid, 1) . ")";
462 $kid = $self->deparse($kid, 16);
463 if (substr($kid, 0, 1) eq "\cS") {
465 return $name . substr($kid, 1);
466 } elsif (substr($kid, 0, 1) eq "(") {
467 # avoid looks-like-a-function trap with extra parens
468 # (`+' can lead to ambiguities)
469 return "$name(" . $kid . ")";
476 sub maybe_parens_func {
478 my($func, $text, $cx, $prec) = @_;
479 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
480 return "$func($text)";
482 return "$func $text";
486 sub OPp_LVAL_INTRO () { 128 }
490 my($op, $cx, $text) = @_;
491 if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
492 return $self->maybe_parens_func("local", $text, $cx, 16);
501 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
506 my($op, $cx, $text) = @_;
507 if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
508 return $self->maybe_parens_func("my", $text, $cx, 16);
514 # The following OPs don't have functions:
516 # pp_padany -- does not exist after parsing
517 # pp_rcatline -- does not exist
519 sub pp_enter { # see also leave
520 cluck "unexpected OP_ENTER";
524 sub pp_pushmark { # see also list
525 cluck "unexpected OP_PUSHMARK";
529 sub pp_leavesub { # see also deparse_sub
530 cluck "unexpected OP_LEAVESUB";
534 sub pp_leavewrite { # see also deparse_format
535 cluck "unexpected OP_LEAVEWRITE";
539 sub pp_method { # see also entersub
540 cluck "unexpected OP_METHOD";
544 sub pp_regcmaybe { # see also regcomp
545 cluck "unexpected OP_REGCMAYBE";
549 sub pp_regcreset { # see also regcomp
550 cluck "unexpected OP_REGCRESET";
554 sub pp_substcont { # see also subst
555 cluck "unexpected OP_SUBSTCONT";
559 sub pp_grepstart { # see also grepwhile
560 cluck "unexpected OP_GREPSTART";
564 sub pp_mapstart { # see also mapwhile
565 cluck "unexpected OP_MAPSTART";
569 sub pp_flip { # see also flop
570 cluck "unexpected OP_FLIP";
574 sub pp_iter { # see also leaveloop
575 cluck "unexpected OP_ITER";
579 sub pp_enteriter { # see also leaveloop
580 cluck "unexpected OP_ENTERITER";
584 sub pp_enterloop { # see also leaveloop
585 cluck "unexpected OP_ENTERLOOP";
589 sub pp_leaveeval { # see also entereval
590 cluck "unexpected OP_LEAVEEVAL";
594 sub pp_entertry { # see also leavetry
595 cluck "unexpected OP_ENTERTRY";
599 # leave and scope/lineseq should probably share code
605 local($self->{'curstash'}) = $self->{'curstash'};
606 $kid = $op->first->sibling; # skip enter
607 if (is_miniwhile($kid)) {
608 my $top = $kid->first;
609 my $name = $top->ppaddr;
610 if ($name eq "pp_and") {
612 } elsif ($name eq "pp_or") {
614 } else { # no conditional -> while 1 or until 0
615 return $self->deparse($top->first, 1) . " while 1";
617 my $cond = $top->first;
618 my $body = $cond->sibling->first; # skip lineseq
619 $cond = $self->deparse($cond, 1);
620 $body = $self->deparse($body, 1);
621 return "$body $name $cond";
623 for (; !null($kid); $kid = $kid->sibling) {
626 $expr = $self->deparse($kid, 0);
627 $kid = $kid->sibling;
630 $expr .= $self->deparse($kid, 0);
631 push @exprs, $expr if $expr;
633 if ($cx > 0) { # inside an expression
634 return "do { " . join(";\n", @exprs) . " }";
636 return join(";\n", @exprs) . ";";
645 for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
648 $expr = $self->deparse($kid, 0);
649 $kid = $kid->sibling;
652 $expr .= $self->deparse($kid, 0);
653 push @exprs, $expr if $expr;
655 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
656 return "do { " . join(";\n", @exprs) . " }";
658 return join(";\n", @exprs) . ";";
662 sub pp_lineseq { pp_scope(@_) }
664 # The BEGIN {} is used here because otherwise this code isn't executed
665 # when you run B::Deparse on itself.
667 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
668 "ENV", "ARGV", "ARGVOUT", "_"); }
673 my $stash = $gv->STASH->NAME;
674 my $name = $gv->NAME;
675 if ($stash eq $self->{'curstash'} or $globalnames{$name}
676 or $name =~ /^[^A-Za-z_]/)
680 $stash = $stash . "::";
682 if ($name =~ /^([\cA-\cZ])$/) {
683 $name = "^" . chr(64 + ord($1));
685 return $stash . $name;
688 # Notice how subs and formats are inserted between statements here
693 @text = $op->label . ": " if $op->label;
694 my $seq = $op->cop_seq;
695 while (scalar(@{$self->{'subs_todo'}})
696 and $seq > $self->{'subs_todo'}[0][0]) {
697 push @text, $self->next_todo;
699 my $stash = $op->stash->NAME;
700 if ($stash ne $self->{'curstash'}) {
701 push @text, "package $stash;\n";
702 $self->{'curstash'} = $stash;
704 if ($self->{'linenums'}) {
705 push @text, "\f#line " . $op->line .
706 ' "' . substr($op->filegv->NAME, 2), qq'"\n';
708 return join("", @text);
711 sub pp_dbstate { pp_nextstate(@_) }
713 sub pp_unstack { return "" } # see also leaveloop
717 my($op, $cx, $name) = @_;
721 sub pp_stub { baseop(@_, "()") }
722 sub pp_wantarray { baseop(@_, "wantarray") }
723 sub pp_fork { baseop(@_, "fork") }
724 sub pp_wait { baseop(@_, "wait") }
725 sub pp_getppid { baseop(@_, "getppid") }
726 sub pp_time { baseop(@_, "time") }
727 sub pp_tms { baseop(@_, "times") }
728 sub pp_ghostent { baseop(@_, "gethostent") }
729 sub pp_gnetent { baseop(@_, "getnetent") }
730 sub pp_gprotoent { baseop(@_, "getprotoent") }
731 sub pp_gservent { baseop(@_, "getservent") }
732 sub pp_ehostent { baseop(@_, "endhostent") }
733 sub pp_enetent { baseop(@_, "endnetent") }
734 sub pp_eprotoent { baseop(@_, "endprotoent") }
735 sub pp_eservent { baseop(@_, "endservent") }
736 sub pp_gpwent { baseop(@_, "getpwent") }
737 sub pp_spwent { baseop(@_, "setpwent") }
738 sub pp_epwent { baseop(@_, "endpwent") }
739 sub pp_ggrent { baseop(@_, "getgrent") }
740 sub pp_sgrent { baseop(@_, "setgrent") }
741 sub pp_egrent { baseop(@_, "endgrent") }
742 sub pp_getlogin { baseop(@_, "getlogin") }
746 # I couldn't think of a good short name, but this is the category of
747 # symbolic unary operators with interesting precedence
751 my($op, $cx, $name, $prec, $flags) = (@_, 0);
752 my $kid = $op->first;
753 $kid = $self->deparse($kid, $prec);
754 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
758 sub pp_preinc { pfixop(@_, "++", 23) }
759 sub pp_predec { pfixop(@_, "--", 23) }
760 sub pp_postinc { pfixop(@_, "++", 23, POSTFIX) }
761 sub pp_postdec { pfixop(@_, "--", 23, POSTFIX) }
762 sub pp_i_preinc { pfixop(@_, "++", 23) }
763 sub pp_i_predec { pfixop(@_, "--", 23) }
764 sub pp_i_postinc { pfixop(@_, "++", 23, POSTFIX) }
765 sub pp_i_postdec { pfixop(@_, "--", 23, POSTFIX) }
766 sub pp_complement { pfixop(@_, "~", 21) }
771 if ($op->first->ppaddr =~ /^pp_(i_)?negate$/) {
773 $self->pfixop($op, $cx, "-", 21.5);
775 $self->pfixop($op, $cx, "-", 21);
778 sub pp_i_negate { pp_negate(@_) }
784 $self->pfixop($op, $cx, "not ", 4);
786 $self->pfixop($op, $cx, "!", 21);
790 sub OPf_SPECIAL () { 128 }
794 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
796 if ($op->flags & OPf_KIDS) {
798 return $self->maybe_parens_unop($name, $kid, $cx);
800 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
804 sub pp_chop { unop(@_, "chop") }
805 sub pp_chomp { unop(@_, "chomp") }
806 sub pp_schop { unop(@_, "chop") }
807 sub pp_schomp { unop(@_, "chomp") }
808 sub pp_defined { unop(@_, "defined") }
809 sub pp_undef { unop(@_, "undef") }
810 sub pp_study { unop(@_, "study") }
811 sub pp_ref { unop(@_, "ref") }
812 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
814 sub pp_sin { unop(@_, "sin") }
815 sub pp_cos { unop(@_, "cos") }
816 sub pp_rand { unop(@_, "rand") }
817 sub pp_srand { unop(@_, "srand") }
818 sub pp_exp { unop(@_, "exp") }
819 sub pp_log { unop(@_, "log") }
820 sub pp_sqrt { unop(@_, "sqrt") }
821 sub pp_int { unop(@_, "int") }
822 sub pp_hex { unop(@_, "hex") }
823 sub pp_oct { unop(@_, "oct") }
824 sub pp_abs { unop(@_, "abs") }
826 sub pp_length { unop(@_, "length") }
827 sub pp_ord { unop(@_, "ord") }
828 sub pp_chr { unop(@_, "chr") }
829 sub pp_ucfirst { unop(@_, "ucfirst") }
830 sub pp_lcfirst { unop(@_, "lcfirst") }
831 sub pp_uc { unop(@_, "uc") }
832 sub pp_lc { unop(@_, "lc") }
833 sub pp_quotemeta { unop(@_, "quotemeta") }
835 sub pp_each { unop(@_, "each") }
836 sub pp_values { unop(@_, "values") }
837 sub pp_keys { unop(@_, "keys") }
838 sub pp_pop { unop(@_, "pop") }
839 sub pp_shift { unop(@_, "shift") }
841 sub pp_caller { unop(@_, "caller") }
842 sub pp_reset { unop(@_, "reset") }
843 sub pp_exit { unop(@_, "exit") }
844 sub pp_prototype { unop(@_, "prototype") }
846 sub pp_close { unop(@_, "close") }
847 sub pp_fileno { unop(@_, "fileno") }
848 sub pp_umask { unop(@_, "umask") }
849 sub pp_binmode { unop(@_, "binmode") }
850 sub pp_untie { unop(@_, "untie") }
851 sub pp_tied { unop(@_, "tied") }
852 sub pp_dbmclose { unop(@_, "dbmclose") }
853 sub pp_getc { unop(@_, "getc") }
854 sub pp_eof { unop(@_, "eof") }
855 sub pp_tell { unop(@_, "tell") }
856 sub pp_getsockname { unop(@_, "getsockname") }
857 sub pp_getpeername { unop(@_, "getpeername") }
859 sub pp_chdir { unop(@_, "chdir") }
860 sub pp_chroot { unop(@_, "chroot") }
861 sub pp_readlink { unop(@_, "readlink") }
862 sub pp_rmdir { unop(@_, "rmdir") }
863 sub pp_readdir { unop(@_, "readdir") }
864 sub pp_telldir { unop(@_, "telldir") }
865 sub pp_rewinddir { unop(@_, "rewinddir") }
866 sub pp_closedir { unop(@_, "closedir") }
867 sub pp_getpgrp { unop(@_, "getpgrp") }
868 sub pp_localtime { unop(@_, "localtime") }
869 sub pp_gmtime { unop(@_, "gmtime") }
870 sub pp_alarm { unop(@_, "alarm") }
871 sub pp_sleep { unop(@_, "sleep") }
873 sub pp_dofile { unop(@_, "do") }
874 sub pp_entereval { unop(@_, "eval") }
876 sub pp_ghbyname { unop(@_, "gethostbyname") }
877 sub pp_gnbyname { unop(@_, "getnetbyname") }
878 sub pp_gpbyname { unop(@_, "getprotobyname") }
879 sub pp_shostent { unop(@_, "sethostent") }
880 sub pp_snetent { unop(@_, "setnetent") }
881 sub pp_sprotoent { unop(@_, "setprotoent") }
882 sub pp_sservent { unop(@_, "setservent") }
883 sub pp_gpwnam { unop(@_, "getpwnam") }
884 sub pp_gpwuid { unop(@_, "getpwuid") }
885 sub pp_ggrnam { unop(@_, "getgrnam") }
886 sub pp_ggrgid { unop(@_, "getgrgid") }
888 sub pp_lock { unop(@_, "lock") }
893 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
897 sub OPpSLICE () { 64 }
903 if ($op->private & OPpSLICE) {
904 return $self->maybe_parens_func("delete",
905 $self->pp_hslice($op->first, 16),
908 return $self->maybe_parens_func("delete",
909 $self->pp_helem($op->first, 16),
914 sub OPp_CONST_BARE () { 64 }
919 if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const"
920 and $op->first->private & OPp_CONST_BARE)
922 my $name = $op->first->sv->PV;
925 return "require($name)";
927 $self->unop($op, $cx, "require");
934 my $kid = $op->first;
935 if (not null $kid->sibling) {
937 return $self->dquote($op);
939 $self->unop(@_, "scalar");
946 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
949 sub OPf_REF () { 16 }
954 my $kid = $op->first;
955 if ($kid->ppaddr eq "pp_null") {
957 if ($kid->ppaddr eq "pp_anonlist" || $kid->ppaddr eq "pp_anonhash") {
958 my($pre, $post) = @{{"pp_anonlist" => ["[","]"],
959 "pp_anonhash" => ["{","}"]}->{$kid->ppaddr}};
961 $kid = $kid->first->sibling; # skip pushmark
962 for (; !null($kid); $kid = $kid->sibling) {
963 $expr = $self->deparse($kid, 6);
966 return $pre . join(", ", @exprs) . $post;
967 } elsif (!null($kid->sibling) and
968 $kid->sibling->ppaddr eq "pp_anoncode") {
970 $self->deparse_sub($self->padval($kid->sibling->targ));
971 } elsif ($kid->ppaddr eq "pp_pushmark"
972 and $kid->sibling->ppaddr =~ /^pp_(pad|rv2)[ah]v$/
973 and not $kid->sibling->flags & OPf_REF) {
974 # The @a in \(@a) isn't in ref context, but only when the
976 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
979 $self->pfixop($op, $cx, "\\", 20);
982 sub pp_srefgen { pp_refgen(@_) }
987 my $kid = $op->first;
988 $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh>
989 if ($kid->ppaddr eq "pp_rv2gv") {
992 return "<" . $self->deparse($kid, 1) . ">";
997 my ($op, $cx, $name) = @_;
998 if (class($op) eq "PVOP") {
999 return "$name " . $op->pv;
1000 } elsif (class($op) eq "OP") {
1002 } elsif (class($op) eq "UNOP") {
1003 # Note -- loop exits are actually exempt from the
1004 # looks-like-a-func rule, but a few extra parens won't hurt
1005 return $self->maybe_parens_unop($name, $op->first, $cx);
1009 sub pp_last { loopex(@_, "last") }
1010 sub pp_next { loopex(@_, "next") }
1011 sub pp_redo { loopex(@_, "redo") }
1012 sub pp_goto { loopex(@_, "goto") }
1013 sub pp_dump { loopex(@_, "dump") }
1017 my($op, $cx, $name) = @_;
1018 if (class($op) eq "UNOP") {
1019 # Genuine `-X' filetests are exempt from the LLAFR, but not
1020 # l?stat(); for the sake of clarity, give'em all parens
1021 return $self->maybe_parens_unop($name, $op->first, $cx);
1022 } elsif (class($op) eq "GVOP") {
1023 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1024 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1029 sub pp_lstat { ftst(@_, "lstat") }
1030 sub pp_stat { ftst(@_, "stat") }
1031 sub pp_ftrread { ftst(@_, "-R") }
1032 sub pp_ftrwrite { ftst(@_, "-W") }
1033 sub pp_ftrexec { ftst(@_, "-X") }
1034 sub pp_fteread { ftst(@_, "-r") }
1035 sub pp_ftewrite { ftst(@_, "-r") }
1036 sub pp_fteexec { ftst(@_, "-r") }
1037 sub pp_ftis { ftst(@_, "-e") }
1038 sub pp_fteowned { ftst(@_, "-O") }
1039 sub pp_ftrowned { ftst(@_, "-o") }
1040 sub pp_ftzero { ftst(@_, "-z") }
1041 sub pp_ftsize { ftst(@_, "-s") }
1042 sub pp_ftmtime { ftst(@_, "-M") }
1043 sub pp_ftatime { ftst(@_, "-A") }
1044 sub pp_ftctime { ftst(@_, "-C") }
1045 sub pp_ftsock { ftst(@_, "-S") }
1046 sub pp_ftchr { ftst(@_, "-c") }
1047 sub pp_ftblk { ftst(@_, "-b") }
1048 sub pp_ftfile { ftst(@_, "-f") }
1049 sub pp_ftdir { ftst(@_, "-d") }
1050 sub pp_ftpipe { ftst(@_, "-p") }
1051 sub pp_ftlink { ftst(@_, "-l") }
1052 sub pp_ftsuid { ftst(@_, "-u") }
1053 sub pp_ftsgid { ftst(@_, "-g") }
1054 sub pp_ftsvtx { ftst(@_, "-k") }
1055 sub pp_fttty { ftst(@_, "-t") }
1056 sub pp_fttext { ftst(@_, "-T") }
1057 sub pp_ftbinary { ftst(@_, "-B") }
1059 sub SWAP_CHILDREN () { 1 }
1060 sub ASSIGN () { 2 } # has OP= variant
1062 sub OPf_STACKED () { 64 }
1068 my $name = $op->ppaddr;
1069 if ($name eq "pp_concat" and $op->first->ppaddr eq "pp_concat") {
1070 # avoid spurious `=' -- see comment in pp_concat
1073 if ($name eq "pp_null" and class($op) eq "UNOP"
1074 and $op->first->ppaddr =~ /^pp_(and|x?or)$/
1075 and null $op->first->sibling)
1077 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1078 # with a null that's used as the common end point of the two
1079 # flows of control. For precedence purposes, ignore it.
1080 # (COND_EXPRs have these too, but we don't bother with
1081 # their associativity).
1082 return assoc_class($op->first);
1084 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1087 # Left associative operators, like `+', for which
1088 # $a + $b + $c is equivalent to ($a + $b) + $c
1091 %left = ('pp_multiply' => 19, 'pp_i_multiply' => 19,
1092 'pp_divide' => 19, 'pp_i_divide' => 19,
1093 'pp_modulo' => 19, 'pp_i_modulo' => 19,
1095 'pp_add' => 18, 'pp_i_add' => 18,
1096 'pp_subtract' => 18, 'pp_i_subtract' => 18,
1098 'pp_left_shift' => 17, 'pp_right_shift' => 17,
1100 'pp_bit_or' => 12, 'pp_bit_xor' => 12,
1102 'pp_or' => 2, 'pp_xor' => 2,
1106 sub deparse_binop_left {
1108 my($op, $left, $prec) = @_;
1109 if ($left{assoc_class($op)}
1110 and $left{assoc_class($op)} == $left{assoc_class($left)})
1112 return $self->deparse($left, $prec - .00001);
1114 return $self->deparse($left, $prec);
1118 # Right associative operators, like `=', for which
1119 # $a = $b = $c is equivalent to $a = ($b = $c)
1122 %right = ('pp_pow' => 22,
1123 'pp_sassign=' => 7, 'pp_aassign=' => 7,
1124 'pp_multiply=' => 7, 'pp_i_multiply=' => 7,
1125 'pp_divide=' => 7, 'pp_i_divide=' => 7,
1126 'pp_modulo=' => 7, 'pp_i_modulo=' => 7,
1128 'pp_add=' => 7, 'pp_i_add=' => 7,
1129 'pp_subtract=' => 7, 'pp_i_subtract=' => 7,
1131 'pp_left_shift=' => 7, 'pp_right_shift=' => 7,
1133 'pp_bit_or=' => 7, 'pp_bit_xor=' => 7,
1134 'pp_andassign' => 7,
1139 sub deparse_binop_right {
1141 my($op, $right, $prec) = @_;
1142 if ($right{assoc_class($op)}
1143 and $right{assoc_class($op)} == $right{assoc_class($right)})
1145 return $self->deparse($right, $prec - .00001);
1147 return $self->deparse($right, $prec);
1153 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1154 my $left = $op->first;
1155 my $right = $op->last;
1157 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1161 if ($flags & SWAP_CHILDREN) {
1162 ($left, $right) = ($right, $left);
1164 $left = $self->deparse_binop_left($op, $left, $prec);
1165 $right = $self->deparse_binop_right($op, $right, $prec);
1166 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1169 sub pp_add { binop(@_, "+", 18, ASSIGN) }
1170 sub pp_multiply { binop(@_, "*", 19, ASSIGN) }
1171 sub pp_subtract { binop(@_, "-",18, ASSIGN) }
1172 sub pp_divide { binop(@_, "/", 19, ASSIGN) }
1173 sub pp_modulo { binop(@_, "%", 19, ASSIGN) }
1174 sub pp_i_add { binop(@_, "+", 18, ASSIGN) }
1175 sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) }
1176 sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) }
1177 sub pp_i_divide { binop(@_, "/", 19, ASSIGN) }
1178 sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) }
1179 sub pp_pow { binop(@_, "**", 22, ASSIGN) }
1181 sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) }
1182 sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) }
1183 sub pp_bit_and { binop(@_, "&", 13, ASSIGN) }
1184 sub pp_bit_or { binop(@_, "|", 12, ASSIGN) }
1185 sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) }
1187 sub pp_eq { binop(@_, "==", 14) }
1188 sub pp_ne { binop(@_, "!=", 14) }
1189 sub pp_lt { binop(@_, "<", 15) }
1190 sub pp_gt { binop(@_, ">", 15) }
1191 sub pp_ge { binop(@_, ">=", 15) }
1192 sub pp_le { binop(@_, "<=", 15) }
1193 sub pp_ncmp { binop(@_, "<=>", 14) }
1194 sub pp_i_eq { binop(@_, "==", 14) }
1195 sub pp_i_ne { binop(@_, "!=", 14) }
1196 sub pp_i_lt { binop(@_, "<", 15) }
1197 sub pp_i_gt { binop(@_, ">", 15) }
1198 sub pp_i_ge { binop(@_, ">=", 15) }
1199 sub pp_i_le { binop(@_, "<=", 15) }
1200 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1202 sub pp_seq { binop(@_, "eq", 14) }
1203 sub pp_sne { binop(@_, "ne", 14) }
1204 sub pp_slt { binop(@_, "lt", 15) }
1205 sub pp_sgt { binop(@_, "gt", 15) }
1206 sub pp_sge { binop(@_, "ge", 15) }
1207 sub pp_sle { binop(@_, "le", 15) }
1208 sub pp_scmp { binop(@_, "cmp", 14) }
1210 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1211 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1213 # `.' is special because concats-of-concats are optimized to save copying
1214 # by making all but the first concat stacked. The effect is as if the
1215 # programmer had written `($a . $b) .= $c', except legal.
1219 my $left = $op->first;
1220 my $right = $op->last;
1223 if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") {
1227 $left = $self->deparse_binop_left($op, $left, $prec);
1228 $right = $self->deparse_binop_right($op, $right, $prec);
1229 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1232 # `x' is weird when the left arg is a list
1236 my $left = $op->first;
1237 my $right = $op->last;
1240 if ($op->flags & OPf_STACKED) {
1244 if (null($right)) { # list repeat; count is inside left-side ex-list
1245 my $kid = $left->first->sibling; # skip pushmark
1247 for (; !null($kid->sibling); $kid = $kid->sibling) {
1248 push @exprs, $self->deparse($kid, 6);
1251 $left = "(" . join(", ", @exprs). ")";
1253 $left = $self->deparse_binop_left($op, $left, $prec);
1255 $right = $self->deparse_binop_right($op, $right, $prec);
1256 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1261 my ($op, $cx, $type) = @_;
1262 my $left = $op->first;
1263 my $right = $left->sibling;
1264 $left = $self->deparse($left, 9);
1265 $right = $self->deparse($right, 9);
1266 return $self->maybe_parens("$left $type $right", $cx, 9);
1272 my $flip = $op->first;
1273 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1274 return $self->range($flip->first, $cx, $type);
1277 # one-line while/until is handled in pp_leave
1281 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1282 my $left = $op->first;
1283 my $right = $op->first->sibling;
1284 if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
1285 $left = $self->deparse($left, 1);
1286 $right = $self->deparse($right, 0);
1287 return "$blockname ($left) {\n\t$right\n\b}\cK";
1288 } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
1289 $right = $self->deparse($right, 1);
1290 $left = $self->deparse($left, 1);
1291 return "$right $blockname $left";
1292 } elsif ($cx > $lowprec and $highop) { # $a && $b
1293 $left = $self->deparse_binop_left($op, $left, $highprec);
1294 $right = $self->deparse_binop_right($op, $right, $highprec);
1295 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1296 } else { # $a and $b
1297 $left = $self->deparse_binop_left($op, $left, $lowprec);
1298 $right = $self->deparse_binop_right($op, $right, $lowprec);
1299 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1303 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1304 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1305 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1309 my ($op, $cx, $opname) = @_;
1310 my $left = $op->first;
1311 my $right = $op->first->sibling->first; # skip sassign
1312 $left = $self->deparse($left, 7);
1313 $right = $self->deparse($right, 7);
1314 return $self->maybe_parens("$left $opname $right", $cx, 7);
1317 sub pp_andassign { logassignop(@_, "&&=") }
1318 sub pp_orassign { logassignop(@_, "||=") }
1322 my($op, $cx, $name) = @_;
1324 my $parens = ($cx >= 5) || $self->{'parens'};
1325 my $kid = $op->first->sibling;
1326 return $name if null $kid;
1327 my $first = $self->deparse($kid, 6);
1328 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1329 push @exprs, $first;
1330 $kid = $kid->sibling;
1331 for (; !null($kid); $kid = $kid->sibling) {
1332 push @exprs, $self->deparse($kid, 6);
1335 return "$name(" . join(", ", @exprs) . ")";
1337 return "$name " . join(", ", @exprs);
1341 sub pp_bless { listop(@_, "bless") }
1342 sub pp_atan2 { listop(@_, "atan2") }
1343 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1344 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1345 sub pp_index { listop(@_, "index") }
1346 sub pp_rindex { listop(@_, "rindex") }
1347 sub pp_sprintf { listop(@_, "sprintf") }
1348 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1349 sub pp_crypt { listop(@_, "crypt") }
1350 sub pp_unpack { listop(@_, "unpack") }
1351 sub pp_pack { listop(@_, "pack") }
1352 sub pp_join { listop(@_, "join") }
1353 sub pp_splice { listop(@_, "splice") }
1354 sub pp_push { listop(@_, "push") }
1355 sub pp_unshift { listop(@_, "unshift") }
1356 sub pp_reverse { listop(@_, "reverse") }
1357 sub pp_warn { listop(@_, "warn") }
1358 sub pp_die { listop(@_, "die") }
1359 # Actually, return is exempt from the LLAFR (see examples in this very
1360 # module!), but for consistency's sake, ignore that fact
1361 sub pp_return { listop(@_, "return") }
1362 sub pp_open { listop(@_, "open") }
1363 sub pp_pipe_op { listop(@_, "pipe") }
1364 sub pp_tie { listop(@_, "tie") }
1365 sub pp_dbmopen { listop(@_, "dbmopen") }
1366 sub pp_sselect { listop(@_, "select") }
1367 sub pp_select { listop(@_, "select") }
1368 sub pp_read { listop(@_, "read") }
1369 sub pp_sysopen { listop(@_, "sysopen") }
1370 sub pp_sysseek { listop(@_, "sysseek") }
1371 sub pp_sysread { listop(@_, "sysread") }
1372 sub pp_syswrite { listop(@_, "syswrite") }
1373 sub pp_send { listop(@_, "send") }
1374 sub pp_recv { listop(@_, "recv") }
1375 sub pp_seek { listop(@_, "seek") }
1376 sub pp_fcntl { listop(@_, "fcntl") }
1377 sub pp_ioctl { listop(@_, "ioctl") }
1378 sub pp_flock { listop(@_, "flock") }
1379 sub pp_socket { listop(@_, "socket") }
1380 sub pp_sockpair { listop(@_, "sockpair") }
1381 sub pp_bind { listop(@_, "bind") }
1382 sub pp_connect { listop(@_, "connect") }
1383 sub pp_listen { listop(@_, "listen") }
1384 sub pp_accept { listop(@_, "accept") }
1385 sub pp_shutdown { listop(@_, "shutdown") }
1386 sub pp_gsockopt { listop(@_, "getsockopt") }
1387 sub pp_ssockopt { listop(@_, "setsockopt") }
1388 sub pp_chown { listop(@_, "chown") }
1389 sub pp_unlink { listop(@_, "unlink") }
1390 sub pp_chmod { listop(@_, "chmod") }
1391 sub pp_utime { listop(@_, "utime") }
1392 sub pp_rename { listop(@_, "rename") }
1393 sub pp_link { listop(@_, "link") }
1394 sub pp_symlink { listop(@_, "symlink") }
1395 sub pp_mkdir { listop(@_, "mkdir") }
1396 sub pp_open_dir { listop(@_, "opendir") }
1397 sub pp_seekdir { listop(@_, "seekdir") }
1398 sub pp_waitpid { listop(@_, "waitpid") }
1399 sub pp_system { listop(@_, "system") }
1400 sub pp_exec { listop(@_, "exec") }
1401 sub pp_kill { listop(@_, "kill") }
1402 sub pp_setpgrp { listop(@_, "setpgrp") }
1403 sub pp_getpriority { listop(@_, "getpriority") }
1404 sub pp_setpriority { listop(@_, "setpriority") }
1405 sub pp_shmget { listop(@_, "shmget") }
1406 sub pp_shmctl { listop(@_, "shmctl") }
1407 sub pp_shmread { listop(@_, "shmread") }
1408 sub pp_shmwrite { listop(@_, "shmwrite") }
1409 sub pp_msgget { listop(@_, "msgget") }
1410 sub pp_msgctl { listop(@_, "msgctl") }
1411 sub pp_msgsnd { listop(@_, "msgsnd") }
1412 sub pp_msgrcv { listop(@_, "msgrcv") }
1413 sub pp_semget { listop(@_, "semget") }
1414 sub pp_semctl { listop(@_, "semctl") }
1415 sub pp_semop { listop(@_, "semop") }
1416 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1417 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1418 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1419 sub pp_gsbyname { listop(@_, "getservbyname") }
1420 sub pp_gsbyport { listop(@_, "getservbyport") }
1421 sub pp_syscall { listop(@_, "syscall") }
1426 my $text = $self->dq($op->first->sibling); # skip pushmark
1427 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1428 or $text =~ /[<>]/) {
1429 return 'glob(' . single_delim('qq', '"', $text) . ')';
1431 return '<' . $text . '>';
1435 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1436 # be a filehandle. This could probably be better fixed in the core
1437 # by moving the GV lookup into ck_truc.
1443 my $parens = ($cx >= 5) || $self->{'parens'};
1444 my $kid = $op->first->sibling;
1446 if ($op->flags & OPf_SPECIAL) {
1447 # $kid is an OP_CONST
1450 $fh = $self->deparse($kid, 6);
1451 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1453 my $len = $self->deparse($kid->sibling, 6);
1455 return "truncate($fh, $len)";
1457 return "truncate $fh, $len";
1464 my($op, $cx, $name) = @_;
1466 my $kid = $op->first->sibling;
1468 if ($op->flags & OPf_STACKED) {
1470 $indir = $indir->first; # skip rv2gv
1471 if (is_scope($indir)) {
1472 $indir = "{" . $self->deparse($indir, 0) . "}";
1474 $indir = $self->deparse($indir, 24);
1476 $indir = $indir . " ";
1477 $kid = $kid->sibling;
1479 for (; !null($kid); $kid = $kid->sibling) {
1480 $expr = $self->deparse($kid, 6);
1483 return $self->maybe_parens_func($name,
1484 $indir . join(", ", @exprs),
1488 sub pp_prtf { indirop(@_, "printf") }
1489 sub pp_print { indirop(@_, "print") }
1490 sub pp_sort { indirop(@_, "sort") }
1494 my($op, $cx, $name) = @_;
1496 my $kid = $op->first; # this is the (map|grep)start
1497 $kid = $kid->first->sibling; # skip a pushmark
1498 my $code = $kid->first; # skip a null
1499 if (is_scope $code) {
1500 $code = "{" . $self->deparse($code, 1) . "} ";
1502 $code = $self->deparse($code, 24) . ", ";
1504 $kid = $kid->sibling;
1505 for (; !null($kid); $kid = $kid->sibling) {
1506 $expr = $self->deparse($kid, 6);
1507 push @exprs, $expr if $expr;
1509 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1512 sub pp_mapwhile { mapop(@_, "map") }
1513 sub pp_grepwhile { mapop(@_, "grep") }
1519 my $kid = $op->first->sibling; # skip pushmark
1521 my $local = "either"; # could be local(...) or my(...)
1522 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1523 # This assumes that no other private flags equal 128, and that
1524 # OPs that store things other than flags in their op_private,
1525 # like OP_AELEMFAST, won't be immediate children of a list.
1526 unless ($lop->private & OPp_LVAL_INTRO or $lop->ppaddr eq "pp_undef")
1528 $local = ""; # or not
1531 if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my()
1532 ($local = "", last) if $local eq "local";
1534 } elsif ($lop->ppaddr ne "pp_undef") { # local()
1535 ($local = "", last) if $local eq "my";
1539 $local = "" if $local eq "either"; # no point if it's all undefs
1540 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
1541 for (; !null($kid); $kid = $kid->sibling) {
1543 if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") {
1548 $self->{'avoid_local'}{$$lop}++;
1549 $expr = $self->deparse($kid, 6);
1550 delete $self->{'avoid_local'}{$$lop};
1552 $expr = $self->deparse($kid, 6);
1557 return "$local(" . join(", ", @exprs) . ")";
1559 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1566 my $cond = $op->first;
1567 my $true = $cond->sibling;
1568 my $false = $true->sibling;
1569 my $cuddle = $self->{'cuddle'};
1570 unless ($cx == 0 and is_scope($true) and is_scope($false)) {
1571 $cond = $self->deparse($cond, 8);
1572 $true = $self->deparse($true, 8);
1573 $false = $self->deparse($false, 8);
1574 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1576 $cond = $self->deparse($cond, 1);
1577 $true = $self->deparse($true, 0);
1578 if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif
1579 my $head = "if ($cond) {\n\t$true\n\b}";
1581 while (!null($false) and $false->ppaddr eq "pp_lineseq") {
1582 my $newop = $false->first->sibling->first;
1583 my $newcond = $newop->first;
1584 my $newtrue = $newcond->sibling;
1585 $false = $newtrue->sibling; # last in chain is OP_AND => no else
1586 $newcond = $self->deparse($newcond, 1);
1587 $newtrue = $self->deparse($newtrue, 0);
1588 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1590 if (!null($false)) {
1591 $false = $cuddle . "else {\n\t" .
1592 $self->deparse($false, 0) . "\n\b}\cK";
1596 return $head . join($cuddle, "", @elsifs) . $false;
1598 $false = $self->deparse($false, 0);
1599 return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
1605 my $enter = $op->first;
1606 my $kid = $enter->sibling;
1607 local($self->{'curstash'}) = $self->{'curstash'};
1610 if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop
1611 if (is_state $kid->last) { # infinite
1612 $head = "for (;;) "; # shorter than while (1)
1616 } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach
1617 my $ary = $enter->first->sibling; # first was pushmark
1618 my $var = $ary->sibling;
1619 if ($enter->flags & OPf_STACKED
1620 and not null $ary->first->sibling->sibling)
1622 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1623 $self->deparse($ary->first->sibling->sibling, 9);
1625 $ary = $self->deparse($ary, 1);
1628 if ($enter->flags & OPf_SPECIAL) { # thread special var
1629 $var = $self->pp_threadsv($enter, 1);
1630 } else { # regular my() variable
1631 $var = $self->pp_padsv($enter, 1);
1632 if ($self->padname_sv($enter->targ)->IVX ==
1633 $kid->first->first->sibling->last->cop_seq)
1635 # If the scope of this variable closes at the last
1636 # statement of the loop, it must have been
1638 $var = "my " . $var;
1641 } elsif ($var->ppaddr eq "pp_rv2gv") {
1642 $var = $self->pp_rv2sv($var, 1);
1643 } elsif ($var->ppaddr eq "pp_gv") {
1644 $var = "\$" . $self->deparse($var, 1);
1646 $head = "foreach $var ($ary) ";
1647 $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1648 } elsif ($kid->ppaddr eq "pp_null") { # while/until
1650 my $name = {"pp_and" => "while", "pp_or" => "until"}
1652 $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
1653 $kid = $kid->first->sibling;
1654 } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty
1655 return "{;}"; # {} could be a hashref
1657 # The third-to-last kid is the continue block if the pointer used
1658 # by `next BLOCK' points to its first OP, which happens to be the
1659 # the op_next of the head of the _previous_ statement.
1660 # Unless it's a bare loop, in which case it's last, since there's
1661 # no unstack or extra nextstate.
1662 # Except if the previous head isn't null but the first kid is
1663 # (because it's a nulled out nextstate in a scope), in which
1664 # case the head's next is advanced past the null but the nextop's
1665 # isn't, so we need to try nextop->next.
1666 my($cont, $precont);
1668 $cont = $kid->first;
1669 while (!null($cont->sibling)) {
1671 $cont = $cont->sibling;
1674 $cont = $kid->first;
1675 while (!null($cont->sibling->sibling->sibling)) {
1677 $cont = $cont->sibling;
1680 if ($precont and $ {$precont->next} == $ {$enter->nextop}
1681 || $ {$precont->next} == $ {$enter->nextop->next} )
1683 my $state = $kid->first;
1684 my $cuddle = $self->{'cuddle'};
1686 for (; $$state != $$cont; $state = $state->sibling) {
1688 if (is_state $state) {
1689 $expr = $self->deparse($state, 0);
1690 $state = $state->sibling;
1693 $expr .= $self->deparse($state, 0);
1694 push @exprs, $expr if $expr;
1696 $kid = join(";\n", @exprs);
1697 $cont = $cuddle . "continue {\n\t" .
1698 $self->deparse($cont, 0) . "\n\b}\cK";
1701 $kid = $self->deparse($kid, 0);
1703 return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1708 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1711 sub OP_CONST () { 5 }
1713 # XXX need a better way to do this
1714 sub OP_STRINGIFY () { $] > 5.004_72 ? 67 : 65 }
1719 if (class($op) eq "OP") {
1720 return "'???'" if $op->targ == OP_CONST; # old value is lost
1721 } elsif ($op->first->ppaddr eq "pp_pushmark") {
1722 return $self->pp_list($op, $cx);
1723 } elsif ($op->first->ppaddr eq "pp_enter") {
1724 return $self->pp_leave($op, $cx);
1725 } elsif ($op->targ == OP_STRINGIFY) {
1726 return $self->dquote($op);
1727 } elsif (!null($op->first->sibling) and
1728 $op->first->sibling->ppaddr eq "pp_readline" and
1729 $op->first->sibling->flags & OPf_STACKED) {
1730 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1731 . $self->deparse($op->first->sibling, 7),
1733 } elsif (!null($op->first->sibling) and
1734 $op->first->sibling->ppaddr eq "pp_trans" and
1735 $op->first->sibling->flags & OPf_STACKED) {
1736 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1737 . $self->deparse($op->first->sibling, 20),
1740 return $self->deparse($op->first, $cx);
1747 my $str = $self->padname_sv($targ)->PV;
1748 return padname_fix($str);
1754 return substr($self->padname($op->targ), 1); # skip $/@/%
1760 return $self->maybe_my($op, $cx, $self->padname($op->targ));
1763 sub pp_padav { pp_padsv(@_) }
1764 sub pp_padhv { pp_padsv(@_) }
1769 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1770 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1771 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1778 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
1784 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
1790 return $self->gv_name($op->gv);
1797 return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1802 my($op, $cx, $type) = @_;
1803 my $kid = $op->first;
1804 my $str = $self->deparse($kid, 0);
1805 return $type . (is_scalar($kid) ? $str : "{$str}");
1808 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1809 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1810 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1816 if ($op->first->ppaddr eq "pp_padav") {
1817 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1819 return $self->maybe_local($op, $cx,
1820 $self->rv2x($op->first, $cx, '$#'));
1824 # skip down to the old, ex-rv2cv
1825 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
1830 my $kid = $op->first;
1831 if ($kid->ppaddr eq "pp_const") { # constant list
1833 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1835 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
1842 my ($op, $cx, $left, $right, $padname) = @_;
1843 my($array, $idx) = ($op->first, $op->first->sibling);
1844 unless ($array->ppaddr eq $padname) { # Maybe this has been fixed
1845 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1847 if ($array->ppaddr eq $padname) {
1848 $array = $self->padany($array);
1849 } elsif (is_scope($array)) { # ${expr}[0]
1850 $array = "{" . $self->deparse($array, 0) . "}";
1851 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
1852 $array = $self->deparse($array, 24);
1854 # $x[20][3]{hi} or expr->[20]
1856 $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/;
1857 return $self->deparse($array, 24) . $arrow .
1858 $left . $self->deparse($idx, 1) . $right;
1860 $idx = $self->deparse($idx, 1);
1861 return "\$" . $array . $left . $idx . $right;
1864 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) }
1865 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) }
1870 my($glob, $part) = ($op->first, $op->last);
1871 $glob = $glob->first; # skip rv2gv
1872 $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug
1873 my $scope = is_scope($glob);
1874 $glob = $self->deparse($glob, 0);
1875 $part = $self->deparse($part, 1);
1876 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
1881 my ($op, $cx, $left, $right, $regname, $padname) = @_;
1883 my(@elems, $kid, $array, $list);
1884 if (class($op) eq "LISTOP") {
1886 } else { # ex-hslice inside delete()
1887 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
1891 $array = $array->first
1892 if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null";
1893 if (is_scope($array)) {
1894 $array = "{" . $self->deparse($array, 0) . "}";
1895 } elsif ($array->ppaddr eq $padname) {
1896 $array = $self->padany($array);
1898 $array = $self->deparse($array, 24);
1900 $kid = $op->first->sibling; # skip pushmark
1901 if ($kid->ppaddr eq "pp_list") {
1902 $kid = $kid->first->sibling; # skip list, pushmark
1903 for (; !null $kid; $kid = $kid->sibling) {
1904 push @elems, $self->deparse($kid, 6);
1906 $list = join(", ", @elems);
1908 $list = $self->deparse($kid, 1);
1910 return "\@" . $array . $left . $list . $right;
1913 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]",
1914 "pp_rv2av", "pp_padav")) }
1915 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
1916 "pp_rv2hv", "pp_padhv")) }
1921 my $idx = $op->first;
1922 my $list = $op->last;
1924 $list = $self->deparse($list, 1);
1925 $idx = $self->deparse($idx, 1);
1926 return "($list)" . "[$idx]";
1929 sub OPpENTERSUB_AMPER () { 8 }
1931 sub OPf_WANT () { 3 }
1932 sub OPf_WANT_VOID () { 1 }
1933 sub OPf_WANT_SCALAR () { 2 }
1934 sub OPf_WANT_LIST () { 2 }
1938 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
1948 my($kid, $args, @exprs);
1949 if (not null $op->first->sibling) { # method
1950 $kid = $op->first->sibling; # skip pushmark
1951 my $obj = $self->deparse($kid, 24);
1952 $kid = $kid->sibling;
1953 for (; not null $kid->sibling; $kid = $kid->sibling) {
1954 push @exprs, $self->deparse($kid, 6);
1956 my $meth = $kid->first;
1957 if ($meth->ppaddr eq "pp_const") {
1958 $meth = $meth->sv->PV; # needs to be bare
1960 $meth = $self->deparse($meth, 1);
1962 $args = join(", ", @exprs);
1963 $kid = $obj . "->" . $meth;
1965 return $kid . "(" . $args . ")"; # parens mandatory
1967 return $kid; # toke.c fakes parens
1970 # else, not a method
1971 if ($op->flags & OPf_SPECIAL) {
1973 } elsif ($op->private & OPpENTERSUB_AMPER) {
1977 $kid = $kid->first->sibling; # skip ex-list, pushmark
1978 for (; not null $kid->sibling; $kid = $kid->sibling) {
1981 if (is_scope($kid)) {
1983 $kid = "{" . $self->deparse($kid, 0) . "}";
1984 } elsif ($kid->first->ppaddr eq "pp_gv") {
1985 my $gv = $kid->first->gv;
1986 if (class($gv->CV) ne "SPECIAL") {
1987 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
1990 $kid = $self->deparse($kid, 24);
1991 } elsif (is_scalar $kid->first) {
1993 $kid = $self->deparse($kid, 24);
1996 $kid = $self->deparse($kid, 24) . "->";
1998 if (defined $proto and not $amper) {
2004 $p =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2006 $p =~ s/^ *([\\]?[\$\@&%*]|;)//;
2009 undef $proto if @args;
2010 } elsif ($chr eq ";") {
2012 } elsif ($chr eq "@" or $chr eq "%") {
2013 push @reals, map($self->deparse($_, 6), @args);
2019 if (want_scalar $arg) {
2020 push @reals, $self->deparse($arg, 6);
2024 } elsif ($chr eq "&") {
2025 if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
2026 push @reals, $self->deparse($arg, 6);
2030 } elsif ($chr eq "*") {
2031 if ($arg->ppaddr =~ /^pp_s?refgen$/
2032 and $arg->first->first->ppaddr eq "pp_rv2gv")
2034 $real = $arg->first->first; # skip refgen, null
2035 if ($real->first->ppaddr eq "pp_gv") {
2036 push @reals, $self->deparse($real, 6);
2038 push @reals, $self->deparse($real->first, 6);
2043 } elsif (substr($chr, 0, 1) eq "\\") {
2044 $chr = substr($chr, 1);
2045 if ($arg->ppaddr =~ /^pp_s?refgen$/ and
2046 !null($real = $arg->first) and
2047 ($chr eq "\$" && is_scalar($real->first)
2049 && $real->first->sibling->ppaddr
2050 =~ /^pp_(rv2|pad)av$/)
2052 && $real->first->sibling->ppaddr
2053 =~ /^pp_(rv2|pad)hv$/)
2054 #or ($chr eq "&" # This doesn't work
2055 # && $real->first->ppaddr eq "pp_rv2cv")
2057 && $real->first->ppaddr eq "pp_rv2gv")))
2059 push @reals, $self->deparse($real, 6);
2066 undef $proto if $p and !$doneok;
2067 undef $proto if @args;
2068 $args = join(", ", @reals);
2070 unless (defined $proto) {
2072 $args = join(", ", map($self->deparse($_, 6), @exprs));
2075 $args = join(", ", map($self->deparse($_, 6), @exprs));
2077 if ($prefix or $amper) {
2078 if ($op->flags & OPf_STACKED) {
2079 return $prefix . $amper . $kid . "(" . $args . ")";
2081 return $prefix . $amper. $kid;
2084 if (defined $proto and $proto eq "") {
2086 } elsif ($proto eq "\$") {
2087 return $self->maybe_parens_func($kid, $args, $cx, 16);
2088 } elsif ($proto or $simple) {
2089 return $self->maybe_parens_func($kid, $args, $cx, 5);
2091 return "$kid(" . $args . ")";
2096 sub pp_enterwrite { unop(@_, "write") }
2098 # escape things that cause interpolation in double quotes,
2099 # but not character escapes
2102 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2106 # the same, but treat $|, $), and $ at the end of the string differently
2109 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2110 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2114 # character escapes, but not delimiters that might need to be escaped
2115 sub escape_str { # ASCII
2118 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2124 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2125 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2129 # Don't do this for regexen
2132 $str =~ s/\\/\\\\/g;
2136 sub balanced_delim {
2138 my @str = split //, $str;
2139 my($ar, $open, $close, $fail, $c, $cnt);
2140 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2141 ($open, $close) = @$ar;
2142 $fail = 0; $cnt = 0;
2146 } elsif ($c eq $close) {
2154 $fail = 1 if $cnt != 0;
2155 return ($open, "$open$str$close") if not $fail;
2161 my($q, $default, $str) = @_;
2162 return "$default$str$default" if $default and index($str, $default) == -1;
2163 my($succeed, $delim);
2164 ($succeed, $str) = balanced_delim($str);
2165 return "$q$str" if $succeed;
2166 for $delim ('/', '"', '#') {
2167 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2170 $str =~ s/$default/\\$default/g;
2171 return "$default$str$default";
2178 sub SVf_IOK () {0x10000}
2179 sub SVf_NOK () {0x20000}
2180 sub SVf_ROK () {0x80000}
2184 if (class($sv) eq "SPECIAL") {
2185 return ('undef', '1', '0')[$$sv-1];
2186 } elsif ($sv->FLAGS & SVf_IOK) {
2188 } elsif ($sv->FLAGS & SVf_NOK) {
2190 } elsif ($sv->FLAGS & SVf_ROK) {
2191 return "\\(" . const($sv->RV) . ")"; # constant folded
2194 if ($str =~ /[^ -~]/) { # ASCII
2195 return single_delim("qq", '"', uninterp escape_str unback $str);
2197 $str =~ s/\\/\\\\/g;
2198 return single_delim("q", "'", $str);
2206 # if ($op->private & OPp_CONST_BARE) { # trouble with `=>' autoquoting
2207 # return $op->sv->PV;
2209 return const($op->sv);
2215 my $type = $op->ppaddr;
2216 if ($type eq "pp_const") {
2217 return uninterp(escape_str(unback($op->sv->PV)));
2218 } elsif ($type eq "pp_concat") {
2219 return $self->dq($op->first) . $self->dq($op->last);
2220 } elsif ($type eq "pp_uc") {
2221 return '\U' . $self->dq($op->first->sibling) . '\E';
2222 } elsif ($type eq "pp_lc") {
2223 return '\L' . $self->dq($op->first->sibling) . '\E';
2224 } elsif ($type eq "pp_ucfirst") {
2225 return '\u' . $self->dq($op->first->sibling);
2226 } elsif ($type eq "pp_lcfirst") {
2227 return '\l' . $self->dq($op->first->sibling);
2228 } elsif ($type eq "pp_quotemeta") {
2229 return '\Q' . $self->dq($op->first->sibling) . '\E';
2230 } elsif ($type eq "pp_join") {
2231 return $self->deparse($op->last, 26); # was join($", @ary)
2233 return $self->deparse($op, 26);
2241 return single_delim("qx", '`', $self->dq($op->first->sibling));
2247 # skip ex-stringify, pushmark
2248 return single_delim("qq", '"', $self->dq($op->first->sibling));
2251 # OP_STRINGIFY is a listop, but it only ever has one arg (?)
2252 sub pp_stringify { dquote(@_) }
2254 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2255 # note that tr(from)/to/ is OK, but not tr/from/(to)
2257 my($from, $to) = @_;
2258 my($succeed, $delim);
2259 if ($from !~ m[/] and $to !~ m[/]) {
2260 return "/$from/$to/";
2261 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2262 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2265 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2266 return "$from$delim$to$delim" if index($to, $delim) == -1;
2269 return "$from/$to/";
2272 for $delim ('/', '"', '#') { # note no '
2273 return "$delim$from$delim$to$delim"
2274 if index($to . $from, $delim) == -1;
2276 $from =~ s[/][\\/]g;
2278 return "/$from/$to/";
2284 if ($n == ord '\\') {
2286 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2288 } elsif ($n == ord "\a") {
2290 } elsif ($n == ord "\b") {
2292 } elsif ($n == ord "\t") {
2294 } elsif ($n == ord "\n") {
2296 } elsif ($n == ord "\e") {
2298 } elsif ($n == ord "\f") {
2300 } elsif ($n == ord "\r") {
2302 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2303 return '\\c' . chr(ord("@") + $n);
2305 # return '\x' . sprintf("%02x", $n);
2306 return '\\' . sprintf("%03o", $n);
2313 for ($c = 0; $c < @chars; $c++) {
2316 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2317 $chars[$c + 2] == $tr + 2)
2319 for (; $c <= $#chars and $chars[$c + 1] == $chars[$c] + 1; $c++) {}
2321 $str .= pchr($chars[$c]);
2327 sub OPpTRANS_SQUASH () { 16 }
2328 sub OPpTRANS_DELETE () { 32 }
2329 sub OPpTRANS_COMPLEMENT () { 64 }
2334 my(@table) = unpack("s256", $op->pv);
2335 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2336 if ($table[ord "-"] != -1 and
2337 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2339 $tr = $table[ord "-"];
2340 $table[ord "-"] = -1;
2344 } else { # -2 ==> delete
2348 for ($c = 0; $c < 256; $c++) {
2351 push @from, $c; push @to, $tr;
2352 } elsif ($tr == -2) {
2357 @from = (@from, @delfrom);
2358 if ($op->private & OPpTRANS_COMPLEMENT) {
2362 @from{@from} = (1) x @from;
2363 for ($c = 0; $c < 256; $c++) {
2364 push @newfrom, $c unless $from{$c};
2368 if ($op->private & OPpTRANS_DELETE) {
2371 pop @to while $#to and $to[$#to] == $to[$#to -1];
2373 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2375 $from = collapse(@from);
2376 $to = collapse(@to);
2377 $from .= "-" if $delhyphen;
2378 return "tr" . double_delim($from, $to) . $flags;
2381 # Like dq(), but different
2385 my $type = $op->ppaddr;
2386 if ($type eq "pp_const") {
2387 return uninterp($op->sv->PV);
2388 } elsif ($type eq "pp_concat") {
2389 return $self->re_dq($op->first) . $self->re_dq($op->last);
2390 } elsif ($type eq "pp_uc") {
2391 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2392 } elsif ($type eq "pp_lc") {
2393 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2394 } elsif ($type eq "pp_ucfirst") {
2395 return '\u' . $self->re_dq($op->first->sibling);
2396 } elsif ($type eq "pp_lcfirst") {
2397 return '\l' . $self->re_dq($op->first->sibling);
2398 } elsif ($type eq "pp_quotemeta") {
2399 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2400 } elsif ($type eq "pp_join") {
2401 return $self->deparse($op->last, 26); # was join($", @ary)
2403 return $self->deparse($op, 26);
2410 my $kid = $op->first;
2411 $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe";
2412 $kid = $kid->first if $kid->ppaddr eq "pp_regcreset";
2413 return $self->re_dq($kid);
2416 sub OPp_RUNTIME () { 64 }
2418 sub PMf_ONCE () { 0x2 }
2419 sub PMf_SKIPWHITE () { 0x10 }
2420 sub PMf_CONST () { 0x40 }
2421 sub PMf_KEEP () { 0x80 }
2422 sub PMf_GLOBAL () { 0x100 }
2423 sub PMf_CONTINUE () { 0x200 }
2424 sub PMf_EVAL () { 0x400 }
2425 sub PMf_LOCALE () { 0x800 }
2426 sub PMf_MULTILINE () { 0x1000 }
2427 sub PMf_SINGLELINE () { 0x2000 }
2428 sub PMf_FOLD () { 0x4000 }
2429 sub PMf_EXTENDED () { 0x8000 }
2431 # osmic acid -- see osmium tetroxide
2434 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2435 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2436 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2440 my($op, $cx, $name, $delim) = @_;
2441 my $kid = $op->first;
2442 my ($binop, $var, $re) = ("", "", "");
2443 if ($op->flags & OPf_STACKED) {
2445 $var = $self->deparse($kid, 20);
2446 $kid = $kid->sibling;
2449 $re = re_uninterp(escape_str($op->precomp));
2451 $re = $self->deparse($kid, 1);
2454 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2455 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2456 $flags .= "i" if $op->pmflags & PMf_FOLD;
2457 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2458 $flags .= "o" if $op->pmflags & PMf_KEEP;
2459 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2460 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2461 $flags = $matchwords{$flags} if $matchwords{$flags};
2462 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2466 $re = single_delim($name, $delim, $re);
2470 return $self->maybe_parens("$var =~ $re", $cx, 20);
2476 sub pp_match { matchop(@_, "m", "/") }
2477 sub pp_pushre { matchop(@_, "m", "/") }
2478 sub pp_qr { matchop(@_, "qr", "") }
2483 my($kid, @exprs, $ary, $expr);
2485 if ($ {$kid->pmreplroot}) {
2486 $ary = '@' . $self->gv_name($kid->pmreplroot);
2488 for (; !null($kid); $kid = $kid->sibling) {
2489 push @exprs, $self->deparse($kid, 6);
2491 $expr = "split(" . join(", ", @exprs) . ")";
2493 return $self->maybe_parens("$ary = $expr", $cx, 7);
2499 # oxime -- any of various compounds obtained chiefly by the action of
2500 # hydroxylamine on aldehydes and ketones and characterized by the
2501 # bivalent grouping C=NOH [Webster's Tenth]
2504 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2505 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2506 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2507 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2512 my $kid = $op->first;
2513 my($binop, $var, $re, $repl) = ("", "", "", "");
2514 if ($op->flags & OPf_STACKED) {
2516 $var = $self->deparse($kid, 20);
2517 $kid = $kid->sibling;
2520 if (null($op->pmreplroot)) {
2521 $repl = $self->dq($kid);
2522 $kid = $kid->sibling;
2524 $repl = $op->pmreplroot->first; # skip substcont
2525 while ($repl->ppaddr eq "pp_entereval") {
2526 $repl = $repl->first;
2529 $repl = $self->dq($repl);
2532 $re = re_uninterp(escape_str($op->precomp));
2534 $re = $self->deparse($kid, 1);
2536 $flags .= "e" if $op->pmflags & PMf_EVAL;
2537 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2538 $flags .= "i" if $op->pmflags & PMf_FOLD;
2539 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2540 $flags .= "o" if $op->pmflags & PMf_KEEP;
2541 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2542 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2543 $flags = $substwords{$flags} if $substwords{$flags};
2545 return $self->maybe_parens("$var =~ s"
2546 . double_delim($re, $repl) . $flags,
2549 return "s". double_delim($re, $repl) . $flags;
2558 B::Deparse - Perl compiler backend to produce perl code
2562 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-l>][B<,-s>I<LETTERS>] I<prog.pl>
2566 B::Deparse is a backend module for the Perl compiler that generates
2567 perl source code, based on the internal compiled structure that perl
2568 itself creates after parsing a program. The output of B::Deparse won't
2569 be exactly the same as the original source, since perl doesn't keep
2570 track of comments or whitespace, and there isn't a one-to-one
2571 correspondence between perl's syntactical constructions and their
2572 compiled form, but it will often be close. When you use the B<-p>
2573 option, the output also includes parentheses even when they are not
2574 required by precedence, which can make it easy to see if perl is
2575 parsing your expressions the way you intended.
2577 Please note that this module is mainly new and untested code and is
2578 still under development, so it may change in the future.
2582 As with all compiler backend options, these must follow directly after
2583 the '-MO=Deparse', separated by a comma but not any white space.
2589 Print extra parentheses. Without this option, B::Deparse includes
2590 parentheses in its output only when they are needed, based on the
2591 structure of your program. With B<-p>, it uses parentheses (almost)
2592 whenever they would be legal. This can be useful if you are used to
2593 LISP, or if you want to see how perl parses your input. If you say
2595 if ($var & 0x7f == 65) {print "Gimme an A!"}
2596 print ($which ? $a : $b), "\n";
2597 $name = $ENV{USER} or "Bob";
2599 C<B::Deparse,-p> will print
2602 print('Gimme an A!')
2604 (print(($which ? $a : $b)), '???');
2605 (($name = $ENV{'USER'}) or '???')
2607 which probably isn't what you intended (the C<'???'> is a sign that
2608 perl optimized away a constant value).
2610 =item B<-u>I<PACKAGE>
2612 Normally, B::Deparse deparses the main code of a program, all the subs
2613 called by the main program (and all the subs called by them,
2614 recursively), and any other subs in the main:: package. To include
2615 subs in other packages that aren't called directly, such as AUTOLOAD,
2616 DESTROY, other subs called automatically by perl, and methods, which
2617 aren't resolved to subs until runtime, use the B<-u> option. The
2618 argument to B<-u> is the name of a package, and should follow directly
2619 after the 'u'. Multiple B<-u> options may be given, separated by
2620 commas. Note that unlike some other backends, B::Deparse doesn't
2621 (yet) try to guess automatically when B<-u> is needed -- you must
2626 Add '#line' declarations to the output based on the line and file
2627 locations of the original code.
2629 =item B<-s>I<LETTERS>
2631 Tweak the style of B::Deparse's output. At the moment, only one style
2632 option is implemented:
2638 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2655 The default is not to cuddle.
2663 See the 'to do' list at the beginning of the module file.
2667 Stephen McCamant <alias@mcs.com>, based on an earlier version by
2668 Malcolm Beattie <mbeattie@sable.ox.ac.uk>.