This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pat.t tests
[perl5.git] / ext / B / B / Deparse.pm
CommitLineData
a798dbf2
MB
1package B::Deparse;
2use strict;
3use B qw(peekop class main_root);
4
5my $debug;
6
7sub compile {
8 my $opt = shift;
9 if ($opt eq "-d") {
10 $debug = 1;
11 }
12 return sub { print deparse(main_root), "\n" }
13}
14
15sub 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
23sub 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
34sub 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
43sub SWAP_CHILDREN () { 1 }
44
45sub 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
59sub pp_add { binop($_[0], "+") }
60sub pp_multiply { binop($_[0], "*") }
61sub pp_subtract { binop($_[0], "-") }
62sub pp_divide { binop($_[0], "/") }
63sub pp_modulo { binop($_[0], "%") }
64sub pp_eq { binop($_[0], "==") }
65sub pp_ne { binop($_[0], "!=") }
66sub pp_lt { binop($_[0], "<") }
67sub pp_gt { binop($_[0], ">") }
68sub pp_ge { binop($_[0], ">=") }
69
70sub pp_sassign { binop($_[0], "=", SWAP_CHILDREN) }
71
72sub pp_null {
73 my $op = shift;
74 warn sprintf("Skipping null op %s\n", peekop($op)) if $debug;
75 return $op->first;
76}
77
78sub 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
90sub 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
1021;