This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move lib/B/... and lib/[BO].pm over to where they should be,
[perl5.git] / ext / B / B / Deparse.pm
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;