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 opnumber
12 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
13 OPpENTERSUB_AMPER OPf_KIDS OPpLVAL_INTRO
14 OPf_SPECIAL OPpSLICE OPpCONST_BARE OPf_REF OPf_STACKED
15 OPpENTERSUB_AMPER OPpTRANS_SQUASH OPpTRANS_DELETE
16 OPpTRANS_COMPLEMENT SVf_IOK SVf_NOK SVf_ROK SVf_POK
17 PMf_ONCE PMf_SKIPWHITE PMf_CONST PMf_KEEP PMf_GLOBAL PMf_CONTINUE
18 PMf_EVAL PMf_LOCALE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED
23 # Changes between 0.50 and 0.51:
24 # - fixed nulled leave with live enter in sort { }
25 # - fixed reference constants (\"str")
26 # - handle empty programs gracefully
27 # - handle infinte loops (for (;;) {}, while (1) {})
28 # - differentiate between `for my $x ...' and `my $x; for $x ...'
29 # - various minor cleanups
30 # - moved globals into an object
31 # - added `-u', like B::C
32 # - package declarations using cop_stash
33 # - subs, formats and code sorted by cop_seq
34 # Changes between 0.51 and 0.52:
35 # - added pp_threadsv (special variables under USE_THREADS)
36 # - added documentation
37 # Changes between 0.52 and 0.53
38 # - many changes adding precedence contexts and associativity
39 # - added `-p' and `-s' output style options
40 # - various other minor fixes
41 # Changes between 0.53 and 0.54
42 # - added support for new `for (1..100)' optimization,
44 # Changes between 0.54 and 0.55
45 # - added support for new qr// construct
46 # - added support for new pp_regcreset OP
47 # Changes between 0.55 and 0.56
48 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
49 # - fixed $# on non-lexicals broken in last big rewrite
50 # - added temporary fix for change in opcode of OP_STRINGIFY
51 # - fixed problem in 0.54's for() patch in `for (@ary)'
52 # - fixed precedence in conditional of ?:
53 # - tweaked list paren elimination in `my($x) = @_'
54 # - made continue-block detection trickier wrt. null ops
55 # - fixed various prototype problems in pp_entersub
56 # - added support for sub prototypes that never get GVs
57 # - added unquoting for special filehandle first arg in truncate
58 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
59 # - added semicolons at the ends of blocks
60 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
63 # - {} around variables in strings ("${var}letters")
66 # - generate symbolic constants directly from core source
67 # - left/right context
68 # - avoid semis in one-statement blocks
69 # - associativity of &&=, ||=, ?:
70 # - ',' => '=>' (auto-unquote?)
71 # - break long lines ("\r" as discretionary break?)
72 # - include values of variables (e.g. set in BEGIN)
73 # - coordinate with Data::Dumper (both directions? see previous)
74 # - version using op_next instead of op_first/sibling?
75 # - avoid string copies (pass arrays, one big join?)
77 # - while{} with one-statement continue => for(; XXX; XXX) {}?
78 # - -uPackage:: descend recursively?
82 # Tests that will always fail:
83 # comp/redef.t -- all (redefinition happens at compile time)
85 # Object fields (were globals):
88 # (local($a), local($b)) and local($a, $b) have the same internal
89 # representation but the short form looks better. We notice we can
90 # use a large-scale local when checking the list, but need to prevent
91 # individual locals too. This hash holds the addresses of OPs that
92 # have already had their local-ness accounted for. The same thing
96 # CV for current sub (or main program) being deparsed
99 # name of the current package for deparsed code
102 # array of [cop_seq, GV, is_format?] for subs and formats we still
106 # as above, but [name, prototype] for subs that never got a GV
108 # subs_done, forms_done:
109 # keys are addresses of GVs for subs and formats we've already
110 # deparsed (or at least put into subs_todo)
114 # cuddle: ` ' or `\n', depending on -sC
116 # A little explanation of how precedence contexts and associativity
119 # deparse() calls each per-op subroutine with an argument $cx (short
120 # for context, but not the same as the cx* in the perl core), which is
121 # a number describing the op's parents in terms of precedence, whether
122 # they're inside an expression or at statement level, etc. (see
123 # chart below). When ops with children call deparse on them, they pass
124 # along their precedence. Fractional values are used to implement
125 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
126 # parentheses hacks. The major disadvantage of this scheme is that
127 # it doesn't know about right sides and left sides, so say if you
128 # assign a listop to a variable, it can't tell it's allowed to leave
129 # the parens off the listop.
132 # 26 [TODO] inside interpolation context ("")
133 # 25 left terms and list operators (leftward)
137 # 21 right ! ~ \ and unary + and -
142 # 16 nonassoc named unary operators
143 # 15 nonassoc < > <= >= lt gt le ge
144 # 14 nonassoc == != <=> eq ne cmp
151 # 7 right = += -= *= etc.
153 # 5 nonassoc list operators (rightward)
157 # 1 statement modifiers
160 # Nonprinting characters with special meaning:
161 # \cS - steal parens (see maybe_parens_unop)
162 # \n - newline and indent
163 # \t - increase indent
164 # \b - decrease indent (`outdent')
165 # \f - flush left (no indent)
166 # \cK - kill following semicolon, if any
170 return class($op) eq "NULL";
175 my($gv, $cv, $is_form) = @_;
177 if (!null($cv->START) and is_state($cv->START)) {
178 $seq = $cv->START->cop_seq;
182 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
187 my $ent = shift @{$self->{'subs_todo'}};
188 my $name = $self->gv_name($ent->[1]);
190 return "format $name =\n"
191 . $self->deparse_format($ent->[1]->FORM). "\n";
193 return "sub $name " .
194 $self->deparse_sub($ent->[1]->CV);
202 if ($op->flags & OPf_KIDS) {
204 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
205 walk_tree($kid, $sub);
214 $op = shift if null $op;
215 return if !$op or null $op;
218 if ($op->ppaddr eq "pp_gv") {
219 if ($op->next->ppaddr eq "pp_entersub") {
220 next if $self->{'subs_done'}{$ {$op->gv}}++;
221 next if class($op->gv->CV) eq "SPECIAL";
222 $self->todo($op->gv, $op->gv->CV, 0);
223 $self->walk_sub($op->gv->CV);
224 } elsif ($op->next->ppaddr eq "pp_enterwrite"
225 or ($op->next->ppaddr eq "pp_rv2gv"
226 and $op->next->next->ppaddr eq "pp_enterwrite")) {
227 next if $self->{'forms_done'}{$ {$op->gv}}++;
228 next if class($op->gv->FORM) eq "SPECIAL";
229 $self->todo($op->gv, $op->gv->FORM, 1);
230 $self->walk_sub($op->gv->FORM);
240 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
241 if ($pack eq "main") {
244 $pack = $pack . "::";
247 while (($key, $val) = each %stash) {
248 my $class = class($val);
249 if ($class eq "PV") {
251 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
252 } elsif ($class eq "IV") {
254 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
255 } elsif ($class eq "GV") {
256 if (class($val->CV) ne "SPECIAL") {
257 next if $self->{'subs_done'}{$$val}++;
258 $self->todo($val, $val->CV, 0);
259 $self->walk_sub($val->CV);
261 if (class($val->FORM) ne "SPECIAL") {
262 next if $self->{'forms_done'}{$$val}++;
263 $self->todo($val, $val->FORM, 1);
264 $self->walk_sub($val->FORM);
274 foreach $ar (@{$self->{'protos_todo'}}) {
275 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
276 push @ret, "sub " . $ar->[0] . "$proto;\n";
278 delete $self->{'protos_todo'};
286 while (length($opt = substr($opts, 0, 1))) {
288 $self->{'cuddle'} = " ";
290 $opts = substr($opts, 1);
299 $self->{'subs_todo'} = [];
300 $self->stash_subs("main");
301 $self->{'curcv'} = main_cv;
302 $self->{'curstash'} = "main";
303 $self->{'cuddle'} = "\n";
304 while ($arg = shift @args) {
305 if (substr($arg, 0, 2) eq "-u") {
306 $self->stash_subs(substr($arg, 2));
307 } elsif ($arg eq "-p") {
308 $self->{'parens'} = 1;
309 } elsif ($arg eq "-l") {
310 $self->{'linenums'} = 1;
311 } elsif (substr($arg, 0, 2) eq "-s") {
312 $self->style_opts(substr $arg, 2);
315 $self->walk_sub(main_cv, main_start);
316 print $self->print_protos;
317 @{$self->{'subs_todo'}} =
318 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
319 print indent($self->deparse(main_root, 0)), "\n" unless null main_root;
321 while (scalar(@{$self->{'subs_todo'}})) {
322 push @text, $self->next_todo;
324 print indent(join("", @text)), "\n" if @text;
331 # cluck if class($op) eq "NULL";
332 my $meth = $op->ppaddr;
333 return $self->$meth($op, $cx);
338 my @lines = split(/\n/, $txt);
342 if (substr($line, 0, 1) eq "\t") {
343 $leader = $leader . " ";
344 $line = substr($line, 1);
345 } elsif (substr($line, 0, 1) eq "\b") {
346 $leader = substr($leader, 0, length($leader) - 4);
347 $line = substr($line, 1);
349 if (substr($line, 0, 1) eq "\f") {
350 $line = substr($line, 1); # no indent
352 $line = $leader . $line;
356 return join("\n", @lines);
364 if ($cv->FLAGS & SVf_POK) {
365 $proto = "(". $cv->PV . ") ";
367 local($self->{'curcv'}) = $cv;
368 local($self->{'curstash'}) = $self->{'curstash'};
369 if (not null $cv->ROOT) {
371 return $proto . "{\n\t" .
372 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
374 return $proto . "{}\n";
382 local($self->{'curcv'}) = $form;
383 local($self->{'curstash'}) = $self->{'curstash'};
384 my $op = $form->ROOT;
386 $op = $op->first->first; # skip leavewrite, lineseq
387 while (not null $op) {
388 $op = $op->sibling; # skip nextstate
390 $kid = $op->first->sibling; # skip pushmark
391 push @text, $kid->sv->PV;
392 $kid = $kid->sibling;
393 for (; not null $kid; $kid = $kid->sibling) {
394 push @exprs, $self->deparse($kid, 0);
396 push @text, join(", ", @exprs)."\n" if @exprs;
399 return join("", @text) . ".";
402 # the aassign in-common check messes up SvCUR (always setting it
403 # to a value >= 100), but it's probably safe to assume there
404 # won't be any NULs in the names of my() variables. (with
405 # stash variables, I wouldn't be so sure)
408 $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
414 return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope"
415 || $op->ppaddr eq "pp_lineseq"
416 || ($op->ppaddr eq "pp_null" && class($op) eq "UNOP"
417 && (is_scope($op->first) || $op->first->ppaddr eq "pp_enter"));
421 my $name = $_[0]->ppaddr;
422 return $name eq "pp_nextstate" || $name eq "pp_dbstate";
425 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
427 return (!null($op) and null($op->sibling)
428 and $op->ppaddr eq "pp_null" and class($op) eq "UNOP"
429 and (($op->first->ppaddr =~ /^pp_(and|or)$/
430 and $op->first->first->sibling->ppaddr eq "pp_lineseq")
431 or ($op->first->ppaddr eq "pp_lineseq"
432 and not null $op->first->first->sibling
433 and $op->first->first->sibling->ppaddr eq "pp_unstack")
439 return ($op->ppaddr eq "pp_rv2sv" or
440 $op->ppaddr eq "pp_padsv" or
441 $op->ppaddr eq "pp_gv" or # only in array/hash constructs
442 !null($op->first) && $op->first->ppaddr eq "pp_gvsv");
447 my($text, $cx, $prec) = @_;
448 if ($prec < $cx # unary ops nest just fine
449 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
450 or $self->{'parens'})
453 # In a unop, let parent reuse our parens; see maybe_parens_unop
454 $text = "\cS" . $text if $cx == 16;
461 # same as above, but get around the `if it looks like a function' rule
462 sub maybe_parens_unop {
464 my($name, $kid, $cx) = @_;
465 if ($cx > 16 or $self->{'parens'}) {
466 return "$name(" . $self->deparse($kid, 1) . ")";
468 $kid = $self->deparse($kid, 16);
469 if (substr($kid, 0, 1) eq "\cS") {
471 return $name . substr($kid, 1);
472 } elsif (substr($kid, 0, 1) eq "(") {
473 # avoid looks-like-a-function trap with extra parens
474 # (`+' can lead to ambiguities)
475 return "$name(" . $kid . ")";
482 sub maybe_parens_func {
484 my($func, $text, $cx, $prec) = @_;
485 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
486 return "$func($text)";
488 return "$func $text";
495 my($op, $cx, $text) = @_;
496 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
497 return $self->maybe_parens_func("local", $text, $cx, 16);
506 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
511 my($op, $cx, $text) = @_;
512 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
513 return $self->maybe_parens_func("my", $text, $cx, 16);
519 # The following OPs don't have functions:
521 # pp_padany -- does not exist after parsing
522 # pp_rcatline -- does not exist
524 sub pp_enter { # see also leave
525 cluck "unexpected OP_ENTER";
529 sub pp_pushmark { # see also list
530 cluck "unexpected OP_PUSHMARK";
534 sub pp_leavesub { # see also deparse_sub
535 cluck "unexpected OP_LEAVESUB";
539 sub pp_leavewrite { # see also deparse_format
540 cluck "unexpected OP_LEAVEWRITE";
544 sub pp_method { # see also entersub
545 cluck "unexpected OP_METHOD";
549 sub pp_regcmaybe { # see also regcomp
550 cluck "unexpected OP_REGCMAYBE";
554 sub pp_regcreset { # see also regcomp
555 cluck "unexpected OP_REGCRESET";
559 sub pp_substcont { # see also subst
560 cluck "unexpected OP_SUBSTCONT";
564 sub pp_grepstart { # see also grepwhile
565 cluck "unexpected OP_GREPSTART";
569 sub pp_mapstart { # see also mapwhile
570 cluck "unexpected OP_MAPSTART";
574 sub pp_flip { # see also flop
575 cluck "unexpected OP_FLIP";
579 sub pp_iter { # see also leaveloop
580 cluck "unexpected OP_ITER";
584 sub pp_enteriter { # see also leaveloop
585 cluck "unexpected OP_ENTERITER";
589 sub pp_enterloop { # see also leaveloop
590 cluck "unexpected OP_ENTERLOOP";
594 sub pp_leaveeval { # see also entereval
595 cluck "unexpected OP_LEAVEEVAL";
599 sub pp_entertry { # see also leavetry
600 cluck "unexpected OP_ENTERTRY";
604 # leave and scope/lineseq should probably share code
610 local($self->{'curstash'}) = $self->{'curstash'};
611 $kid = $op->first->sibling; # skip enter
612 if (is_miniwhile($kid)) {
613 my $top = $kid->first;
614 my $name = $top->ppaddr;
615 if ($name eq "pp_and") {
617 } elsif ($name eq "pp_or") {
619 } else { # no conditional -> while 1 or until 0
620 return $self->deparse($top->first, 1) . " while 1";
622 my $cond = $top->first;
623 my $body = $cond->sibling->first; # skip lineseq
624 $cond = $self->deparse($cond, 1);
625 $body = $self->deparse($body, 1);
626 return "$body $name $cond";
628 for (; !null($kid); $kid = $kid->sibling) {
631 $expr = $self->deparse($kid, 0);
632 $kid = $kid->sibling;
635 $expr .= $self->deparse($kid, 0);
636 push @exprs, $expr if $expr;
638 if ($cx > 0) { # inside an expression
639 return "do { " . join(";\n", @exprs) . " }";
641 return join(";\n", @exprs) . ";";
650 for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
653 $expr = $self->deparse($kid, 0);
654 $kid = $kid->sibling;
657 $expr .= $self->deparse($kid, 0);
658 push @exprs, $expr if $expr;
660 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
661 return "do { " . join(";\n", @exprs) . " }";
663 return join(";\n", @exprs) . ";";
667 sub pp_lineseq { pp_scope(@_) }
669 # The BEGIN {} is used here because otherwise this code isn't executed
670 # when you run B::Deparse on itself.
672 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
673 "ENV", "ARGV", "ARGVOUT", "_"); }
678 my $stash = $gv->STASH->NAME;
679 my $name = $gv->NAME;
680 if ($stash eq $self->{'curstash'} or $globalnames{$name}
681 or $name =~ /^[^A-Za-z_]/)
685 $stash = $stash . "::";
687 if ($name =~ /^([\cA-\cZ])$/) {
688 $name = "^" . chr(64 + ord($1));
690 return $stash . $name;
693 # Notice how subs and formats are inserted between statements here
698 @text = $op->label . ": " if $op->label;
699 my $seq = $op->cop_seq;
700 while (scalar(@{$self->{'subs_todo'}})
701 and $seq > $self->{'subs_todo'}[0][0]) {
702 push @text, $self->next_todo;
704 my $stash = $op->stash->NAME;
705 if ($stash ne $self->{'curstash'}) {
706 push @text, "package $stash;\n";
707 $self->{'curstash'} = $stash;
709 if ($self->{'linenums'}) {
710 push @text, "\f#line " . $op->line .
711 ' "' . substr($op->filegv->NAME, 2), qq'"\n';
713 return join("", @text);
716 sub pp_dbstate { pp_nextstate(@_) }
718 sub pp_unstack { return "" } # see also leaveloop
722 my($op, $cx, $name) = @_;
726 sub pp_stub { baseop(@_, "()") }
727 sub pp_wantarray { baseop(@_, "wantarray") }
728 sub pp_fork { baseop(@_, "fork") }
729 sub pp_wait { baseop(@_, "wait") }
730 sub pp_getppid { baseop(@_, "getppid") }
731 sub pp_time { baseop(@_, "time") }
732 sub pp_tms { baseop(@_, "times") }
733 sub pp_ghostent { baseop(@_, "gethostent") }
734 sub pp_gnetent { baseop(@_, "getnetent") }
735 sub pp_gprotoent { baseop(@_, "getprotoent") }
736 sub pp_gservent { baseop(@_, "getservent") }
737 sub pp_ehostent { baseop(@_, "endhostent") }
738 sub pp_enetent { baseop(@_, "endnetent") }
739 sub pp_eprotoent { baseop(@_, "endprotoent") }
740 sub pp_eservent { baseop(@_, "endservent") }
741 sub pp_gpwent { baseop(@_, "getpwent") }
742 sub pp_spwent { baseop(@_, "setpwent") }
743 sub pp_epwent { baseop(@_, "endpwent") }
744 sub pp_ggrent { baseop(@_, "getgrent") }
745 sub pp_sgrent { baseop(@_, "setgrent") }
746 sub pp_egrent { baseop(@_, "endgrent") }
747 sub pp_getlogin { baseop(@_, "getlogin") }
751 # I couldn't think of a good short name, but this is the category of
752 # symbolic unary operators with interesting precedence
756 my($op, $cx, $name, $prec, $flags) = (@_, 0);
757 my $kid = $op->first;
758 $kid = $self->deparse($kid, $prec);
759 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
763 sub pp_preinc { pfixop(@_, "++", 23) }
764 sub pp_predec { pfixop(@_, "--", 23) }
765 sub pp_postinc { pfixop(@_, "++", 23, POSTFIX) }
766 sub pp_postdec { pfixop(@_, "--", 23, POSTFIX) }
767 sub pp_i_preinc { pfixop(@_, "++", 23) }
768 sub pp_i_predec { pfixop(@_, "--", 23) }
769 sub pp_i_postinc { pfixop(@_, "++", 23, POSTFIX) }
770 sub pp_i_postdec { pfixop(@_, "--", 23, POSTFIX) }
771 sub pp_complement { pfixop(@_, "~", 21) }
776 if ($op->first->ppaddr =~ /^pp_(i_)?negate$/) {
778 $self->pfixop($op, $cx, "-", 21.5);
780 $self->pfixop($op, $cx, "-", 21);
783 sub pp_i_negate { pp_negate(@_) }
789 $self->pfixop($op, $cx, "not ", 4);
791 $self->pfixop($op, $cx, "!", 21);
798 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
800 if ($op->flags & OPf_KIDS) {
802 return $self->maybe_parens_unop($name, $kid, $cx);
804 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
808 sub pp_chop { unop(@_, "chop") }
809 sub pp_chomp { unop(@_, "chomp") }
810 sub pp_schop { unop(@_, "chop") }
811 sub pp_schomp { unop(@_, "chomp") }
812 sub pp_defined { unop(@_, "defined") }
813 sub pp_undef { unop(@_, "undef") }
814 sub pp_study { unop(@_, "study") }
815 sub pp_ref { unop(@_, "ref") }
816 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
818 sub pp_sin { unop(@_, "sin") }
819 sub pp_cos { unop(@_, "cos") }
820 sub pp_rand { unop(@_, "rand") }
821 sub pp_srand { unop(@_, "srand") }
822 sub pp_exp { unop(@_, "exp") }
823 sub pp_log { unop(@_, "log") }
824 sub pp_sqrt { unop(@_, "sqrt") }
825 sub pp_int { unop(@_, "int") }
826 sub pp_hex { unop(@_, "hex") }
827 sub pp_oct { unop(@_, "oct") }
828 sub pp_abs { unop(@_, "abs") }
830 sub pp_length { unop(@_, "length") }
831 sub pp_ord { unop(@_, "ord") }
832 sub pp_chr { unop(@_, "chr") }
833 sub pp_ucfirst { unop(@_, "ucfirst") }
834 sub pp_lcfirst { unop(@_, "lcfirst") }
835 sub pp_uc { unop(@_, "uc") }
836 sub pp_lc { unop(@_, "lc") }
837 sub pp_quotemeta { unop(@_, "quotemeta") }
839 sub pp_each { unop(@_, "each") }
840 sub pp_values { unop(@_, "values") }
841 sub pp_keys { unop(@_, "keys") }
842 sub pp_pop { unop(@_, "pop") }
843 sub pp_shift { unop(@_, "shift") }
845 sub pp_caller { unop(@_, "caller") }
846 sub pp_reset { unop(@_, "reset") }
847 sub pp_exit { unop(@_, "exit") }
848 sub pp_prototype { unop(@_, "prototype") }
850 sub pp_close { unop(@_, "close") }
851 sub pp_fileno { unop(@_, "fileno") }
852 sub pp_umask { unop(@_, "umask") }
853 sub pp_binmode { unop(@_, "binmode") }
854 sub pp_untie { unop(@_, "untie") }
855 sub pp_tied { unop(@_, "tied") }
856 sub pp_dbmclose { unop(@_, "dbmclose") }
857 sub pp_getc { unop(@_, "getc") }
858 sub pp_eof { unop(@_, "eof") }
859 sub pp_tell { unop(@_, "tell") }
860 sub pp_getsockname { unop(@_, "getsockname") }
861 sub pp_getpeername { unop(@_, "getpeername") }
863 sub pp_chdir { unop(@_, "chdir") }
864 sub pp_chroot { unop(@_, "chroot") }
865 sub pp_readlink { unop(@_, "readlink") }
866 sub pp_rmdir { unop(@_, "rmdir") }
867 sub pp_readdir { unop(@_, "readdir") }
868 sub pp_telldir { unop(@_, "telldir") }
869 sub pp_rewinddir { unop(@_, "rewinddir") }
870 sub pp_closedir { unop(@_, "closedir") }
871 sub pp_getpgrp { unop(@_, "getpgrp") }
872 sub pp_localtime { unop(@_, "localtime") }
873 sub pp_gmtime { unop(@_, "gmtime") }
874 sub pp_alarm { unop(@_, "alarm") }
875 sub pp_sleep { unop(@_, "sleep") }
877 sub pp_dofile { unop(@_, "do") }
878 sub pp_entereval { unop(@_, "eval") }
880 sub pp_ghbyname { unop(@_, "gethostbyname") }
881 sub pp_gnbyname { unop(@_, "getnetbyname") }
882 sub pp_gpbyname { unop(@_, "getprotobyname") }
883 sub pp_shostent { unop(@_, "sethostent") }
884 sub pp_snetent { unop(@_, "setnetent") }
885 sub pp_sprotoent { unop(@_, "setprotoent") }
886 sub pp_sservent { unop(@_, "setservent") }
887 sub pp_gpwnam { unop(@_, "getpwnam") }
888 sub pp_gpwuid { unop(@_, "getpwuid") }
889 sub pp_ggrnam { unop(@_, "getgrnam") }
890 sub pp_ggrgid { unop(@_, "getgrgid") }
892 sub pp_lock { unop(@_, "lock") }
897 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
905 if ($op->private & OPpSLICE) {
906 return $self->maybe_parens_func("delete",
907 $self->pp_hslice($op->first, 16),
910 return $self->maybe_parens_func("delete",
911 $self->pp_helem($op->first, 16),
919 if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const"
920 and $op->first->private & OPpCONST_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];
952 my $kid = $op->first;
953 if ($kid->ppaddr eq "pp_null") {
955 if ($kid->ppaddr eq "pp_anonlist" || $kid->ppaddr eq "pp_anonhash") {
956 my($pre, $post) = @{{"pp_anonlist" => ["[","]"],
957 "pp_anonhash" => ["{","}"]}->{$kid->ppaddr}};
959 $kid = $kid->first->sibling; # skip pushmark
960 for (; !null($kid); $kid = $kid->sibling) {
961 $expr = $self->deparse($kid, 6);
964 return $pre . join(", ", @exprs) . $post;
965 } elsif (!null($kid->sibling) and
966 $kid->sibling->ppaddr eq "pp_anoncode") {
968 $self->deparse_sub($self->padval($kid->sibling->targ));
969 } elsif ($kid->ppaddr eq "pp_pushmark"
970 and $kid->sibling->ppaddr =~ /^pp_(pad|rv2)[ah]v$/
971 and not $kid->sibling->flags & OPf_REF) {
972 # The @a in \(@a) isn't in ref context, but only when the
974 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
977 $self->pfixop($op, $cx, "\\", 20);
980 sub pp_srefgen { pp_refgen(@_) }
985 my $kid = $op->first;
986 $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh>
987 if ($kid->ppaddr eq "pp_rv2gv") {
990 return "<" . $self->deparse($kid, 1) . ">";
995 my ($op, $cx, $name) = @_;
996 if (class($op) eq "PVOP") {
997 return "$name " . $op->pv;
998 } elsif (class($op) eq "OP") {
1000 } elsif (class($op) eq "UNOP") {
1001 # Note -- loop exits are actually exempt from the
1002 # looks-like-a-func rule, but a few extra parens won't hurt
1003 return $self->maybe_parens_unop($name, $op->first, $cx);
1007 sub pp_last { loopex(@_, "last") }
1008 sub pp_next { loopex(@_, "next") }
1009 sub pp_redo { loopex(@_, "redo") }
1010 sub pp_goto { loopex(@_, "goto") }
1011 sub pp_dump { loopex(@_, "dump") }
1015 my($op, $cx, $name) = @_;
1016 if (class($op) eq "UNOP") {
1017 # Genuine `-X' filetests are exempt from the LLAFR, but not
1018 # l?stat(); for the sake of clarity, give'em all parens
1019 return $self->maybe_parens_unop($name, $op->first, $cx);
1020 } elsif (class($op) eq "GVOP") {
1021 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1022 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1027 sub pp_lstat { ftst(@_, "lstat") }
1028 sub pp_stat { ftst(@_, "stat") }
1029 sub pp_ftrread { ftst(@_, "-R") }
1030 sub pp_ftrwrite { ftst(@_, "-W") }
1031 sub pp_ftrexec { ftst(@_, "-X") }
1032 sub pp_fteread { ftst(@_, "-r") }
1033 sub pp_ftewrite { ftst(@_, "-r") }
1034 sub pp_fteexec { ftst(@_, "-r") }
1035 sub pp_ftis { ftst(@_, "-e") }
1036 sub pp_fteowned { ftst(@_, "-O") }
1037 sub pp_ftrowned { ftst(@_, "-o") }
1038 sub pp_ftzero { ftst(@_, "-z") }
1039 sub pp_ftsize { ftst(@_, "-s") }
1040 sub pp_ftmtime { ftst(@_, "-M") }
1041 sub pp_ftatime { ftst(@_, "-A") }
1042 sub pp_ftctime { ftst(@_, "-C") }
1043 sub pp_ftsock { ftst(@_, "-S") }
1044 sub pp_ftchr { ftst(@_, "-c") }
1045 sub pp_ftblk { ftst(@_, "-b") }
1046 sub pp_ftfile { ftst(@_, "-f") }
1047 sub pp_ftdir { ftst(@_, "-d") }
1048 sub pp_ftpipe { ftst(@_, "-p") }
1049 sub pp_ftlink { ftst(@_, "-l") }
1050 sub pp_ftsuid { ftst(@_, "-u") }
1051 sub pp_ftsgid { ftst(@_, "-g") }
1052 sub pp_ftsvtx { ftst(@_, "-k") }
1053 sub pp_fttty { ftst(@_, "-t") }
1054 sub pp_fttext { ftst(@_, "-T") }
1055 sub pp_ftbinary { ftst(@_, "-B") }
1057 sub SWAP_CHILDREN () { 1 }
1058 sub ASSIGN () { 2 } # has OP= variant
1064 my $name = $op->ppaddr;
1065 if ($name eq "pp_concat" and $op->first->ppaddr eq "pp_concat") {
1066 # avoid spurious `=' -- see comment in pp_concat
1069 if ($name eq "pp_null" and class($op) eq "UNOP"
1070 and $op->first->ppaddr =~ /^pp_(and|x?or)$/
1071 and null $op->first->sibling)
1073 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1074 # with a null that's used as the common end point of the two
1075 # flows of control. For precedence purposes, ignore it.
1076 # (COND_EXPRs have these too, but we don't bother with
1077 # their associativity).
1078 return assoc_class($op->first);
1080 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1083 # Left associative operators, like `+', for which
1084 # $a + $b + $c is equivalent to ($a + $b) + $c
1087 %left = ('pp_multiply' => 19, 'pp_i_multiply' => 19,
1088 'pp_divide' => 19, 'pp_i_divide' => 19,
1089 'pp_modulo' => 19, 'pp_i_modulo' => 19,
1091 'pp_add' => 18, 'pp_i_add' => 18,
1092 'pp_subtract' => 18, 'pp_i_subtract' => 18,
1094 'pp_left_shift' => 17, 'pp_right_shift' => 17,
1096 'pp_bit_or' => 12, 'pp_bit_xor' => 12,
1098 'pp_or' => 2, 'pp_xor' => 2,
1102 sub deparse_binop_left {
1104 my($op, $left, $prec) = @_;
1105 if ($left{assoc_class($op)}
1106 and $left{assoc_class($op)} == $left{assoc_class($left)})
1108 return $self->deparse($left, $prec - .00001);
1110 return $self->deparse($left, $prec);
1114 # Right associative operators, like `=', for which
1115 # $a = $b = $c is equivalent to $a = ($b = $c)
1118 %right = ('pp_pow' => 22,
1119 'pp_sassign=' => 7, 'pp_aassign=' => 7,
1120 'pp_multiply=' => 7, 'pp_i_multiply=' => 7,
1121 'pp_divide=' => 7, 'pp_i_divide=' => 7,
1122 'pp_modulo=' => 7, 'pp_i_modulo=' => 7,
1124 'pp_add=' => 7, 'pp_i_add=' => 7,
1125 'pp_subtract=' => 7, 'pp_i_subtract=' => 7,
1127 'pp_left_shift=' => 7, 'pp_right_shift=' => 7,
1129 'pp_bit_or=' => 7, 'pp_bit_xor=' => 7,
1130 'pp_andassign' => 7,
1135 sub deparse_binop_right {
1137 my($op, $right, $prec) = @_;
1138 if ($right{assoc_class($op)}
1139 and $right{assoc_class($op)} == $right{assoc_class($right)})
1141 return $self->deparse($right, $prec - .00001);
1143 return $self->deparse($right, $prec);
1149 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1150 my $left = $op->first;
1151 my $right = $op->last;
1153 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1157 if ($flags & SWAP_CHILDREN) {
1158 ($left, $right) = ($right, $left);
1160 $left = $self->deparse_binop_left($op, $left, $prec);
1161 $right = $self->deparse_binop_right($op, $right, $prec);
1162 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1165 sub pp_add { binop(@_, "+", 18, ASSIGN) }
1166 sub pp_multiply { binop(@_, "*", 19, ASSIGN) }
1167 sub pp_subtract { binop(@_, "-",18, ASSIGN) }
1168 sub pp_divide { binop(@_, "/", 19, ASSIGN) }
1169 sub pp_modulo { binop(@_, "%", 19, ASSIGN) }
1170 sub pp_i_add { binop(@_, "+", 18, ASSIGN) }
1171 sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) }
1172 sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) }
1173 sub pp_i_divide { binop(@_, "/", 19, ASSIGN) }
1174 sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) }
1175 sub pp_pow { binop(@_, "**", 22, ASSIGN) }
1177 sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) }
1178 sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) }
1179 sub pp_bit_and { binop(@_, "&", 13, ASSIGN) }
1180 sub pp_bit_or { binop(@_, "|", 12, ASSIGN) }
1181 sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) }
1183 sub pp_eq { binop(@_, "==", 14) }
1184 sub pp_ne { binop(@_, "!=", 14) }
1185 sub pp_lt { binop(@_, "<", 15) }
1186 sub pp_gt { binop(@_, ">", 15) }
1187 sub pp_ge { binop(@_, ">=", 15) }
1188 sub pp_le { binop(@_, "<=", 15) }
1189 sub pp_ncmp { binop(@_, "<=>", 14) }
1190 sub pp_i_eq { binop(@_, "==", 14) }
1191 sub pp_i_ne { binop(@_, "!=", 14) }
1192 sub pp_i_lt { binop(@_, "<", 15) }
1193 sub pp_i_gt { binop(@_, ">", 15) }
1194 sub pp_i_ge { binop(@_, ">=", 15) }
1195 sub pp_i_le { binop(@_, "<=", 15) }
1196 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1198 sub pp_seq { binop(@_, "eq", 14) }
1199 sub pp_sne { binop(@_, "ne", 14) }
1200 sub pp_slt { binop(@_, "lt", 15) }
1201 sub pp_sgt { binop(@_, "gt", 15) }
1202 sub pp_sge { binop(@_, "ge", 15) }
1203 sub pp_sle { binop(@_, "le", 15) }
1204 sub pp_scmp { binop(@_, "cmp", 14) }
1206 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1207 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1209 # `.' is special because concats-of-concats are optimized to save copying
1210 # by making all but the first concat stacked. The effect is as if the
1211 # programmer had written `($a . $b) .= $c', except legal.
1215 my $left = $op->first;
1216 my $right = $op->last;
1219 if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") {
1223 $left = $self->deparse_binop_left($op, $left, $prec);
1224 $right = $self->deparse_binop_right($op, $right, $prec);
1225 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1228 # `x' is weird when the left arg is a list
1232 my $left = $op->first;
1233 my $right = $op->last;
1236 if ($op->flags & OPf_STACKED) {
1240 if (null($right)) { # list repeat; count is inside left-side ex-list
1241 my $kid = $left->first->sibling; # skip pushmark
1243 for (; !null($kid->sibling); $kid = $kid->sibling) {
1244 push @exprs, $self->deparse($kid, 6);
1247 $left = "(" . join(", ", @exprs). ")";
1249 $left = $self->deparse_binop_left($op, $left, $prec);
1251 $right = $self->deparse_binop_right($op, $right, $prec);
1252 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1257 my ($op, $cx, $type) = @_;
1258 my $left = $op->first;
1259 my $right = $left->sibling;
1260 $left = $self->deparse($left, 9);
1261 $right = $self->deparse($right, 9);
1262 return $self->maybe_parens("$left $type $right", $cx, 9);
1268 my $flip = $op->first;
1269 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1270 return $self->range($flip->first, $cx, $type);
1273 # one-line while/until is handled in pp_leave
1277 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1278 my $left = $op->first;
1279 my $right = $op->first->sibling;
1280 if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
1281 $left = $self->deparse($left, 1);
1282 $right = $self->deparse($right, 0);
1283 return "$blockname ($left) {\n\t$right\n\b}\cK";
1284 } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
1285 $right = $self->deparse($right, 1);
1286 $left = $self->deparse($left, 1);
1287 return "$right $blockname $left";
1288 } elsif ($cx > $lowprec and $highop) { # $a && $b
1289 $left = $self->deparse_binop_left($op, $left, $highprec);
1290 $right = $self->deparse_binop_right($op, $right, $highprec);
1291 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1292 } else { # $a and $b
1293 $left = $self->deparse_binop_left($op, $left, $lowprec);
1294 $right = $self->deparse_binop_right($op, $right, $lowprec);
1295 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1299 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1300 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1301 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1305 my ($op, $cx, $opname) = @_;
1306 my $left = $op->first;
1307 my $right = $op->first->sibling->first; # skip sassign
1308 $left = $self->deparse($left, 7);
1309 $right = $self->deparse($right, 7);
1310 return $self->maybe_parens("$left $opname $right", $cx, 7);
1313 sub pp_andassign { logassignop(@_, "&&=") }
1314 sub pp_orassign { logassignop(@_, "||=") }
1318 my($op, $cx, $name) = @_;
1320 my $parens = ($cx >= 5) || $self->{'parens'};
1321 my $kid = $op->first->sibling;
1322 return $name if null $kid;
1323 my $first = $self->deparse($kid, 6);
1324 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1325 push @exprs, $first;
1326 $kid = $kid->sibling;
1327 for (; !null($kid); $kid = $kid->sibling) {
1328 push @exprs, $self->deparse($kid, 6);
1331 return "$name(" . join(", ", @exprs) . ")";
1333 return "$name " . join(", ", @exprs);
1337 sub pp_bless { listop(@_, "bless") }
1338 sub pp_atan2 { listop(@_, "atan2") }
1339 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1340 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1341 sub pp_index { listop(@_, "index") }
1342 sub pp_rindex { listop(@_, "rindex") }
1343 sub pp_sprintf { listop(@_, "sprintf") }
1344 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1345 sub pp_crypt { listop(@_, "crypt") }
1346 sub pp_unpack { listop(@_, "unpack") }
1347 sub pp_pack { listop(@_, "pack") }
1348 sub pp_join { listop(@_, "join") }
1349 sub pp_splice { listop(@_, "splice") }
1350 sub pp_push { listop(@_, "push") }
1351 sub pp_unshift { listop(@_, "unshift") }
1352 sub pp_reverse { listop(@_, "reverse") }
1353 sub pp_warn { listop(@_, "warn") }
1354 sub pp_die { listop(@_, "die") }
1355 # Actually, return is exempt from the LLAFR (see examples in this very
1356 # module!), but for consistency's sake, ignore that fact
1357 sub pp_return { listop(@_, "return") }
1358 sub pp_open { listop(@_, "open") }
1359 sub pp_pipe_op { listop(@_, "pipe") }
1360 sub pp_tie { listop(@_, "tie") }
1361 sub pp_dbmopen { listop(@_, "dbmopen") }
1362 sub pp_sselect { listop(@_, "select") }
1363 sub pp_select { listop(@_, "select") }
1364 sub pp_read { listop(@_, "read") }
1365 sub pp_sysopen { listop(@_, "sysopen") }
1366 sub pp_sysseek { listop(@_, "sysseek") }
1367 sub pp_sysread { listop(@_, "sysread") }
1368 sub pp_syswrite { listop(@_, "syswrite") }
1369 sub pp_send { listop(@_, "send") }
1370 sub pp_recv { listop(@_, "recv") }
1371 sub pp_seek { listop(@_, "seek") }
1372 sub pp_fcntl { listop(@_, "fcntl") }
1373 sub pp_ioctl { listop(@_, "ioctl") }
1374 sub pp_flock { listop(@_, "flock") }
1375 sub pp_socket { listop(@_, "socket") }
1376 sub pp_sockpair { listop(@_, "sockpair") }
1377 sub pp_bind { listop(@_, "bind") }
1378 sub pp_connect { listop(@_, "connect") }
1379 sub pp_listen { listop(@_, "listen") }
1380 sub pp_accept { listop(@_, "accept") }
1381 sub pp_shutdown { listop(@_, "shutdown") }
1382 sub pp_gsockopt { listop(@_, "getsockopt") }
1383 sub pp_ssockopt { listop(@_, "setsockopt") }
1384 sub pp_chown { listop(@_, "chown") }
1385 sub pp_unlink { listop(@_, "unlink") }
1386 sub pp_chmod { listop(@_, "chmod") }
1387 sub pp_utime { listop(@_, "utime") }
1388 sub pp_rename { listop(@_, "rename") }
1389 sub pp_link { listop(@_, "link") }
1390 sub pp_symlink { listop(@_, "symlink") }
1391 sub pp_mkdir { listop(@_, "mkdir") }
1392 sub pp_open_dir { listop(@_, "opendir") }
1393 sub pp_seekdir { listop(@_, "seekdir") }
1394 sub pp_waitpid { listop(@_, "waitpid") }
1395 sub pp_system { listop(@_, "system") }
1396 sub pp_exec { listop(@_, "exec") }
1397 sub pp_kill { listop(@_, "kill") }
1398 sub pp_setpgrp { listop(@_, "setpgrp") }
1399 sub pp_getpriority { listop(@_, "getpriority") }
1400 sub pp_setpriority { listop(@_, "setpriority") }
1401 sub pp_shmget { listop(@_, "shmget") }
1402 sub pp_shmctl { listop(@_, "shmctl") }
1403 sub pp_shmread { listop(@_, "shmread") }
1404 sub pp_shmwrite { listop(@_, "shmwrite") }
1405 sub pp_msgget { listop(@_, "msgget") }
1406 sub pp_msgctl { listop(@_, "msgctl") }
1407 sub pp_msgsnd { listop(@_, "msgsnd") }
1408 sub pp_msgrcv { listop(@_, "msgrcv") }
1409 sub pp_semget { listop(@_, "semget") }
1410 sub pp_semctl { listop(@_, "semctl") }
1411 sub pp_semop { listop(@_, "semop") }
1412 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1413 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1414 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1415 sub pp_gsbyname { listop(@_, "getservbyname") }
1416 sub pp_gsbyport { listop(@_, "getservbyport") }
1417 sub pp_syscall { listop(@_, "syscall") }
1422 my $text = $self->dq($op->first->sibling); # skip pushmark
1423 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1424 or $text =~ /[<>]/) {
1425 return 'glob(' . single_delim('qq', '"', $text) . ')';
1427 return '<' . $text . '>';
1431 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1432 # be a filehandle. This could probably be better fixed in the core
1433 # by moving the GV lookup into ck_truc.
1439 my $parens = ($cx >= 5) || $self->{'parens'};
1440 my $kid = $op->first->sibling;
1442 if ($op->flags & OPf_SPECIAL) {
1443 # $kid is an OP_CONST
1446 $fh = $self->deparse($kid, 6);
1447 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1449 my $len = $self->deparse($kid->sibling, 6);
1451 return "truncate($fh, $len)";
1453 return "truncate $fh, $len";
1460 my($op, $cx, $name) = @_;
1462 my $kid = $op->first->sibling;
1464 if ($op->flags & OPf_STACKED) {
1466 $indir = $indir->first; # skip rv2gv
1467 if (is_scope($indir)) {
1468 $indir = "{" . $self->deparse($indir, 0) . "}";
1470 $indir = $self->deparse($indir, 24);
1472 $indir = $indir . " ";
1473 $kid = $kid->sibling;
1475 for (; !null($kid); $kid = $kid->sibling) {
1476 $expr = $self->deparse($kid, 6);
1479 return $self->maybe_parens_func($name,
1480 $indir . join(", ", @exprs),
1484 sub pp_prtf { indirop(@_, "printf") }
1485 sub pp_print { indirop(@_, "print") }
1486 sub pp_sort { indirop(@_, "sort") }
1490 my($op, $cx, $name) = @_;
1492 my $kid = $op->first; # this is the (map|grep)start
1493 $kid = $kid->first->sibling; # skip a pushmark
1494 my $code = $kid->first; # skip a null
1495 if (is_scope $code) {
1496 $code = "{" . $self->deparse($code, 1) . "} ";
1498 $code = $self->deparse($code, 24) . ", ";
1500 $kid = $kid->sibling;
1501 for (; !null($kid); $kid = $kid->sibling) {
1502 $expr = $self->deparse($kid, 6);
1503 push @exprs, $expr if $expr;
1505 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1508 sub pp_mapwhile { mapop(@_, "map") }
1509 sub pp_grepwhile { mapop(@_, "grep") }
1515 my $kid = $op->first->sibling; # skip pushmark
1517 my $local = "either"; # could be local(...) or my(...)
1518 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1519 # This assumes that no other private flags equal 128, and that
1520 # OPs that store things other than flags in their op_private,
1521 # like OP_AELEMFAST, won't be immediate children of a list.
1522 unless ($lop->private & OPpLVAL_INTRO or $lop->ppaddr eq "pp_undef")
1524 $local = ""; # or not
1527 if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my()
1528 ($local = "", last) if $local eq "local";
1530 } elsif ($lop->ppaddr ne "pp_undef") { # local()
1531 ($local = "", last) if $local eq "my";
1535 $local = "" if $local eq "either"; # no point if it's all undefs
1536 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
1537 for (; !null($kid); $kid = $kid->sibling) {
1539 if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") {
1544 $self->{'avoid_local'}{$$lop}++;
1545 $expr = $self->deparse($kid, 6);
1546 delete $self->{'avoid_local'}{$$lop};
1548 $expr = $self->deparse($kid, 6);
1553 return "$local(" . join(", ", @exprs) . ")";
1555 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1562 my $cond = $op->first;
1563 my $true = $cond->sibling;
1564 my $false = $true->sibling;
1565 my $cuddle = $self->{'cuddle'};
1566 unless ($cx == 0 and is_scope($true) and is_scope($false)) {
1567 $cond = $self->deparse($cond, 8);
1568 $true = $self->deparse($true, 8);
1569 $false = $self->deparse($false, 8);
1570 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1572 $cond = $self->deparse($cond, 1);
1573 $true = $self->deparse($true, 0);
1574 if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif
1575 my $head = "if ($cond) {\n\t$true\n\b}";
1577 while (!null($false) and $false->ppaddr eq "pp_lineseq") {
1578 my $newop = $false->first->sibling->first;
1579 my $newcond = $newop->first;
1580 my $newtrue = $newcond->sibling;
1581 $false = $newtrue->sibling; # last in chain is OP_AND => no else
1582 $newcond = $self->deparse($newcond, 1);
1583 $newtrue = $self->deparse($newtrue, 0);
1584 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1586 if (!null($false)) {
1587 $false = $cuddle . "else {\n\t" .
1588 $self->deparse($false, 0) . "\n\b}\cK";
1592 return $head . join($cuddle, "", @elsifs) . $false;
1594 $false = $self->deparse($false, 0);
1595 return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
1601 my $enter = $op->first;
1602 my $kid = $enter->sibling;
1603 local($self->{'curstash'}) = $self->{'curstash'};
1606 if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop
1607 if (is_state $kid->last) { # infinite
1608 $head = "for (;;) "; # shorter than while (1)
1612 } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach
1613 my $ary = $enter->first->sibling; # first was pushmark
1614 my $var = $ary->sibling;
1615 if ($enter->flags & OPf_STACKED
1616 and not null $ary->first->sibling->sibling)
1618 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1619 $self->deparse($ary->first->sibling->sibling, 9);
1621 $ary = $self->deparse($ary, 1);
1624 if ($enter->flags & OPf_SPECIAL) { # thread special var
1625 $var = $self->pp_threadsv($enter, 1);
1626 } else { # regular my() variable
1627 $var = $self->pp_padsv($enter, 1);
1628 if ($self->padname_sv($enter->targ)->IVX ==
1629 $kid->first->first->sibling->last->cop_seq)
1631 # If the scope of this variable closes at the last
1632 # statement of the loop, it must have been
1634 $var = "my " . $var;
1637 } elsif ($var->ppaddr eq "pp_rv2gv") {
1638 $var = $self->pp_rv2sv($var, 1);
1639 } elsif ($var->ppaddr eq "pp_gv") {
1640 $var = "\$" . $self->deparse($var, 1);
1642 $head = "foreach $var ($ary) ";
1643 $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1644 } elsif ($kid->ppaddr eq "pp_null") { # while/until
1646 my $name = {"pp_and" => "while", "pp_or" => "until"}
1648 $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
1649 $kid = $kid->first->sibling;
1650 } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty
1651 return "{;}"; # {} could be a hashref
1653 # The third-to-last kid is the continue block if the pointer used
1654 # by `next BLOCK' points to its first OP, which happens to be the
1655 # the op_next of the head of the _previous_ statement.
1656 # Unless it's a bare loop, in which case it's last, since there's
1657 # no unstack or extra nextstate.
1658 # Except if the previous head isn't null but the first kid is
1659 # (because it's a nulled out nextstate in a scope), in which
1660 # case the head's next is advanced past the null but the nextop's
1661 # isn't, so we need to try nextop->next.
1662 my($cont, $precont);
1664 $cont = $kid->first;
1665 while (!null($cont->sibling)) {
1667 $cont = $cont->sibling;
1670 $cont = $kid->first;
1671 while (!null($cont->sibling->sibling->sibling)) {
1673 $cont = $cont->sibling;
1676 if ($precont and $ {$precont->next} == $ {$enter->nextop}
1677 || $ {$precont->next} == $ {$enter->nextop->next} )
1679 my $state = $kid->first;
1680 my $cuddle = $self->{'cuddle'};
1682 for (; $$state != $$cont; $state = $state->sibling) {
1684 if (is_state $state) {
1685 $expr = $self->deparse($state, 0);
1686 $state = $state->sibling;
1689 $expr .= $self->deparse($state, 0);
1690 push @exprs, $expr if $expr;
1692 $kid = join(";\n", @exprs);
1693 $cont = $cuddle . "continue {\n\t" .
1694 $self->deparse($cont, 0) . "\n\b}\cK";
1697 $kid = $self->deparse($kid, 0);
1699 return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1704 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1707 my $OP_CONST = opnumber("const");
1708 my $OP_STRINGIFY = opnumber("stringify");
1710 # XXX need a better way to do this
1714 if (class($op) eq "OP") {
1715 return "'???'" if $op->targ == $OP_CONST; # old value is lost
1716 } elsif ($op->first->ppaddr eq "pp_pushmark") {
1717 return $self->pp_list($op, $cx);
1718 } elsif ($op->first->ppaddr eq "pp_enter") {
1719 return $self->pp_leave($op, $cx);
1720 } elsif ($op->targ == $OP_STRINGIFY) {
1721 return $self->dquote($op);
1722 } elsif (!null($op->first->sibling) and
1723 $op->first->sibling->ppaddr eq "pp_readline" and
1724 $op->first->sibling->flags & OPf_STACKED) {
1725 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1726 . $self->deparse($op->first->sibling, 7),
1728 } elsif (!null($op->first->sibling) and
1729 $op->first->sibling->ppaddr eq "pp_trans" and
1730 $op->first->sibling->flags & OPf_STACKED) {
1731 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1732 . $self->deparse($op->first->sibling, 20),
1735 return $self->deparse($op->first, $cx);
1742 my $str = $self->padname_sv($targ)->PV;
1743 return padname_fix($str);
1749 return substr($self->padname($op->targ), 1); # skip $/@/%
1755 return $self->maybe_my($op, $cx, $self->padname($op->targ));
1758 sub pp_padav { pp_padsv(@_) }
1759 sub pp_padhv { pp_padsv(@_) }
1764 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1765 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1766 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1773 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
1779 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
1785 return $self->gv_name($op->gv);
1792 return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1797 my($op, $cx, $type) = @_;
1798 my $kid = $op->first;
1799 my $str = $self->deparse($kid, 0);
1800 return $type . (is_scalar($kid) ? $str : "{$str}");
1803 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1804 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1805 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1811 if ($op->first->ppaddr eq "pp_padav") {
1812 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1814 return $self->maybe_local($op, $cx,
1815 $self->rv2x($op->first, $cx, '$#'));
1819 # skip down to the old, ex-rv2cv
1820 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
1825 my $kid = $op->first;
1826 if ($kid->ppaddr eq "pp_const") { # constant list
1828 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1830 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
1837 my ($op, $cx, $left, $right, $padname) = @_;
1838 my($array, $idx) = ($op->first, $op->first->sibling);
1839 unless ($array->ppaddr eq $padname) { # Maybe this has been fixed
1840 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1842 if ($array->ppaddr eq $padname) {
1843 $array = $self->padany($array);
1844 } elsif (is_scope($array)) { # ${expr}[0]
1845 $array = "{" . $self->deparse($array, 0) . "}";
1846 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
1847 $array = $self->deparse($array, 24);
1849 # $x[20][3]{hi} or expr->[20]
1851 $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/;
1852 return $self->deparse($array, 24) . $arrow .
1853 $left . $self->deparse($idx, 1) . $right;
1855 $idx = $self->deparse($idx, 1);
1856 return "\$" . $array . $left . $idx . $right;
1859 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) }
1860 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) }
1865 my($glob, $part) = ($op->first, $op->last);
1866 $glob = $glob->first; # skip rv2gv
1867 $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug
1868 my $scope = is_scope($glob);
1869 $glob = $self->deparse($glob, 0);
1870 $part = $self->deparse($part, 1);
1871 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
1876 my ($op, $cx, $left, $right, $regname, $padname) = @_;
1878 my(@elems, $kid, $array, $list);
1879 if (class($op) eq "LISTOP") {
1881 } else { # ex-hslice inside delete()
1882 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
1886 $array = $array->first
1887 if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null";
1888 if (is_scope($array)) {
1889 $array = "{" . $self->deparse($array, 0) . "}";
1890 } elsif ($array->ppaddr eq $padname) {
1891 $array = $self->padany($array);
1893 $array = $self->deparse($array, 24);
1895 $kid = $op->first->sibling; # skip pushmark
1896 if ($kid->ppaddr eq "pp_list") {
1897 $kid = $kid->first->sibling; # skip list, pushmark
1898 for (; !null $kid; $kid = $kid->sibling) {
1899 push @elems, $self->deparse($kid, 6);
1901 $list = join(", ", @elems);
1903 $list = $self->deparse($kid, 1);
1905 return "\@" . $array . $left . $list . $right;
1908 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]",
1909 "pp_rv2av", "pp_padav")) }
1910 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
1911 "pp_rv2hv", "pp_padhv")) }
1916 my $idx = $op->first;
1917 my $list = $op->last;
1919 $list = $self->deparse($list, 1);
1920 $idx = $self->deparse($idx, 1);
1921 return "($list)" . "[$idx]";
1926 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
1936 my($kid, $args, @exprs);
1937 if (not null $op->first->sibling) { # method
1938 $kid = $op->first->sibling; # skip pushmark
1939 my $obj = $self->deparse($kid, 24);
1940 $kid = $kid->sibling;
1941 for (; not null $kid->sibling; $kid = $kid->sibling) {
1942 push @exprs, $self->deparse($kid, 6);
1944 my $meth = $kid->first;
1945 if ($meth->ppaddr eq "pp_const") {
1946 $meth = $meth->sv->PV; # needs to be bare
1948 $meth = $self->deparse($meth, 1);
1950 $args = join(", ", @exprs);
1951 $kid = $obj . "->" . $meth;
1953 return $kid . "(" . $args . ")"; # parens mandatory
1955 return $kid; # toke.c fakes parens
1958 # else, not a method
1959 if ($op->flags & OPf_SPECIAL) {
1961 } elsif ($op->private & OPpENTERSUB_AMPER) {
1965 $kid = $kid->first->sibling; # skip ex-list, pushmark
1966 for (; not null $kid->sibling; $kid = $kid->sibling) {
1969 if (is_scope($kid)) {
1971 $kid = "{" . $self->deparse($kid, 0) . "}";
1972 } elsif ($kid->first->ppaddr eq "pp_gv") {
1973 my $gv = $kid->first->gv;
1974 if (class($gv->CV) ne "SPECIAL") {
1975 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
1978 $kid = $self->deparse($kid, 24);
1979 } elsif (is_scalar $kid->first) {
1981 $kid = $self->deparse($kid, 24);
1984 $kid = $self->deparse($kid, 24) . "->";
1986 if (defined $proto and not $amper) {
1992 $p =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
1994 $p =~ s/^ *([\\]?[\$\@&%*]|;)//;
1997 undef $proto if @args;
1998 } elsif ($chr eq ";") {
2000 } elsif ($chr eq "@" or $chr eq "%") {
2001 push @reals, map($self->deparse($_, 6), @args);
2007 if (want_scalar $arg) {
2008 push @reals, $self->deparse($arg, 6);
2012 } elsif ($chr eq "&") {
2013 if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
2014 push @reals, $self->deparse($arg, 6);
2018 } elsif ($chr eq "*") {
2019 if ($arg->ppaddr =~ /^pp_s?refgen$/
2020 and $arg->first->first->ppaddr eq "pp_rv2gv")
2022 $real = $arg->first->first; # skip refgen, null
2023 if ($real->first->ppaddr eq "pp_gv") {
2024 push @reals, $self->deparse($real, 6);
2026 push @reals, $self->deparse($real->first, 6);
2031 } elsif (substr($chr, 0, 1) eq "\\") {
2032 $chr = substr($chr, 1);
2033 if ($arg->ppaddr =~ /^pp_s?refgen$/ and
2034 !null($real = $arg->first) and
2035 ($chr eq "\$" && is_scalar($real->first)
2037 && $real->first->sibling->ppaddr
2038 =~ /^pp_(rv2|pad)av$/)
2040 && $real->first->sibling->ppaddr
2041 =~ /^pp_(rv2|pad)hv$/)
2042 #or ($chr eq "&" # This doesn't work
2043 # && $real->first->ppaddr eq "pp_rv2cv")
2045 && $real->first->ppaddr eq "pp_rv2gv")))
2047 push @reals, $self->deparse($real, 6);
2054 undef $proto if $p and !$doneok;
2055 undef $proto if @args;
2056 $args = join(", ", @reals);
2058 unless (defined $proto) {
2060 $args = join(", ", map($self->deparse($_, 6), @exprs));
2063 $args = join(", ", map($self->deparse($_, 6), @exprs));
2065 if ($prefix or $amper) {
2066 if ($op->flags & OPf_STACKED) {
2067 return $prefix . $amper . $kid . "(" . $args . ")";
2069 return $prefix . $amper. $kid;
2072 if (defined $proto and $proto eq "") {
2074 } elsif ($proto eq "\$") {
2075 return $self->maybe_parens_func($kid, $args, $cx, 16);
2076 } elsif ($proto or $simple) {
2077 return $self->maybe_parens_func($kid, $args, $cx, 5);
2079 return "$kid(" . $args . ")";
2084 sub pp_enterwrite { unop(@_, "write") }
2086 # escape things that cause interpolation in double quotes,
2087 # but not character escapes
2090 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2094 # the same, but treat $|, $), and $ at the end of the string differently
2097 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2098 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2102 # character escapes, but not delimiters that might need to be escaped
2103 sub escape_str { # ASCII
2106 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2112 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2113 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2117 # Don't do this for regexen
2120 $str =~ s/\\/\\\\/g;
2124 sub balanced_delim {
2126 my @str = split //, $str;
2127 my($ar, $open, $close, $fail, $c, $cnt);
2128 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2129 ($open, $close) = @$ar;
2130 $fail = 0; $cnt = 0;
2134 } elsif ($c eq $close) {
2142 $fail = 1 if $cnt != 0;
2143 return ($open, "$open$str$close") if not $fail;
2149 my($q, $default, $str) = @_;
2150 return "$default$str$default" if $default and index($str, $default) == -1;
2151 my($succeed, $delim);
2152 ($succeed, $str) = balanced_delim($str);
2153 return "$q$str" if $succeed;
2154 for $delim ('/', '"', '#') {
2155 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2158 $str =~ s/$default/\\$default/g;
2159 return "$default$str$default";
2169 if (class($sv) eq "SPECIAL") {
2170 return ('undef', '1', '0')[$$sv-1];
2171 } elsif ($sv->FLAGS & SVf_IOK) {
2173 } elsif ($sv->FLAGS & SVf_NOK) {
2175 } elsif ($sv->FLAGS & SVf_ROK) {
2176 return "\\(" . const($sv->RV) . ")"; # constant folded
2179 if ($str =~ /[^ -~]/) { # ASCII
2180 return single_delim("qq", '"', uninterp escape_str unback $str);
2182 $str =~ s/\\/\\\\/g;
2183 return single_delim("q", "'", $str);
2191 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2192 # return $op->sv->PV;
2194 return const($op->sv);
2200 my $type = $op->ppaddr;
2201 if ($type eq "pp_const") {
2202 return uninterp(escape_str(unback($op->sv->PV)));
2203 } elsif ($type eq "pp_concat") {
2204 return $self->dq($op->first) . $self->dq($op->last);
2205 } elsif ($type eq "pp_uc") {
2206 return '\U' . $self->dq($op->first->sibling) . '\E';
2207 } elsif ($type eq "pp_lc") {
2208 return '\L' . $self->dq($op->first->sibling) . '\E';
2209 } elsif ($type eq "pp_ucfirst") {
2210 return '\u' . $self->dq($op->first->sibling);
2211 } elsif ($type eq "pp_lcfirst") {
2212 return '\l' . $self->dq($op->first->sibling);
2213 } elsif ($type eq "pp_quotemeta") {
2214 return '\Q' . $self->dq($op->first->sibling) . '\E';
2215 } elsif ($type eq "pp_join") {
2216 return $self->deparse($op->last, 26); # was join($", @ary)
2218 return $self->deparse($op, 26);
2226 return single_delim("qx", '`', $self->dq($op->first->sibling));
2232 # skip ex-stringify, pushmark
2233 return single_delim("qq", '"', $self->dq($op->first->sibling));
2236 # OP_STRINGIFY is a listop, but it only ever has one arg (?)
2237 sub pp_stringify { dquote(@_) }
2239 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2240 # note that tr(from)/to/ is OK, but not tr/from/(to)
2242 my($from, $to) = @_;
2243 my($succeed, $delim);
2244 if ($from !~ m[/] and $to !~ m[/]) {
2245 return "/$from/$to/";
2246 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2247 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2250 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2251 return "$from$delim$to$delim" if index($to, $delim) == -1;
2254 return "$from/$to/";
2257 for $delim ('/', '"', '#') { # note no '
2258 return "$delim$from$delim$to$delim"
2259 if index($to . $from, $delim) == -1;
2261 $from =~ s[/][\\/]g;
2263 return "/$from/$to/";
2269 if ($n == ord '\\') {
2271 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2273 } elsif ($n == ord "\a") {
2275 } elsif ($n == ord "\b") {
2277 } elsif ($n == ord "\t") {
2279 } elsif ($n == ord "\n") {
2281 } elsif ($n == ord "\e") {
2283 } elsif ($n == ord "\f") {
2285 } elsif ($n == ord "\r") {
2287 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2288 return '\\c' . chr(ord("@") + $n);
2290 # return '\x' . sprintf("%02x", $n);
2291 return '\\' . sprintf("%03o", $n);
2298 for ($c = 0; $c < @chars; $c++) {
2301 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2302 $chars[$c + 2] == $tr + 2)
2304 for (; $c <= $#chars and $chars[$c + 1] == $chars[$c] + 1; $c++) {}
2306 $str .= pchr($chars[$c]);
2315 my(@table) = unpack("s256", $op->pv);
2316 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2317 if ($table[ord "-"] != -1 and
2318 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2320 $tr = $table[ord "-"];
2321 $table[ord "-"] = -1;
2325 } else { # -2 ==> delete
2329 for ($c = 0; $c < 256; $c++) {
2332 push @from, $c; push @to, $tr;
2333 } elsif ($tr == -2) {
2338 @from = (@from, @delfrom);
2339 if ($op->private & OPpTRANS_COMPLEMENT) {
2343 @from{@from} = (1) x @from;
2344 for ($c = 0; $c < 256; $c++) {
2345 push @newfrom, $c unless $from{$c};
2349 if ($op->private & OPpTRANS_DELETE) {
2352 pop @to while $#to and $to[$#to] == $to[$#to -1];
2354 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2356 $from = collapse(@from);
2357 $to = collapse(@to);
2358 $from .= "-" if $delhyphen;
2359 return "tr" . double_delim($from, $to) . $flags;
2362 # Like dq(), but different
2366 my $type = $op->ppaddr;
2367 if ($type eq "pp_const") {
2368 return uninterp($op->sv->PV);
2369 } elsif ($type eq "pp_concat") {
2370 return $self->re_dq($op->first) . $self->re_dq($op->last);
2371 } elsif ($type eq "pp_uc") {
2372 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2373 } elsif ($type eq "pp_lc") {
2374 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2375 } elsif ($type eq "pp_ucfirst") {
2376 return '\u' . $self->re_dq($op->first->sibling);
2377 } elsif ($type eq "pp_lcfirst") {
2378 return '\l' . $self->re_dq($op->first->sibling);
2379 } elsif ($type eq "pp_quotemeta") {
2380 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2381 } elsif ($type eq "pp_join") {
2382 return $self->deparse($op->last, 26); # was join($", @ary)
2384 return $self->deparse($op, 26);
2391 my $kid = $op->first;
2392 $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe";
2393 $kid = $kid->first if $kid->ppaddr eq "pp_regcreset";
2394 return $self->re_dq($kid);
2398 # osmic acid -- see osmium tetroxide
2401 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2402 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2403 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2407 my($op, $cx, $name, $delim) = @_;
2408 my $kid = $op->first;
2409 my ($binop, $var, $re) = ("", "", "");
2410 if ($op->flags & OPf_STACKED) {
2412 $var = $self->deparse($kid, 20);
2413 $kid = $kid->sibling;
2416 $re = re_uninterp(escape_str($op->precomp));
2418 $re = $self->deparse($kid, 1);
2421 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2422 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2423 $flags .= "i" if $op->pmflags & PMf_FOLD;
2424 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2425 $flags .= "o" if $op->pmflags & PMf_KEEP;
2426 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2427 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2428 $flags = $matchwords{$flags} if $matchwords{$flags};
2429 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2433 $re = single_delim($name, $delim, $re);
2437 return $self->maybe_parens("$var =~ $re", $cx, 20);
2443 sub pp_match { matchop(@_, "m", "/") }
2444 sub pp_pushre { matchop(@_, "m", "/") }
2445 sub pp_qr { matchop(@_, "qr", "") }
2450 my($kid, @exprs, $ary, $expr);
2452 if ($ {$kid->pmreplroot}) {
2453 $ary = '@' . $self->gv_name($kid->pmreplroot);
2455 for (; !null($kid); $kid = $kid->sibling) {
2456 push @exprs, $self->deparse($kid, 6);
2458 $expr = "split(" . join(", ", @exprs) . ")";
2460 return $self->maybe_parens("$ary = $expr", $cx, 7);
2466 # oxime -- any of various compounds obtained chiefly by the action of
2467 # hydroxylamine on aldehydes and ketones and characterized by the
2468 # bivalent grouping C=NOH [Webster's Tenth]
2471 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2472 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2473 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2474 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2479 my $kid = $op->first;
2480 my($binop, $var, $re, $repl) = ("", "", "", "");
2481 if ($op->flags & OPf_STACKED) {
2483 $var = $self->deparse($kid, 20);
2484 $kid = $kid->sibling;
2487 if (null($op->pmreplroot)) {
2488 $repl = $self->dq($kid);
2489 $kid = $kid->sibling;
2491 $repl = $op->pmreplroot->first; # skip substcont
2492 while ($repl->ppaddr eq "pp_entereval") {
2493 $repl = $repl->first;
2496 $repl = $self->dq($repl);
2499 $re = re_uninterp(escape_str($op->precomp));
2501 $re = $self->deparse($kid, 1);
2503 $flags .= "e" if $op->pmflags & PMf_EVAL;
2504 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2505 $flags .= "i" if $op->pmflags & PMf_FOLD;
2506 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2507 $flags .= "o" if $op->pmflags & PMf_KEEP;
2508 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2509 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2510 $flags = $substwords{$flags} if $substwords{$flags};
2512 return $self->maybe_parens("$var =~ s"
2513 . double_delim($re, $repl) . $flags,
2516 return "s". double_delim($re, $repl) . $flags;
2525 B::Deparse - Perl compiler backend to produce perl code
2529 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-l>][B<,-s>I<LETTERS>] I<prog.pl>
2533 B::Deparse is a backend module for the Perl compiler that generates
2534 perl source code, based on the internal compiled structure that perl
2535 itself creates after parsing a program. The output of B::Deparse won't
2536 be exactly the same as the original source, since perl doesn't keep
2537 track of comments or whitespace, and there isn't a one-to-one
2538 correspondence between perl's syntactical constructions and their
2539 compiled form, but it will often be close. When you use the B<-p>
2540 option, the output also includes parentheses even when they are not
2541 required by precedence, which can make it easy to see if perl is
2542 parsing your expressions the way you intended.
2544 Please note that this module is mainly new and untested code and is
2545 still under development, so it may change in the future.
2549 As with all compiler backend options, these must follow directly after
2550 the '-MO=Deparse', separated by a comma but not any white space.
2556 Print extra parentheses. Without this option, B::Deparse includes
2557 parentheses in its output only when they are needed, based on the
2558 structure of your program. With B<-p>, it uses parentheses (almost)
2559 whenever they would be legal. This can be useful if you are used to
2560 LISP, or if you want to see how perl parses your input. If you say
2562 if ($var & 0x7f == 65) {print "Gimme an A!"}
2563 print ($which ? $a : $b), "\n";
2564 $name = $ENV{USER} or "Bob";
2566 C<B::Deparse,-p> will print
2569 print('Gimme an A!')
2571 (print(($which ? $a : $b)), '???');
2572 (($name = $ENV{'USER'}) or '???')
2574 which probably isn't what you intended (the C<'???'> is a sign that
2575 perl optimized away a constant value).
2577 =item B<-u>I<PACKAGE>
2579 Normally, B::Deparse deparses the main code of a program, all the subs
2580 called by the main program (and all the subs called by them,
2581 recursively), and any other subs in the main:: package. To include
2582 subs in other packages that aren't called directly, such as AUTOLOAD,
2583 DESTROY, other subs called automatically by perl, and methods, which
2584 aren't resolved to subs until runtime, use the B<-u> option. The
2585 argument to B<-u> is the name of a package, and should follow directly
2586 after the 'u'. Multiple B<-u> options may be given, separated by
2587 commas. Note that unlike some other backends, B::Deparse doesn't
2588 (yet) try to guess automatically when B<-u> is needed -- you must
2593 Add '#line' declarations to the output based on the line and file
2594 locations of the original code.
2596 =item B<-s>I<LETTERS>
2598 Tweak the style of B::Deparse's output. At the moment, only one style
2599 option is implemented:
2605 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2622 The default is not to cuddle.
2630 See the 'to do' list at the beginning of the module file.
2634 Stephen McCamant <alias@mcs.com>, based on an earlier version by
2635 Malcolm Beattie <mbeattie@sable.ox.ac.uk>.