Commit | Line | Data |
a798dbf2 |
1 | package B::Deparse; |
2 | use strict; |
3 | use B qw(peekop class main_root); |
4 | |
5 | my $debug; |
6 | |
7 | sub compile { |
8 | my $opt = shift; |
9 | if ($opt eq "-d") { |
10 | $debug = 1; |
11 | } |
12 | return sub { print deparse(main_root), "\n" } |
13 | } |
14 | |
15 | sub ppname { |
16 | my $op = shift; |
17 | my $ppname = $op->ppaddr; |
18 | warn sprintf("ppname %s\n", peekop($op)) if $debug; |
19 | no strict "refs"; |
20 | return defined(&$ppname) ? &$ppname($op) : 0; |
21 | } |
22 | |
23 | sub deparse { |
24 | my $op = shift; |
25 | my $expr; |
26 | warn sprintf("deparse %s\n", peekop($op)) if $debug; |
27 | while (ref($expr = ppname($op))) { |
28 | $op = $expr; |
29 | warn sprintf("Redirecting to %s\n", peekop($op)) if $debug; |
30 | } |
31 | return $expr; |
32 | } |
33 | |
34 | sub pp_leave { |
35 | my $op = shift; |
36 | my ($child, $expr); |
37 | for ($child = $op->first; !$expr; $child = $child->sibling) { |
38 | $expr = ppname($child); |
39 | } |
40 | return $expr; |
41 | } |
42 | |
43 | sub SWAP_CHILDREN () { 1 } |
44 | |
45 | sub binop { |
46 | my ($op, $opname, $flags) = @_; |
47 | my $left = $op->first; |
48 | my $right = $op->last; |
49 | if ($flags & SWAP_CHILDREN) { |
50 | ($left, $right) = ($right, $left); |
51 | } |
52 | warn sprintf("binop deparsing first %s\n", peekop($op->first)) if $debug; |
53 | $left = deparse($left); |
54 | warn sprintf("binop deparsing last %s\n", peekop($op->last)) if $debug; |
55 | $right = deparse($right); |
56 | return "($left $opname $right)"; |
57 | } |
58 | |
59 | sub pp_add { binop($_[0], "+") } |
60 | sub pp_multiply { binop($_[0], "*") } |
61 | sub pp_subtract { binop($_[0], "-") } |
62 | sub pp_divide { binop($_[0], "/") } |
63 | sub pp_modulo { binop($_[0], "%") } |
64 | sub pp_eq { binop($_[0], "==") } |
65 | sub pp_ne { binop($_[0], "!=") } |
66 | sub pp_lt { binop($_[0], "<") } |
67 | sub pp_gt { binop($_[0], ">") } |
68 | sub pp_ge { binop($_[0], ">=") } |
69 | |
70 | sub pp_sassign { binop($_[0], "=", SWAP_CHILDREN) } |
71 | |
72 | sub pp_null { |
73 | my $op = shift; |
74 | warn sprintf("Skipping null op %s\n", peekop($op)) if $debug; |
75 | return $op->first; |
76 | } |
77 | |
78 | sub pp_const { |
79 | my $op = shift; |
80 | my $sv = $op->sv; |
81 | if (class($sv) eq "IV") { |
82 | return $sv->IV; |
83 | } elsif (class($sv) eq "NV") { |
84 | return $sv->NV; |
85 | } else { |
86 | return $sv->PV; |
87 | } |
88 | } |
89 | |
90 | sub pp_gvsv { |
91 | my $op = shift; |
92 | my $gv = $op->gv; |
93 | my $stash = $gv->STASH->NAME; |
94 | if ($stash eq "main") { |
95 | $stash = ""; |
96 | } else { |
97 | $stash = $stash . "::"; |
98 | } |
99 | return sprintf('$%s%s', $stash, $gv->NAME); |
100 | } |
101 | |
102 | 1; |