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
35 # - {} around variables in strings ("${var}letters")
36 # - associativity of &&=, ||=, ?:
37 # - ',' => '=>' (auto-unquote?)
38 # - break long lines ("\r" as discretionary break?)
39 # - version using op_next instead of op_first/sibling?
40 # - avoid string copies (pass arrays, one big join?)
42 # - while{} with one-statement continue => for(; XXX; XXX) {}?
43 # - -uPackage:: descend recursively?
47 # Object fields (were globals):
50 # (local($a), local($b)) and local($a, $b) have the same internal
51 # representation but the short form looks better. We notice we can
52 # use a large-scale local when checking the list, but need to prevent
53 # individual locals too. This hash holds the addresses of OPs that
54 # have already had their local-ness accounted for. The same thing
58 # CV for current sub (or main program) being deparsed
61 # name of the current package for deparsed code
64 # array of [cop_seq, GV, is_format?] for subs and formats we still
67 # subs_done, forms_done:
68 # keys are addresses of GVs for subs and formats we've already
69 # deparsed (or at least put into subs_todo)
72 # cuddle: ` ' or `\n', depending on -sC
74 # A little explanation of how precedence contexts and associativity
77 # deparse() calls each per-op subroutine with an argument $cx (short
78 # for context, but not the same as the cx* in the perl core), which is
79 # a number describing the op's parents in terms of precedence, whether
80 # they're inside and expression or at statement level, etc. (see
81 # chart below). When ops with children call deparse on them, they pass
82 # along their precedence. Fractional values are used to implement
83 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
84 # parentheses hacks. The major disadvantage of this scheme is that
85 # it doesn't know about right sides and left sides, so say if you
86 # assign a listop to a variable, it can't tell it's allowed to leave
87 # the parens off the listop.
90 # 26 [TODO] inside interpolation context ("")
91 # 25 left terms and list operators (leftward)
95 # 21 right ! ~ \ and unary + and -
100 # 16 nonassoc named unary operators
101 # 15 nonassoc < > <= >= lt gt le ge
102 # 14 nonassoc == != <=> eq ne cmp
109 # 7 right = += -= *= etc.
111 # 5 nonassoc list operators (rightward)
115 # 1 statement modifiers
118 # Nonprinting characters with special meaning:
119 # \cS - steal parens (see maybe_parens_unop)
120 # \n - newline and indent
121 # \t - increase indent
122 # \b - decrease indent (`outdent')
123 # \cK - kill following semicolon, if any
127 return class($op) eq "NULL";
132 my($gv, $cv, $is_form) = @_;
134 if (!null($cv->START) and is_state($cv->START)) {
135 $seq = $cv->START->cop_seq;
139 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
144 my $ent = shift @{$self->{'subs_todo'}};
145 my $name = $self->gv_name($ent->[1]);
147 return "format $name =\n"
148 . $self->deparse_format($ent->[1]->FORM). "\n";
150 return "sub $name " .
151 $self->deparse_sub($ent->[1]->CV);
155 sub OPf_KIDS () { 4 }
160 if ($op->flags & OPf_KIDS) {
162 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
163 walk_tree($kid, $sub);
172 $op = shift if null $op;
173 return if !$op or null $op;
176 if ($op->ppaddr eq "pp_gv") {
177 if ($op->next->ppaddr eq "pp_entersub") {
178 next if $self->{'subs_done'}{$ {$op->gv}}++;
179 next if class($op->gv->CV) eq "SPECIAL";
180 $self->todo($op->gv, $op->gv->CV, 0);
181 $self->walk_sub($op->gv->CV);
182 } elsif ($op->next->ppaddr eq "pp_enterwrite"
183 or ($op->next->ppaddr eq "pp_rv2gv"
184 and $op->next->next->ppaddr eq "pp_enterwrite")) {
185 next if $self->{'forms_done'}{$ {$op->gv}}++;
186 next if class($op->gv->FORM) eq "SPECIAL";
187 $self->todo($op->gv, $op->gv->FORM, 1);
188 $self->walk_sub($op->gv->FORM);
198 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
200 while (($key, $val) = each %stash) {
201 next unless class($val) eq "GV";
202 if (class($val->CV) ne "SPECIAL") {
203 next if $self->{'subs_done'}{$$val}++;
204 $self->todo($val, $val->CV, 0);
205 $self->walk_sub($val->CV);
207 if (class($val->FORM) ne "SPECIAL") {
208 next if $self->{'forms_done'}{$$val}++;
209 $self->todo($val, $val->FORM, 1);
210 $self->walk_sub($val->FORM);
219 while (length($opt = substr($opts, 0, 1))) {
221 $self->{'cuddle'} = " ";
223 $opts = substr($opts, 1);
232 $self->{'subs_todo'} = [];
233 $self->stash_subs("main");
234 $self->{'curcv'} = main_cv;
235 $self->{'curstash'} = "main";
236 $self->{'cuddle'} = "\n";
237 while ($arg = shift @args) {
238 if (substr($arg, 0, 2) eq "-u") {
239 $self->stash_subs(substr($arg, 2));
240 } elsif ($arg eq "-p") {
241 $self->{'parens'} = 1;
242 } elsif (substr($arg, 0, 2) eq "-s") {
243 $self->style_opts(substr $arg, 2);
246 $self->walk_sub(main_cv, main_start);
247 @{$self->{'subs_todo'}} =
248 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
249 print indent($self->deparse(main_root, 0)), "\n" unless null main_root;
251 while (scalar(@{$self->{'subs_todo'}})) {
252 push @text, $self->next_todo;
254 print indent(join("", @text)), "\n" if @text;
261 # cluck if class($op) eq "NULL";
262 my $meth = $op->ppaddr;
263 return $self->$meth($op, $cx);
268 my @lines = split(/\n/, $txt);
272 if (substr($line, 0, 1) eq "\t") {
273 $leader = $leader . " ";
274 $line = substr($line, 1);
275 } elsif (substr($line, 0, 1) eq "\b") {
276 $leader = substr($leader, 0, length($leader) - 4);
277 $line = substr($line, 1);
280 $line = $leader . $line;
282 return join("\n", @lines);
285 sub SVf_POK () {0x40000}
291 if ($cv->FLAGS & SVf_POK) {
292 $proto = "(". $cv->PV . ") ";
294 local($self->{'curcv'}) = $cv;
295 local($self->{'curstash'}) = $self->{'curstash'};
296 if (not null $cv->ROOT) {
298 return $proto . "{\n\t" .
299 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
301 return $proto . "{}\n";
309 local($self->{'curcv'}) = $form;
310 local($self->{'curstash'}) = $self->{'curstash'};
311 my $op = $form->ROOT;
313 $op = $op->first->first; # skip leavewrite, lineseq
314 while (not null $op) {
315 $op = $op->sibling; # skip nextstate
317 $kid = $op->first->sibling; # skip pushmark
318 push @text, $kid->sv->PV;
319 $kid = $kid->sibling;
320 for (; not null $kid; $kid = $kid->sibling) {
321 push @exprs, $self->deparse($kid, 0);
323 push @text, join(", ", @exprs)."\n" if @exprs;
326 return join("", @text) . ".";
329 # the aassign in-common check messes up SvCUR (always setting it
330 # to a value >= 100), but it's probably safe to assume there
331 # won't be any NULs in the names of my() variables. (with
332 # stash variables, I wouldn't be so sure)
335 $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
341 return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope"
342 || $op->ppaddr eq "pp_lineseq"
343 || ($op->ppaddr eq "pp_null" && class($op) eq "UNOP"
344 && (is_scope($op->first) || $op->first->ppaddr eq "pp_enter"));
348 my $name = $_[0]->ppaddr;
349 return $name eq "pp_nextstate" || $name eq "pp_dbstate";
352 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
354 return (!null($op) and null($op->sibling)
355 and $op->ppaddr eq "pp_null" and class($op) eq "UNOP"
356 and (($op->first->ppaddr =~ /^pp_(and|or)$/
357 and $op->first->first->sibling->ppaddr eq "pp_lineseq")
358 or ($op->first->ppaddr eq "pp_lineseq"
359 and not null $op->first->first->sibling
360 and $op->first->first->sibling->ppaddr eq "pp_unstack")
366 return ($op->ppaddr eq "pp_rv2sv" or
367 $op->ppaddr eq "pp_padsv" or
368 $op->ppaddr eq "pp_gv" or # only in array/hash constructs
369 !null($op->first) && $op->first->ppaddr eq "pp_gvsv");
374 my($text, $cx, $prec) = @_;
375 if ($prec < $cx # unary ops nest just fine
376 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
377 or $self->{'parens'})
380 # In a unop, let parent reuse our parens; see maybe_parens_unop
381 $text = "\cS" . $text if $cx == 16;
388 # same as above, but get around the `if it looks like a function' rule
389 sub maybe_parens_unop {
391 my($name, $kid, $cx) = @_;
392 if ($cx > 16 or $self->{'parens'}) {
393 return "$name(" . $self->deparse($kid, 1) . ")";
395 $kid = $self->deparse($kid, 16);
396 if (substr($kid, 0, 1) eq "\cS") {
398 return $name . substr($kid, 1);
399 } elsif (substr($kid, 0, 1) eq "(") {
400 # avoid looks-like-a-function trap with extra parens
401 # (`+' can lead to ambiguities)
402 return "$name(" . $kid . ")";
409 sub maybe_parens_func {
411 my($func, $text, $cx, $prec) = @_;
412 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
413 return "$func($text)";
415 return "$func $text";
419 sub OPp_LVAL_INTRO () { 128 }
423 my($op, $cx, $text) = @_;
424 if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
425 return $self->maybe_parens_func("local", $text, $cx, 16);
434 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
439 my($op, $cx, $text) = @_;
440 if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
441 return $self->maybe_parens_func("my", $text, $cx, 16);
447 # The following OPs don't have functions:
449 # pp_padany -- does not exist after parsing
450 # pp_rcatline -- does not exist
452 sub pp_enter { # see also leave
453 cluck "unexpected OP_ENTER";
457 sub pp_pushmark { # see also list
458 cluck "unexpected OP_PUSHMARK";
462 sub pp_leavesub { # see also deparse_sub
463 cluck "unexpected OP_LEAVESUB";
467 sub pp_leavewrite { # see also deparse_format
468 cluck "unexpected OP_LEAVEWRITE";
472 sub pp_method { # see also entersub
473 cluck "unexpected OP_METHOD";
477 sub pp_regcmaybe { # see also regcomp
478 cluck "unexpected OP_REGCMAYBE";
482 sub pp_substcont { # see also subst
483 cluck "unexpected OP_SUBSTCONT";
487 sub pp_grepstart { # see also grepwhile
488 cluck "unexpected OP_GREPSTART";
492 sub pp_mapstart { # see also mapwhile
493 cluck "unexpected OP_MAPSTART";
497 sub pp_flip { # see also flop
498 cluck "unexpected OP_FLIP";
502 sub pp_iter { # see also leaveloop
503 cluck "unexpected OP_ITER";
507 sub pp_enteriter { # see also leaveloop
508 cluck "unexpected OP_ENTERITER";
512 sub pp_enterloop { # see also leaveloop
513 cluck "unexpected OP_ENTERLOOP";
517 sub pp_leaveeval { # see also entereval
518 cluck "unexpected OP_LEAVEEVAL";
522 sub pp_entertry { # see also leavetry
523 cluck "unexpected OP_ENTERTRY";
527 # leave and scope/lineseq should probably share code
533 local($self->{'curstash'}) = $self->{'curstash'};
534 $kid = $op->first->sibling; # skip enter
535 if (is_miniwhile($kid)) {
536 my $top = $kid->first;
537 my $name = $top->ppaddr;
538 if ($name eq "pp_and") {
540 } elsif ($name eq "pp_or") {
542 } else { # no conditional -> while 1 or until 0
543 return $self->deparse($top->first, 1) . " while 1";
545 my $cond = $top->first;
546 my $body = $cond->sibling->first; # skip lineseq
547 $cond = $self->deparse($cond, 1);
548 $body = $self->deparse($body, 1);
549 return "$body $name $cond";
551 for (; !null($kid); $kid = $kid->sibling) {
554 $expr = $self->deparse($kid, 0);
555 $kid = $kid->sibling;
558 $expr .= $self->deparse($kid, 0);
559 push @exprs, $expr if $expr;
561 if ($cx > 0) { # inside an expression
562 return "do { " . join(";\n", @exprs) . " }";
564 return join(";\n", @exprs);
573 for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
576 $expr = $self->deparse($kid, 0);
577 $kid = $kid->sibling;
580 $expr .= $self->deparse($kid, 0);
581 push @exprs, $expr if $expr;
583 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
584 return "do { " . join(";\n", @exprs) . " }";
586 return join(";\n", @exprs);
590 sub pp_lineseq { pp_scope(@_) }
592 # The BEGIN {} is used here because otherwise this code isn't executed
593 # when you run B::Deparse on itself.
595 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
596 "ENV", "ARGV", "ARGVOUT", "_"); }
601 my $stash = $gv->STASH->NAME;
602 my $name = $gv->NAME;
603 if ($stash eq $self->{'curstash'} or $globalnames{$name}
604 or $name =~ /^[^A-Za-z_]/)
608 $stash = $stash . "::";
610 if ($name =~ /^([\cA-\cZ])$/) {
611 $name = "^" . chr(64 + ord($1));
613 return $stash . $name;
616 # Notice how subs and formats are inserted between statements here
621 @text = $op->label . ": " if $op->label;
622 my $seq = $op->cop_seq;
623 while (scalar(@{$self->{'subs_todo'}})
624 and $seq > $self->{'subs_todo'}[0][0]) {
625 push @text, $self->next_todo;
627 my $stash = $op->stash->NAME;
628 if ($stash ne $self->{'curstash'}) {
629 push @text, "package $stash;\n";
630 $self->{'curstash'} = $stash;
632 return join("", @text);
635 sub pp_dbstate { pp_nextstate(@_) }
637 sub pp_unstack { return "" } # see also leaveloop
641 my($op, $cx, $name) = @_;
645 sub pp_stub { baseop(@_, "()") }
646 sub pp_wantarray { baseop(@_, "wantarray") }
647 sub pp_fork { baseop(@_, "fork") }
648 sub pp_wait { baseop(@_, "wait") }
649 sub pp_getppid { baseop(@_, "getppid") }
650 sub pp_time { baseop(@_, "time") }
651 sub pp_tms { baseop(@_, "times") }
652 sub pp_ghostent { baseop(@_, "gethostent") }
653 sub pp_gnetent { baseop(@_, "getnetent") }
654 sub pp_gprotoent { baseop(@_, "getprotoent") }
655 sub pp_gservent { baseop(@_, "getservent") }
656 sub pp_ehostent { baseop(@_, "endhostent") }
657 sub pp_enetent { baseop(@_, "endnetent") }
658 sub pp_eprotoent { baseop(@_, "endprotoent") }
659 sub pp_eservent { baseop(@_, "endservent") }
660 sub pp_gpwent { baseop(@_, "getpwent") }
661 sub pp_spwent { baseop(@_, "setpwent") }
662 sub pp_epwent { baseop(@_, "endpwent") }
663 sub pp_ggrent { baseop(@_, "getgrent") }
664 sub pp_sgrent { baseop(@_, "setgrent") }
665 sub pp_egrent { baseop(@_, "endgrent") }
666 sub pp_getlogin { baseop(@_, "getlogin") }
670 # I couldn't think of a good short name, but this is the category of
671 # symbolic unary operators with interesting precedence
675 my($op, $cx, $name, $prec, $flags) = (@_, 0);
676 my $kid = $op->first;
677 $kid = $self->deparse($kid, $prec);
678 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
682 sub pp_preinc { pfixop(@_, "++", 23) }
683 sub pp_predec { pfixop(@_, "--", 23) }
684 sub pp_postinc { pfixop(@_, "++", 23, POSTFIX) }
685 sub pp_postdec { pfixop(@_, "--", 23, POSTFIX) }
686 sub pp_i_preinc { pfixop(@_, "++", 23) }
687 sub pp_i_predec { pfixop(@_, "--", 23) }
688 sub pp_i_postinc { pfixop(@_, "++", 23, POSTFIX) }
689 sub pp_i_postdec { pfixop(@_, "--", 23, POSTFIX) }
690 sub pp_complement { pfixop(@_, "~", 21) }
695 if ($op->first->ppaddr =~ /^pp_(i_)?negate$/) {
697 $self->pfixop($op, $cx, "-", 21.5);
699 $self->pfixop($op, $cx, "-", 21);
702 sub pp_i_negate { pp_negate(@_) }
708 $self->pfixop($op, $cx, "not ", 4);
710 $self->pfixop($op, $cx, "!", 21);
714 sub OPf_SPECIAL () { 128 }
718 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
720 if ($op->flags & OPf_KIDS) {
722 return $self->maybe_parens_unop($name, $kid, $cx);
724 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
728 sub pp_chop { unop(@_, "chop") }
729 sub pp_chomp { unop(@_, "chomp") }
730 sub pp_schop { unop(@_, "chop") }
731 sub pp_schomp { unop(@_, "chomp") }
732 sub pp_defined { unop(@_, "defined") }
733 sub pp_undef { unop(@_, "undef") }
734 sub pp_study { unop(@_, "study") }
735 sub pp_ref { unop(@_, "ref") }
736 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
738 sub pp_sin { unop(@_, "sin") }
739 sub pp_cos { unop(@_, "cos") }
740 sub pp_rand { unop(@_, "rand") }
741 sub pp_srand { unop(@_, "srand") }
742 sub pp_exp { unop(@_, "exp") }
743 sub pp_log { unop(@_, "log") }
744 sub pp_sqrt { unop(@_, "sqrt") }
745 sub pp_int { unop(@_, "int") }
746 sub pp_hex { unop(@_, "hex") }
747 sub pp_oct { unop(@_, "oct") }
748 sub pp_abs { unop(@_, "abs") }
750 sub pp_length { unop(@_, "length") }
751 sub pp_ord { unop(@_, "ord") }
752 sub pp_chr { unop(@_, "chr") }
753 sub pp_ucfirst { unop(@_, "ucfirst") }
754 sub pp_lcfirst { unop(@_, "lcfirst") }
755 sub pp_uc { unop(@_, "uc") }
756 sub pp_lc { unop(@_, "lc") }
757 sub pp_quotemeta { unop(@_, "quotemeta") }
759 sub pp_each { unop(@_, "each") }
760 sub pp_values { unop(@_, "values") }
761 sub pp_keys { unop(@_, "keys") }
762 sub pp_pop { unop(@_, "pop") }
763 sub pp_shift { unop(@_, "shift") }
765 sub pp_caller { unop(@_, "caller") }
766 sub pp_reset { unop(@_, "reset") }
767 sub pp_exit { unop(@_, "exit") }
768 sub pp_prototype { unop(@_, "prototype") }
770 sub pp_close { unop(@_, "close") }
771 sub pp_fileno { unop(@_, "fileno") }
772 sub pp_umask { unop(@_, "umask") }
773 sub pp_binmode { unop(@_, "binmode") }
774 sub pp_untie { unop(@_, "untie") }
775 sub pp_tied { unop(@_, "tied") }
776 sub pp_dbmclose { unop(@_, "dbmclose") }
777 sub pp_getc { unop(@_, "getc") }
778 sub pp_eof { unop(@_, "eof") }
779 sub pp_tell { unop(@_, "tell") }
780 sub pp_getsockname { unop(@_, "getsockname") }
781 sub pp_getpeername { unop(@_, "getpeername") }
783 sub pp_chdir { unop(@_, "chdir") }
784 sub pp_chroot { unop(@_, "chroot") }
785 sub pp_readlink { unop(@_, "readlink") }
786 sub pp_rmdir { unop(@_, "rmdir") }
787 sub pp_readdir { unop(@_, "readdir") }
788 sub pp_telldir { unop(@_, "telldir") }
789 sub pp_rewinddir { unop(@_, "rewinddir") }
790 sub pp_closedir { unop(@_, "closedir") }
791 sub pp_getpgrp { unop(@_, "getpgrp") }
792 sub pp_localtime { unop(@_, "localtime") }
793 sub pp_gmtime { unop(@_, "gmtime") }
794 sub pp_alarm { unop(@_, "alarm") }
795 sub pp_sleep { unop(@_, "sleep") }
797 sub pp_dofile { unop(@_, "do") }
798 sub pp_entereval { unop(@_, "eval") }
800 sub pp_ghbyname { unop(@_, "gethostbyname") }
801 sub pp_gnbyname { unop(@_, "getnetbyname") }
802 sub pp_gpbyname { unop(@_, "getprotobyname") }
803 sub pp_shostent { unop(@_, "sethostent") }
804 sub pp_snetent { unop(@_, "setnetent") }
805 sub pp_sprotoent { unop(@_, "setprotoent") }
806 sub pp_sservent { unop(@_, "setservent") }
807 sub pp_gpwnam { unop(@_, "getpwnam") }
808 sub pp_gpwuid { unop(@_, "getpwuid") }
809 sub pp_ggrnam { unop(@_, "getgrnam") }
810 sub pp_ggrgid { unop(@_, "getgrgid") }
812 sub pp_lock { unop(@_, "lock") }
817 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
821 sub OPpSLICE () { 64 }
827 if ($op->private & OPpSLICE) {
828 return $self->maybe_parens_func("delete",
829 $self->pp_hslice($op->first, 16),
832 return $self->maybe_parens_func("delete",
833 $self->pp_helem($op->first, 16),
838 sub OPp_CONST_BARE () { 64 }
843 if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const"
844 and $op->first->private & OPp_CONST_BARE)
846 my $name = $op->first->sv->PV;
849 return "require($name)";
851 $self->unop($op, $cx, "require");
858 my $kid = $op->first;
859 if (not null $kid->sibling) {
861 return $self->dquote($op);
863 $self->unop(@_, "scalar");
870 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
873 sub OPf_REF () { 16 }
878 my $kid = $op->first;
879 if ($kid->ppaddr eq "pp_null") {
881 if ($kid->ppaddr eq "pp_anonlist" || $kid->ppaddr eq "pp_anonhash") {
882 my($pre, $post) = @{{"pp_anonlist" => ["[","]"],
883 "pp_anonhash" => ["{","}"]}->{$kid->ppaddr}};
885 $kid = $kid->first->sibling; # skip pushmark
886 for (; !null($kid); $kid = $kid->sibling) {
887 $expr = $self->deparse($kid, 6);
890 return $pre . join(", ", @exprs) . $post;
891 } elsif (!null($kid->sibling) and
892 $kid->sibling->ppaddr eq "pp_anoncode") {
894 $self->deparse_sub($self->padval($kid->sibling->targ));
895 } elsif ($kid->ppaddr eq "pp_pushmark"
896 and $kid->sibling->ppaddr =~ /^pp_(pad|rv2)[ah]v$/
897 and not $kid->sibling->flags & OPf_REF) {
898 # The @a in \(@a) isn't in ref context, but only when the
900 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
903 $self->pfixop($op, $cx, "\\", 20);
906 sub pp_srefgen { pp_refgen(@_) }
911 my $kid = $op->first;
912 $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh>
913 if ($kid->ppaddr eq "pp_rv2gv") {
916 return "<" . $self->deparse($kid, 1) . ">";
921 my ($op, $cx, $name) = @_;
922 if (class($op) eq "PVOP") {
923 return "$name " . $op->pv;
924 } elsif (class($op) eq "OP") {
926 } elsif (class($op) eq "UNOP") {
927 # Note -- loop exits are actually exempt from the
928 # looks-like-a-func rule, but a few extra parens won't hurt
929 return $self->maybe_parens_unop($name, $op->first, $cx);
933 sub pp_last { loopex(@_, "last") }
934 sub pp_next { loopex(@_, "next") }
935 sub pp_redo { loopex(@_, "redo") }
936 sub pp_goto { loopex(@_, "goto") }
937 sub pp_dump { loopex(@_, "dump") }
941 my($op, $cx, $name) = @_;
942 if (class($op) eq "UNOP") {
943 # Genuine `-X' filetests are exempt from the LLAFR, but not
944 # l?stat(); for the sake of clarity, give'em all parens
945 return $self->maybe_parens_unop($name, $op->first, $cx);
946 } elsif (class($op) eq "GVOP") {
947 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
948 } else { # I don't think baseop filetests ever survive ck_ftst, but...
953 sub pp_lstat { ftst(@_, "lstat") }
954 sub pp_stat { ftst(@_, "stat") }
955 sub pp_ftrread { ftst(@_, "-R") }
956 sub pp_ftrwrite { ftst(@_, "-W") }
957 sub pp_ftrexec { ftst(@_, "-X") }
958 sub pp_fteread { ftst(@_, "-r") }
959 sub pp_ftewrite { ftst(@_, "-r") }
960 sub pp_fteexec { ftst(@_, "-r") }
961 sub pp_ftis { ftst(@_, "-e") }
962 sub pp_fteowned { ftst(@_, "-O") }
963 sub pp_ftrowned { ftst(@_, "-o") }
964 sub pp_ftzero { ftst(@_, "-z") }
965 sub pp_ftsize { ftst(@_, "-s") }
966 sub pp_ftmtime { ftst(@_, "-M") }
967 sub pp_ftatime { ftst(@_, "-A") }
968 sub pp_ftctime { ftst(@_, "-C") }
969 sub pp_ftsock { ftst(@_, "-S") }
970 sub pp_ftchr { ftst(@_, "-c") }
971 sub pp_ftblk { ftst(@_, "-b") }
972 sub pp_ftfile { ftst(@_, "-f") }
973 sub pp_ftdir { ftst(@_, "-d") }
974 sub pp_ftpipe { ftst(@_, "-p") }
975 sub pp_ftlink { ftst(@_, "-l") }
976 sub pp_ftsuid { ftst(@_, "-u") }
977 sub pp_ftsgid { ftst(@_, "-g") }
978 sub pp_ftsvtx { ftst(@_, "-k") }
979 sub pp_fttty { ftst(@_, "-t") }
980 sub pp_fttext { ftst(@_, "-T") }
981 sub pp_ftbinary { ftst(@_, "-B") }
983 sub SWAP_CHILDREN () { 1 }
984 sub ASSIGN () { 2 } # has OP= variant
986 sub OPf_STACKED () { 64 }
992 my $name = $op->ppaddr;
993 if ($name eq "pp_concat" and $op->first->ppaddr eq "pp_concat") {
994 # avoid spurious `=' -- see comment in pp_concat
997 if ($name eq "pp_null" and class($op) eq "UNOP"
998 and $op->first->ppaddr =~ /^pp_(and|x?or)$/
999 and null $op->first->sibling)
1001 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1002 # with a null that's used as the common end point of the two
1003 # flows of control. For precedence purposes, ignore it.
1004 # (COND_EXPRs have these too, but we don't bother with
1005 # their associativity).
1006 return assoc_class($op->first);
1008 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1011 # Left associative operators, like `+', for which
1012 # $a + $b + $c is equivalent to ($a + $b) + $c
1015 %left = ('pp_multiply' => 19, 'pp_i_multiply' => 19,
1016 'pp_divide' => 19, 'pp_i_divide' => 19,
1017 'pp_modulo' => 19, 'pp_i_modulo' => 19,
1019 'pp_add' => 18, 'pp_i_add' => 18,
1020 'pp_subtract' => 18, 'pp_i_subtract' => 18,
1022 'pp_left_shift' => 17, 'pp_right_shift' => 17,
1024 'pp_bit_or' => 12, 'pp_bit_xor' => 12,
1026 'pp_or' => 2, 'pp_xor' => 2,
1030 sub deparse_binop_left {
1032 my($op, $left, $prec) = @_;
1033 if ($left{assoc_class($op)}
1034 and $left{assoc_class($op)} == $left{assoc_class($left)})
1036 return $self->deparse($left, $prec - .00001);
1038 return $self->deparse($left, $prec);
1042 # Right associative operators, like `=', for which
1043 # $a = $b = $c is equivalent to $a = ($b = $c)
1046 %right = ('pp_pow' => 22,
1047 'pp_sassign=' => 7, 'pp_aassign=' => 7,
1048 'pp_multiply=' => 7, 'pp_i_multiply=' => 7,
1049 'pp_divide=' => 7, 'pp_i_divide=' => 7,
1050 'pp_modulo=' => 7, 'pp_i_modulo=' => 7,
1052 'pp_add=' => 7, 'pp_i_add=' => 7,
1053 'pp_subtract=' => 7, 'pp_i_subtract=' => 7,
1055 'pp_left_shift=' => 7, 'pp_right_shift=' => 7,
1057 'pp_bit_or=' => 7, 'pp_bit_xor=' => 7,
1058 'pp_andassign' => 7,
1063 sub deparse_binop_right {
1065 my($op, $right, $prec) = @_;
1066 if ($right{assoc_class($op)}
1067 and $right{assoc_class($op)} == $right{assoc_class($right)})
1069 return $self->deparse($right, $prec - .00001);
1071 return $self->deparse($right, $prec);
1077 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1078 my $left = $op->first;
1079 my $right = $op->last;
1081 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1085 if ($flags & SWAP_CHILDREN) {
1086 ($left, $right) = ($right, $left);
1088 $left = $self->deparse_binop_left($op, $left, $prec);
1089 $right = $self->deparse_binop_right($op, $right, $prec);
1090 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1093 sub pp_add { binop(@_, "+", 18, ASSIGN) }
1094 sub pp_multiply { binop(@_, "*", 19, ASSIGN) }
1095 sub pp_subtract { binop(@_, "-",18, ASSIGN) }
1096 sub pp_divide { binop(@_, "/", 19, ASSIGN) }
1097 sub pp_modulo { binop(@_, "%", 19, ASSIGN) }
1098 sub pp_i_add { binop(@_, "+", 18, ASSIGN) }
1099 sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) }
1100 sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) }
1101 sub pp_i_divide { binop(@_, "/", 19, ASSIGN) }
1102 sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) }
1103 sub pp_pow { binop(@_, "**", 22, ASSIGN) }
1105 sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) }
1106 sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) }
1107 sub pp_bit_and { binop(@_, "&", 13, ASSIGN) }
1108 sub pp_bit_or { binop(@_, "|", 12, ASSIGN) }
1109 sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) }
1111 sub pp_eq { binop(@_, "==", 14) }
1112 sub pp_ne { binop(@_, "!=", 14) }
1113 sub pp_lt { binop(@_, "<", 15) }
1114 sub pp_gt { binop(@_, ">", 15) }
1115 sub pp_ge { binop(@_, ">=", 15) }
1116 sub pp_le { binop(@_, "<=", 15) }
1117 sub pp_ncmp { binop(@_, "<=>", 14) }
1118 sub pp_i_eq { binop(@_, "==", 14) }
1119 sub pp_i_ne { binop(@_, "!=", 14) }
1120 sub pp_i_lt { binop(@_, "<", 15) }
1121 sub pp_i_gt { binop(@_, ">", 15) }
1122 sub pp_i_ge { binop(@_, ">=", 15) }
1123 sub pp_i_le { binop(@_, "<=", 15) }
1124 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1126 sub pp_seq { binop(@_, "eq", 14) }
1127 sub pp_sne { binop(@_, "ne", 14) }
1128 sub pp_slt { binop(@_, "lt", 15) }
1129 sub pp_sgt { binop(@_, "gt", 15) }
1130 sub pp_sge { binop(@_, "ge", 15) }
1131 sub pp_sle { binop(@_, "le", 15) }
1132 sub pp_scmp { binop(@_, "cmp", 14) }
1134 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1135 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1137 # `.' is special because concats-of-concats are optimized to save copying
1138 # by making all but the first concat stacked. The effect is as if the
1139 # programmer had written `($a . $b) .= $c', except legal.
1143 my $left = $op->first;
1144 my $right = $op->last;
1147 if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") {
1151 $left = $self->deparse_binop_left($op, $left, $prec);
1152 $right = $self->deparse_binop_right($op, $right, $prec);
1153 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1156 # `x' is weird when the left arg is a list
1160 my $left = $op->first;
1161 my $right = $op->last;
1164 if ($op->flags & OPf_STACKED) {
1168 if (null($right)) { # list repeat; count is inside left-side ex-list
1169 my $kid = $left->first->sibling; # skip pushmark
1171 for (; !null($kid->sibling); $kid = $kid->sibling) {
1172 push @exprs, $self->deparse($kid, 6);
1175 $left = "(" . join(", ", @exprs). ")";
1177 $left = $self->deparse_binop_left($op, $left, $prec);
1179 $right = $self->deparse_binop_right($op, $right, $prec);
1180 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1185 my ($op, $cx, $type) = @_;
1186 my $left = $op->first;
1187 my $right = $left->sibling;
1188 $left = $self->deparse($left, 9);
1189 $right = $self->deparse($right, 9);
1190 return $self->maybe_parens("$left $type $right", $cx, 9);
1196 my $flip = $op->first;
1197 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1198 return $self->range($flip->first, $cx, $type);
1201 # one-line while/until is handled in pp_leave
1205 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1206 my $left = $op->first;
1207 my $right = $op->first->sibling;
1208 if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
1209 $left = $self->deparse($left, 1);
1210 $right = $self->deparse($right, 0);
1211 return "$blockname ($left) {\n\t$right\n\b}\cK";
1212 } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
1213 $right = $self->deparse($right, 1);
1214 $left = $self->deparse($left, 1);
1215 return "$right $blockname $left";
1216 } elsif ($cx > $lowprec and $highop) { # $a && $b
1217 $left = $self->deparse_binop_left($op, $left, $highprec);
1218 $right = $self->deparse_binop_right($op, $right, $highprec);
1219 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1220 } else { # $a and $b
1221 $left = $self->deparse_binop_left($op, $left, $lowprec);
1222 $right = $self->deparse_binop_right($op, $right, $lowprec);
1223 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1227 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1228 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1229 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1233 my ($op, $cx, $opname) = @_;
1234 my $left = $op->first;
1235 my $right = $op->first->sibling->first; # skip sassign
1236 $left = $self->deparse($left, 7);
1237 $right = $self->deparse($right, 7);
1238 return $self->maybe_parens("$left $opname $right", $cx, 7);
1241 sub pp_andassign { logassignop(@_, "&&=") }
1242 sub pp_orassign { logassignop(@_, "||=") }
1246 my($op, $cx, $name) = @_;
1248 my $parens = ($cx >= 5) || $self->{'parens'};
1249 my $kid = $op->first->sibling;
1250 return $name if null $kid;
1251 my $first = $self->deparse($kid, 6);
1252 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1253 push @exprs, $first;
1254 $kid = $kid->sibling;
1255 for (; !null($kid); $kid = $kid->sibling) {
1256 push @exprs, $self->deparse($kid, 6);
1259 return "$name(" . join(", ", @exprs) . ")";
1261 return "$name " . join(", ", @exprs);
1265 sub pp_bless { listop(@_, "bless") }
1266 sub pp_atan2 { listop(@_, "atan2") }
1267 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1268 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1269 sub pp_index { listop(@_, "index") }
1270 sub pp_rindex { listop(@_, "rindex") }
1271 sub pp_sprintf { listop(@_, "sprintf") }
1272 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1273 sub pp_crypt { listop(@_, "crypt") }
1274 sub pp_unpack { listop(@_, "unpack") }
1275 sub pp_pack { listop(@_, "pack") }
1276 sub pp_join { listop(@_, "join") }
1277 sub pp_splice { listop(@_, "splice") }
1278 sub pp_push { listop(@_, "push") }
1279 sub pp_unshift { listop(@_, "unshift") }
1280 sub pp_reverse { listop(@_, "reverse") }
1281 sub pp_warn { listop(@_, "warn") }
1282 sub pp_die { listop(@_, "die") }
1283 # Actually, return is exempt from the LLAFR (see examples in this very
1284 # module!), but for consistency's sake, ignore that fact
1285 sub pp_return { listop(@_, "return") }
1286 sub pp_open { listop(@_, "open") }
1287 sub pp_pipe_op { listop(@_, "pipe") }
1288 sub pp_tie { listop(@_, "tie") }
1289 sub pp_dbmopen { listop(@_, "dbmopen") }
1290 sub pp_sselect { listop(@_, "select") }
1291 sub pp_select { listop(@_, "select") }
1292 sub pp_read { listop(@_, "read") }
1293 sub pp_sysopen { listop(@_, "sysopen") }
1294 sub pp_sysseek { listop(@_, "sysseek") }
1295 sub pp_sysread { listop(@_, "sysread") }
1296 sub pp_syswrite { listop(@_, "syswrite") }
1297 sub pp_send { listop(@_, "send") }
1298 sub pp_recv { listop(@_, "recv") }
1299 sub pp_seek { listop(@_, "seek") }
1300 sub pp_truncate { listop(@_, "truncate") }
1301 sub pp_fcntl { listop(@_, "fcntl") }
1302 sub pp_ioctl { listop(@_, "ioctl") }
1303 sub pp_flock { listop(@_, "flock") }
1304 sub pp_socket { listop(@_, "socket") }
1305 sub pp_sockpair { listop(@_, "sockpair") }
1306 sub pp_bind { listop(@_, "bind") }
1307 sub pp_connect { listop(@_, "connect") }
1308 sub pp_listen { listop(@_, "listen") }
1309 sub pp_accept { listop(@_, "accept") }
1310 sub pp_shutdown { listop(@_, "shutdown") }
1311 sub pp_gsockopt { listop(@_, "getsockopt") }
1312 sub pp_ssockopt { listop(@_, "setsockopt") }
1313 sub pp_chown { listop(@_, "chown") }
1314 sub pp_unlink { listop(@_, "unlink") }
1315 sub pp_chmod { listop(@_, "chmod") }
1316 sub pp_utime { listop(@_, "utime") }
1317 sub pp_rename { listop(@_, "rename") }
1318 sub pp_link { listop(@_, "link") }
1319 sub pp_symlink { listop(@_, "symlink") }
1320 sub pp_mkdir { listop(@_, "mkdir") }
1321 sub pp_open_dir { listop(@_, "opendir") }
1322 sub pp_seekdir { listop(@_, "seekdir") }
1323 sub pp_waitpid { listop(@_, "waitpid") }
1324 sub pp_system { listop(@_, "system") }
1325 sub pp_exec { listop(@_, "exec") }
1326 sub pp_kill { listop(@_, "kill") }
1327 sub pp_setpgrp { listop(@_, "setpgrp") }
1328 sub pp_getpriority { listop(@_, "getpriority") }
1329 sub pp_setpriority { listop(@_, "setpriority") }
1330 sub pp_shmget { listop(@_, "shmget") }
1331 sub pp_shmctl { listop(@_, "shmctl") }
1332 sub pp_shmread { listop(@_, "shmread") }
1333 sub pp_shmwrite { listop(@_, "shmwrite") }
1334 sub pp_msgget { listop(@_, "msgget") }
1335 sub pp_msgctl { listop(@_, "msgctl") }
1336 sub pp_msgsnd { listop(@_, "msgsnd") }
1337 sub pp_msgrcv { listop(@_, "msgrcv") }
1338 sub pp_semget { listop(@_, "semget") }
1339 sub pp_semctl { listop(@_, "semctl") }
1340 sub pp_semop { listop(@_, "semop") }
1341 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1342 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1343 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1344 sub pp_gsbyname { listop(@_, "getservbyname") }
1345 sub pp_gsbyport { listop(@_, "getservbyport") }
1346 sub pp_syscall { listop(@_, "syscall") }
1351 my $text = $self->dq($op->first->sibling); # skip pushmark
1352 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1353 or $text =~ /[<>]/) {
1354 return 'glob(' . single_delim('qq', '"', $text) . ')';
1356 return '<' . $text . '>';
1362 my($op, $cx, $name) = @_;
1364 my $kid = $op->first->sibling;
1366 if ($op->flags & OPf_STACKED) {
1368 $indir = $indir->first; # skip rv2gv
1369 if (is_scope($indir)) {
1370 $indir = "{" . $self->deparse($indir, 0) . "}";
1372 $indir = $self->deparse($indir, 24);
1374 $indir = $indir . " ";
1375 $kid = $kid->sibling;
1377 for (; !null($kid); $kid = $kid->sibling) {
1378 $expr = $self->deparse($kid, 6);
1381 return $self->maybe_parens_func($name,
1382 $indir . join(", ", @exprs),
1386 sub pp_prtf { indirop(@_, "printf") }
1387 sub pp_print { indirop(@_, "print") }
1388 sub pp_sort { indirop(@_, "sort") }
1392 my($op, $cx, $name) = @_;
1394 my $kid = $op->first; # this is the (map|grep)start
1395 $kid = $kid->first->sibling; # skip a pushmark
1396 my $code = $kid->first; # skip a null
1397 if (is_scope $code) {
1398 $code = "{" . $self->deparse($code, 1) . "} ";
1400 $code = $self->deparse($code, 24) . ", ";
1402 $kid = $kid->sibling;
1403 for (; !null($kid); $kid = $kid->sibling) {
1404 $expr = $self->deparse($kid, 6);
1405 push @exprs, $expr if $expr;
1407 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1410 sub pp_mapwhile { mapop(@_, "map") }
1411 sub pp_grepwhile { mapop(@_, "grep") }
1417 my $kid = $op->first->sibling; # skip pushmark
1418 return $self->deparse($kid, $cx) if null $kid->sibling;
1420 my $local = "either"; # could be local(...) or my(...)
1421 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1422 # This assumes that no other private flags equal 128, and that
1423 # OPs that store things other than flags in their op_private,
1424 # like OP_AELEMFAST, won't be immediate children of a list.
1425 unless ($lop->private & OPp_LVAL_INTRO or $lop->ppaddr eq "pp_undef")
1427 $local = ""; # or not
1430 if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my()
1431 ($local = "", last) if $local eq "local";
1433 } elsif ($lop->ppaddr ne "pp_undef") { # local()
1434 ($local = "", last) if $local eq "my";
1438 $local = "" if $local eq "either"; # no point if it's all undefs
1439 for (; !null($kid); $kid = $kid->sibling) {
1441 if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") {
1446 $self->{'avoid_local'}{$$lop}++;
1447 $expr = $self->deparse($kid, 6);
1448 delete $self->{'avoid_local'}{$$lop};
1450 $expr = $self->deparse($kid, 6);
1455 return "$local(" . join(", ", @exprs) . ")";
1457 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1464 my $cond = $op->first;
1465 my $true = $cond->sibling;
1466 my $false = $true->sibling;
1467 my $cuddle = $self->{'cuddle'};
1468 $cond = $self->deparse($cond, 1);
1469 unless ($cx == 0 and is_scope($true) and is_scope($false)) {
1470 $true = $self->deparse($true, 8);
1471 $false = $self->deparse($false, 8);
1472 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1474 $true = $self->deparse($true, 0);
1475 if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif
1476 my $head = "if ($cond) {\n\t$true\n\b}";
1478 while (!null($false) and $false->ppaddr eq "pp_lineseq") {
1479 my $newop = $false->first->sibling->first;
1480 my $newcond = $newop->first;
1481 my $newtrue = $newcond->sibling;
1482 $false = $newtrue->sibling; # last in chain is OP_AND => no else
1483 $newcond = $self->deparse($newcond, 1);
1484 $newtrue = $self->deparse($newtrue, 0);
1485 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1487 if (!null($false)) {
1488 $false = $cuddle . "else {\n\t" .
1489 $self->deparse($false, 0) . "\n\b}\cK";
1493 return $head . join($cuddle, "", @elsifs) . $false;
1495 $false = $self->deparse($false, 0);
1496 return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
1502 my $enter = $op->first;
1503 my $kid = $enter->sibling;
1504 local($self->{'curstash'}) = $self->{'curstash'};
1507 if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop
1508 if (is_state $kid->last) { # infinite
1509 $head = "for (;;) "; # shorter than while (1)
1513 } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach
1514 my $ary = $enter->first->sibling; # first was pushmark
1515 my $var = $ary->sibling;
1516 $ary = $self->deparse($ary, 1);
1518 if ($enter->flags & OPf_SPECIAL) { # thread special var
1519 $var = $self->pp_threadsv($enter, 1);
1520 } else { # regular my() variable
1521 $var = $self->pp_padsv($enter, 1);
1522 if ($self->padname_sv($enter->targ)->IVX ==
1523 $kid->first->first->sibling->last->cop_seq)
1525 # If the scope of this variable closes at the last
1526 # statement of the loop, it must have been
1528 $var = "my " . $var;
1531 } elsif ($var->ppaddr eq "pp_rv2gv") {
1532 $var = $self->pp_rv2sv($var, 1);
1533 } elsif ($var->ppaddr eq "pp_gv") {
1534 $var = "\$" . $self->deparse($var, 1);
1536 $head = "foreach $var ($ary) ";
1537 $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1538 } elsif ($kid->ppaddr eq "pp_null") { # while/until
1540 my $name = {"pp_and" => "while", "pp_or" => "until"}
1542 $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
1543 $kid = $kid->first->sibling;
1544 } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty
1545 return "{;}"; # {} could be a hashref
1547 # The third-to-last kid is the continue block if the pointer used
1548 # by `next BLOCK' points to its first OP, which happens to be the
1549 # the op_next of the head of the _previous_ statement.
1550 # Unless it's a bare loop, in which case it's last, since there's
1551 # no unstack or extra nextstate.
1552 my($cont, $precont);
1554 $cont = $kid->first;
1555 while (!null($cont->sibling)) {
1557 $cont = $cont->sibling;
1560 $cont = $kid->first;
1561 while (!null($cont->sibling->sibling->sibling)) {
1563 $cont = $cont->sibling;
1566 # cluck $self->{'curcv'}->GV->NAME unless $precont;
1567 if ($precont and $ {$precont->next} == $ {$enter->nextop}) {
1568 my $state = $kid->first;
1569 my $cuddle = $self->{'cuddle'};
1571 for (; $$state != $$cont; $state = $state->sibling) {
1573 if (is_state $state) {
1574 $expr = $self->deparse($state, 0);
1575 $state = $state->sibling;
1578 $expr .= $self->deparse($state, 0);
1579 push @exprs, $expr if $expr;
1581 $kid = join(";\n", @exprs);
1582 $cont = $cuddle . "continue {\n\t" .
1583 $self->deparse($cont, 0) . "\n\b}\cK";
1586 $kid = $self->deparse($kid, 0);
1588 return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1593 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1596 sub OP_CONST () { 5 }
1597 sub OP_STRINGIFY () { 65 }
1602 if (class($op) eq "OP") {
1603 return "'???'" if $op->targ == OP_CONST; # old value is lost
1604 } elsif ($op->first->ppaddr eq "pp_pushmark") {
1605 return $self->pp_list($op, $cx);
1606 } elsif ($op->first->ppaddr eq "pp_enter") {
1607 return $self->pp_leave($op, $cx);
1608 } elsif ($op->targ == OP_STRINGIFY) {
1609 return $self->dquote($op);
1610 } elsif (!null($op->first->sibling) and
1611 $op->first->sibling->ppaddr eq "pp_readline" and
1612 $op->first->sibling->flags & OPf_STACKED) {
1613 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1614 . $self->deparse($op->first->sibling, 7),
1616 } elsif (!null($op->first->sibling) and
1617 $op->first->sibling->ppaddr eq "pp_trans" and
1618 $op->first->sibling->flags & OPf_STACKED) {
1619 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1620 . $self->deparse($op->first->sibling, 20),
1623 return $self->deparse($op->first, $cx);
1630 my $str = $self->padname_sv($targ)->PV;
1631 return padname_fix($str);
1637 return substr($self->padname($op->targ), 1); # skip $/@/%
1643 return $self->maybe_my($op, $cx, $self->padname($op->targ));
1646 sub pp_padav { pp_padsv(@_) }
1647 sub pp_padhv { pp_padsv(@_) }
1652 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1653 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1654 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1661 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
1667 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
1673 return $self->gv_name($op->gv);
1680 return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1685 my($op, $cx, $type) = @_;
1686 my $kid = $op->first;
1687 my $scope = is_scope($kid);
1688 $kid = $self->deparse($kid, 0);
1689 return $type . ($scope ? "{$kid}" : $kid);
1692 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1693 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1694 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1700 if ($op->first->ppaddr eq "pp_padav") {
1701 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1703 return $self->maybe_local($op, $cx, $self->rv2x($op->first, '$#'));
1707 # skip down to the old, ex-rv2cv
1708 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
1713 my $kid = $op->first;
1714 if ($kid->ppaddr eq "pp_const") { # constant list
1716 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1718 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
1725 my ($op, $cx, $left, $right, $padname) = @_;
1726 my($array, $idx) = ($op->first, $op->first->sibling);
1727 unless ($array->ppaddr eq $padname) { # Maybe this has been fixed
1728 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1730 if ($array->ppaddr eq $padname) {
1731 $array = $self->padany($array);
1732 } elsif (is_scope($array)) { # ${expr}[0]
1733 $array = "{" . $self->deparse($array, 0) . "}";
1734 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
1735 $array = $self->deparse($array, 24);
1737 # $x[20][3]{hi} or expr->[20]
1739 $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/;
1740 return $self->deparse($array, 24) . $arrow .
1741 $left . $self->deparse($idx, 1) . $right;
1743 $idx = $self->deparse($idx, 1);
1744 return "\$" . $array . $left . $idx . $right;
1747 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) }
1748 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) }
1753 my($glob, $part) = ($op->first, $op->last);
1754 $glob = $glob->first; # skip rv2gv
1755 $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug
1756 my $scope = is_scope($glob);
1757 $glob = $self->deparse($glob, 0);
1758 $part = $self->deparse($part, 1);
1759 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
1764 my ($op, $cx, $left, $right, $regname, $padname) = @_;
1766 my(@elems, $kid, $array, $list);
1767 if (class($op) eq "LISTOP") {
1769 } else { # ex-hslice inside delete()
1770 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
1774 $array = $array->first
1775 if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null";
1776 if (is_scope($array)) {
1777 $array = "{" . $self->deparse($array, 0) . "}";
1778 } elsif ($array->ppaddr eq $padname) {
1779 $array = $self->padany($array);
1781 $array = $self->deparse($array, 24);
1783 $kid = $op->first->sibling; # skip pushmark
1784 if ($kid->ppaddr eq "pp_list") {
1785 $kid = $kid->first->sibling; # skip list, pushmark
1786 for (; !null $kid; $kid = $kid->sibling) {
1787 push @elems, $self->deparse($kid, 6);
1789 $list = join(", ", @elems);
1791 $list = $self->deparse($kid, 1);
1793 return "\@" . $array . $left . $list . $right;
1796 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]",
1797 "pp_rv2av", "pp_padav")) }
1798 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
1799 "pp_rv2hv", "pp_padhv")) }
1804 my $idx = $op->first;
1805 my $list = $op->last;
1807 $list = $self->deparse($list, 1);
1808 $idx = $self->deparse($idx, 1);
1809 return "($list)" . "[$idx]";
1812 sub OPpENTERSUB_AMPER () { 8 }
1814 sub OPf_WANT () { 3 }
1815 sub OPf_WANT_VOID () { 1 }
1816 sub OPf_WANT_SCALAR () { 2 }
1817 sub OPf_WANT_LIST () { 2 }
1821 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
1831 my($kid, $args, @exprs);
1832 if (not null $op->first->sibling) { # method
1833 $kid = $op->first->sibling; # skip pushmark
1834 my $obj = $self->deparse($kid, 24);
1835 $kid = $kid->sibling;
1836 for (; not null $kid->sibling; $kid = $kid->sibling) {
1837 push @exprs, $self->deparse($kid, 6);
1839 my $meth = $kid->first;
1840 if ($meth->ppaddr eq "pp_const") {
1841 $meth = $meth->sv->PV; # needs to be bare
1843 $meth = $self->deparse($meth, 1);
1845 $args = join(", ", @exprs);
1846 $kid = $obj . "->" . $meth;
1848 return $kid . "(" . $args . ")"; # parens mandatory
1850 return $kid; # toke.c fakes parens
1853 # else, not a method
1854 if ($op->flags & OPf_SPECIAL) {
1856 } elsif ($op->private & OPpENTERSUB_AMPER) {
1860 $kid = $kid->first->sibling; # skip ex-list, pushmark
1861 for (; not null $kid->sibling; $kid = $kid->sibling) {
1864 if (is_scope($kid)) {
1866 $kid = "{" . $self->deparse($kid, 0) . "}";
1867 } elsif ($kid->first->ppaddr eq "pp_gv") {
1868 my $gv = $kid->first->gv;
1869 if (class($gv->CV) ne "SPECIAL") {
1870 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
1873 $kid = $self->deparse($kid, 24);
1874 } elsif (is_scalar $kid->first) {
1876 $kid = $self->deparse($kid, 24);
1879 $kid = $self->deparse($kid, 24) . "->";
1881 if (defined $proto and not $amper) {
1886 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
1888 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
1891 undef $proto if @args;
1892 } elsif ($chr eq ";") {
1894 } elsif ($chr eq "@" or $chr eq "%") {
1895 push @reals, map($self->deparse($_, 6), @args);
1899 undef $proto, last unless $arg;
1901 if (want_scalar $arg) {
1902 push @reals, $self->deparse($arg, 6);
1906 } elsif ($chr eq "&") {
1907 if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
1908 push @reals, $self->deparse($arg, 6);
1912 } elsif ($chr eq "*") {
1913 if ($arg->ppaddr =~ /^pp_s?refgen$/
1914 and $arg->first->first->ppaddr eq "pp_rv2gv")
1916 $real = $arg->first->first; # skip refgen, null
1917 if ($real->first->ppaddr eq "pp_gv") {
1918 push @reals, $self->deparse($real, 6);
1920 push @reals, $self->deparse($real->first, 6);
1925 } elsif (substr($chr, 0, 1) eq "\\") {
1926 $chr = substr($chr, 1);
1927 if ($arg->ppaddr =~ /^pp_s?refgen$/ and
1928 !null($real = $arg->first) and
1929 ($chr eq "\$" && is_scalar($real->first)
1931 && $real->first->sibling->ppaddr
1932 =~ /^pp_(rv2|pad)av$/)
1934 && $real->first->sibling->ppaddr
1935 =~ /^pp_(rv2|pad)hv$/)
1936 #or ($chr eq "&" # This doesn't work
1937 # && $real->first->ppaddr eq "pp_rv2cv")
1939 && $real->first->ppaddr eq "pp_rv2gv")))
1941 push @reals, $self->deparse($real, 6);
1948 undef $proto if $proto and !$doneok;
1949 undef $proto if @args;
1950 $args = join(", ", @reals);
1952 unless (defined $proto) {
1954 $args = join(", ", map($self->deparse($_, 6), @exprs));
1957 $args = join(", ", map($self->deparse($_, 6), @exprs));
1959 if ($prefix or $amper) {
1960 if ($op->flags & OPf_STACKED) {
1961 return $prefix . $amper . $kid . "(" . $args . ")";
1963 return $prefix . $amper. $kid;
1966 if (defined $proto and $proto eq "") {
1968 } elsif ($proto eq "\$") {
1969 return $self->maybe_parens_func($kid, $args, $cx, 16);
1970 } elsif ($proto or $simple) {
1971 return $self->maybe_parens_func($kid, $args, $cx, 5);
1973 return "$kid(" . $args . ")";
1978 sub pp_enterwrite { unop(@_, "write") }
1980 # escape things that cause interpolation in double quotes,
1981 # but not character escapes
1984 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
1988 # the same, but treat $|, $), and $ at the end of the string differently
1991 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
1992 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
1996 # character escapes, but not delimiters that might need to be escaped
1997 sub escape_str { # ASCII
2000 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2006 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2007 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2011 # Don't do this for regexen
2014 $str =~ s/\\/\\\\/g;
2018 sub balanced_delim {
2020 my @str = split //, $str;
2021 my($ar, $open, $close, $fail, $c, $cnt);
2022 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2023 ($open, $close) = @$ar;
2024 $fail = 0; $cnt = 0;
2028 } elsif ($c eq $close) {
2036 $fail = 1 if $cnt != 0;
2037 return ($open, "$open$str$close") if not $fail;
2043 my($q, $default, $str) = @_;
2044 return "$default$str$default" if index($str, $default) == -1;
2045 my($succeed, $delim);
2046 ($succeed, $str) = balanced_delim($str);
2047 return "$q$str" if $succeed;
2048 for $delim ('/', '"', '#') {
2049 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2051 $str =~ s/$default/\\$default/g;
2052 return "$default$str$default";
2055 sub SVf_IOK () {0x10000}
2056 sub SVf_NOK () {0x20000}
2057 sub SVf_ROK () {0x80000}
2061 if (class($sv) eq "SPECIAL") {
2062 return ('undef', '1', '0')[$$sv-1];
2063 } elsif ($sv->FLAGS & SVf_IOK) {
2065 } elsif ($sv->FLAGS & SVf_NOK) {
2067 } elsif ($sv->FLAGS & SVf_ROK) {
2068 return "\\(" . const($sv->RV) . ")"; # constant folded
2071 if ($str =~ /[^ -~]/) { # ASCII
2072 return single_delim("qq", '"', uninterp escape_str unback $str);
2074 $str =~ s/\\/\\\\/g;
2075 return single_delim("q", "'", $str);
2083 # if ($op->private & OPp_CONST_BARE) { # trouble with `=>' autoquoting
2084 # return $op->sv->PV;
2086 return const($op->sv);
2092 my $type = $op->ppaddr;
2093 if ($type eq "pp_const") {
2094 return uninterp(escape_str(unback($op->sv->PV)));
2095 } elsif ($type eq "pp_concat") {
2096 return $self->dq($op->first) . $self->dq($op->last);
2097 } elsif ($type eq "pp_uc") {
2098 return '\U' . $self->dq($op->first->sibling) . '\E';
2099 } elsif ($type eq "pp_lc") {
2100 return '\L' . $self->dq($op->first->sibling) . '\E';
2101 } elsif ($type eq "pp_ucfirst") {
2102 return '\u' . $self->dq($op->first->sibling);
2103 } elsif ($type eq "pp_lcfirst") {
2104 return '\l' . $self->dq($op->first->sibling);
2105 } elsif ($type eq "pp_quotemeta") {
2106 return '\Q' . $self->dq($op->first->sibling) . '\E';
2107 } elsif ($type eq "pp_join") {
2108 return $self->deparse($op->last, 26); # was join($", @ary)
2110 return $self->deparse($op, 26);
2118 return single_delim("qx", '`', $self->dq($op->first->sibling));
2124 # skip ex-stringify, pushmark
2125 return single_delim("qq", '"', $self->dq($op->first->sibling));
2128 # OP_STRINGIFY is a listop, but it only ever has one arg (?)
2129 sub pp_stringify { dquote(@_) }
2131 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2132 # note that tr(from)/to/ is OK, but not tr/from/(to)
2134 my($from, $to) = @_;
2135 my($succeed, $delim);
2136 if ($from !~ m[/] and $to !~ m[/]) {
2137 return "/$from/$to/";
2138 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2139 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2142 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2143 return "$from$delim$to$delim" if index($to, $delim) == -1;
2146 return "$from/$to/";
2149 for $delim ('/', '"', '#') { # note no '
2150 return "$delim$from$delim$to$delim"
2151 if index($to . $from, $delim) == -1;
2153 $from =~ s[/][\\/]g;
2155 return "/$from/$to/";
2161 if ($n == ord '\\') {
2163 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2165 } elsif ($n == ord "\a") {
2167 } elsif ($n == ord "\b") {
2169 } elsif ($n == ord "\t") {
2171 } elsif ($n == ord "\n") {
2173 } elsif ($n == ord "\e") {
2175 } elsif ($n == ord "\f") {
2177 } elsif ($n == ord "\r") {
2179 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2180 return '\\c' . chr(ord("@") + $n);
2182 # return '\x' . sprintf("%02x", $n);
2183 return '\\' . sprintf("%03o", $n);
2190 for ($c = 0; $c < @chars; $c++) {
2193 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2194 $chars[$c + 2] == $tr + 2)
2196 for (; $c <= $#chars and $chars[$c + 1] == $chars[$c] + 1; $c++) {}
2198 $str .= pchr($chars[$c]);
2204 sub OPpTRANS_SQUASH () { 16 }
2205 sub OPpTRANS_DELETE () { 32 }
2206 sub OPpTRANS_COMPLEMENT () { 64 }
2211 my(@table) = unpack("s256", $op->pv);
2212 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2213 if ($table[ord "-"] != -1 and
2214 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2216 $tr = $table[ord "-"];
2217 $table[ord "-"] = -1;
2221 } else { # -2 ==> delete
2225 for ($c = 0; $c < 256; $c++) {
2228 push @from, $c; push @to, $tr;
2229 } elsif ($tr == -2) {
2234 @from = (@from, @delfrom);
2235 if ($op->private & OPpTRANS_COMPLEMENT) {
2239 @from{@from} = (1) x @from;
2240 for ($c = 0; $c < 256; $c++) {
2241 push @newfrom, $c unless $from{$c};
2245 if ($op->private & OPpTRANS_DELETE) {
2248 pop @to while $#to and $to[$#to] == $to[$#to -1];
2250 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2252 $from = collapse(@from);
2253 $to = collapse(@to);
2254 $from .= "-" if $delhyphen;
2255 return "tr" . double_delim($from, $to) . $flags;
2258 # Like dq(), but different
2262 my $type = $op->ppaddr;
2263 if ($type eq "pp_const") {
2264 return uninterp($op->sv->PV);
2265 } elsif ($type eq "pp_concat") {
2266 return $self->re_dq($op->first) . $self->re_dq($op->last);
2267 } elsif ($type eq "pp_uc") {
2268 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2269 } elsif ($type eq "pp_lc") {
2270 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2271 } elsif ($type eq "pp_ucfirst") {
2272 return '\u' . $self->re_dq($op->first->sibling);
2273 } elsif ($type eq "pp_lcfirst") {
2274 return '\l' . $self->re_dq($op->first->sibling);
2275 } elsif ($type eq "pp_quotemeta") {
2276 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2277 } elsif ($type eq "pp_join") {
2278 return $self->deparse($op->last, 26); # was join($", @ary)
2280 return $self->deparse($op, 26);
2287 my $kid = $op->first;
2288 $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe";
2289 return $self->re_dq($kid);
2292 sub OPp_RUNTIME () { 64 }
2294 sub PMf_ONCE () { 0x2 }
2295 sub PMf_SKIPWHITE () { 0x10 }
2296 sub PMf_FOLD () { 0x20 }
2297 sub PMf_CONST () { 0x40 }
2298 sub PMf_KEEP () { 0x80 }
2299 sub PMf_GLOBAL () { 0x100 }
2300 sub PMf_CONTINUE () { 0x200 }
2301 sub PMf_EVAL () { 0x400 }
2302 sub PMf_MULTILINE () { 0x1000 }
2303 sub PMf_SINGLELINE () { 0x2000 }
2304 sub PMf_LOCALE () { 0x4000 }
2305 sub PMf_EXTENDED () { 0x8000 }
2307 # osmic acid -- see osmium tetroxide
2310 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2311 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2312 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2317 my $kid = $op->first;
2318 my ($binop, $var, $re) = ("", "", "");
2319 if ($op->flags & OPf_STACKED) {
2321 $var = $self->deparse($kid, 20);
2322 $kid = $kid->sibling;
2325 $re = re_uninterp(escape_str($op->precomp));
2327 $re = $self->deparse($kid, 1);
2330 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2331 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2332 $flags .= "i" if $op->pmflags & PMf_FOLD;
2333 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2334 $flags .= "o" if $op->pmflags & PMf_KEEP;
2335 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2336 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2337 $flags = $matchwords{$flags} if $matchwords{$flags};
2338 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2342 $re = single_delim("m", "/", $re);
2346 return $self->maybe_parens("$var =~ $re", $cx, 20);
2352 sub pp_pushre { pp_match(@_) }
2357 my($kid, @exprs, $ary, $expr);
2359 if ($ {$kid->pmreplroot}) {
2360 $ary = '@' . $self->gv_name($kid->pmreplroot);
2362 for (; !null($kid); $kid = $kid->sibling) {
2363 push @exprs, $self->deparse($kid, 6);
2365 $expr = "split(" . join(", ", @exprs) . ")";
2367 return $self->maybe_parens("$ary = $expr", $cx, 7);
2373 # oxime -- any of various compounds obtained chiefly by the action of
2374 # hydroxylamine on aldehydes and ketones and characterized by the
2375 # bivalent grouping C=NOH [Webster's Tenth]
2378 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2379 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2380 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2381 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2386 my $kid = $op->first;
2387 my($binop, $var, $re, $repl) = ("", "", "", "");
2388 if ($op->flags & OPf_STACKED) {
2390 $var = $self->deparse($kid, 20);
2391 $kid = $kid->sibling;
2394 if (null($op->pmreplroot)) {
2395 $repl = $self->dq($kid);
2396 $kid = $kid->sibling;
2398 $repl = $op->pmreplroot->first; # skip substcont
2399 while ($repl->ppaddr eq "pp_entereval") {
2400 $repl = $repl->first;
2403 $repl = $self->dq($repl);
2406 $re = re_uninterp(escape_str($op->precomp));
2408 $re = $self->deparse($kid, 1);
2410 $flags .= "e" if $op->pmflags & PMf_EVAL;
2411 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2412 $flags .= "i" if $op->pmflags & PMf_FOLD;
2413 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2414 $flags .= "o" if $op->pmflags & PMf_KEEP;
2415 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2416 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2417 $flags = $substwords{$flags} if $substwords{$flags};
2419 return $self->maybe_parens("$var =~ s"
2420 . double_delim($re, $repl) . $flags,
2423 return "s". double_delim($re, $repl) . $flags;
2432 B::Deparse - Perl compiler backend to produce perl code
2436 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-s>I<LETTERS>] I<prog.pl>
2440 B::Deparse is a backend module for the Perl compiler that generates
2441 perl source code, based on the internal compiled structure that perl
2442 itself creates after parsing a program. The output of B::Deparse won't
2443 be exactly the same as the original source, since perl doesn't keep
2444 track of comments or whitespace, and there isn't a one-to-one
2445 correspondence between perl's syntactical constructions and their
2446 compiled form, but it will often be close. When you use the B<-p>
2447 option, the output also includes parentheses even when they are not
2448 required by precedence, which can make it easy to see if perl is
2449 parsing your expressions the way you intended.
2451 Please note that this module is mainly new and untested code and is
2452 still under development, so it may change in the future.
2456 As with all compiler backend options, these must follow directly after
2457 the '-MO=Deparse', separated by a comma but not any white space.
2463 Print extra parentheses. Without this option, B::Deparse includes
2464 parentheses in its output only when they are needed, based on the
2465 structure of your program. With B<-p>, it uses parentheses (almost)
2466 whenever they would be legal. This can be useful if you are used to
2467 LISP, or if you want to see how perl parses your input. If you say
2469 if ($var & 0x7f == 65) {print "Gimme an A!"}
2470 print ($which ? $a : $b), "\n";
2471 $name = $ENV{USER} or "Bob";
2473 C<B::Deparse,-p> will print
2476 print('Gimme an A!')
2478 (print(($which ? $a : $b)), '???');
2479 (($name = $ENV{'USER'}) or '???')
2481 which probably isn't what you intended (the C<'???'> is a sign that
2482 perl optimized away a constant value).
2484 =item B<-u>I<PACKAGE>
2486 Normally, B::Deparse deparses the main code of a program, all the subs
2487 called by the main program (and all the subs called by them,
2488 recursively), and any other subs in the main:: package. To include
2489 subs in other packages that aren't called directly, such as AUTOLOAD,
2490 DESTROY, other subs called automatically by perl, and methods, which
2491 aren't resolved to subs until runtime, use the B<-u> option. The
2492 argument to B<-u> is the name of a package, and should follow directly
2493 after the 'u'. Multiple B<-u> options may be given, separated by
2494 commas. Note that unlike some other backends, B::Deparse doesn't
2495 (yet) try to guess automatically when B<-u> is needed -- you must
2498 =item B<-s>I<LETTERS>
2500 Tweak the style of B::Deparse's output. At the moment, only one style
2501 option is implemented:
2507 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2524 The default is not to cuddle.
2532 See the 'to do' list at the beginning of the module file.
2536 Stephen McCamant <alias@mcs.com>, based on an earlier version by
2537 Malcolm Beattie <mbeattie@sable.ox.ac.uk>.