Commit | Line | Data |
a798dbf2 |
1 | package B::Terse; |
28b605d8 |
2 | |
3 | our $VERSION = '1.00'; |
4 | |
ad4997d3 |
5 | use strict; |
6 | use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow |
d9963e60 |
7 | main_start main_root cstring svref_2object SVf_IVisUV); |
ad4997d3 |
8 | use B::Asmdata qw(@specialsv_name); |
9 | |
10 | sub terse { |
11 | my ($order, $cvref) = @_; |
12 | my $cv = svref_2object($cvref); |
13 | if ($order eq "exec") { |
14 | walkoptree_exec($cv->START, "terse"); |
15 | } else { |
16 | walkoptree_slow($cv->ROOT, "terse"); |
17 | } |
18 | } |
a798dbf2 |
19 | |
20 | sub compile { |
244826eb |
21 | my $order = @_ ? shift : ""; |
ad4997d3 |
22 | my @options = @_; |
23 | B::clearsym(); |
24 | if (@options) { |
25 | return sub { |
26 | my $objname; |
27 | foreach $objname (@options) { |
28 | $objname = "main::$objname" unless $objname =~ /::/; |
29 | eval "terse(\$order, \\&$objname)"; |
30 | die "terse($order, \\&$objname) failed: $@" if $@; |
31 | } |
32 | } |
33 | } else { |
34 | if ($order eq "exec") { |
35 | return sub { walkoptree_exec(main_start, "terse") } |
36 | } else { |
37 | return sub { walkoptree_slow(main_root, "terse") } |
38 | } |
39 | } |
40 | } |
41 | |
42 | sub indent { |
244826eb |
43 | my $level = @_ ? shift : 0; |
ad4997d3 |
44 | return " " x $level; |
45 | } |
46 | |
47 | sub B::OP::terse { |
48 | my ($op, $level) = @_; |
49 | my $targ = $op->targ; |
50 | $targ = ($targ > 0) ? " [$targ]" : ""; |
51 | print indent($level), peekop($op), $targ, "\n"; |
52 | } |
53 | |
54 | sub B::SVOP::terse { |
55 | my ($op, $level) = @_; |
56 | print indent($level), peekop($op), " "; |
57 | $op->sv->terse(0); |
58 | } |
59 | |
60 | sub B::PADOP::terse { |
61 | my ($op, $level) = @_; |
62 | print indent($level), peekop($op), " ", $op->padix, "\n"; |
63 | } |
64 | |
65 | sub B::PMOP::terse { |
66 | my ($op, $level) = @_; |
67 | my $precomp = $op->precomp; |
68 | print indent($level), peekop($op), |
69 | defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n"; |
70 | |
71 | } |
72 | |
73 | sub B::PVOP::terse { |
74 | my ($op, $level) = @_; |
75 | print indent($level), peekop($op), " ", cstring($op->pv), "\n"; |
76 | } |
77 | |
78 | sub B::COP::terse { |
79 | my ($op, $level) = @_; |
80 | my $label = $op->label; |
81 | if ($label) { |
82 | $label = " label ".cstring($label); |
83 | } |
84 | print indent($level), peekop($op), $label || "", "\n"; |
85 | } |
86 | |
87 | sub B::PV::terse { |
88 | my ($sv, $level) = @_; |
89 | print indent($level); |
90 | printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV); |
91 | } |
92 | |
93 | sub B::AV::terse { |
94 | my ($sv, $level) = @_; |
95 | print indent($level); |
96 | printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL; |
97 | } |
98 | |
99 | sub B::GV::terse { |
100 | my ($gv, $level) = @_; |
101 | my $stash = $gv->STASH->NAME; |
102 | if ($stash eq "main") { |
103 | $stash = ""; |
104 | } else { |
105 | $stash = $stash . "::"; |
106 | } |
107 | print indent($level); |
002b978b |
108 | printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->SAFENAME; |
ad4997d3 |
109 | } |
110 | |
111 | sub B::IV::terse { |
112 | my ($sv, $level) = @_; |
113 | print indent($level); |
d9963e60 |
114 | my $v = $sv->FLAGS & SVf_IVisUV ? "%u" : "%d"; |
115 | printf "%s (0x%lx) $v\n", class($sv), $$sv, $sv->int_value; |
ad4997d3 |
116 | } |
117 | |
118 | sub B::NV::terse { |
119 | my ($sv, $level) = @_; |
120 | print indent($level); |
121 | printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV; |
122 | } |
123 | |
d333a217 |
124 | sub B::RV::terse { |
125 | my ($rv, $level) = @_; |
126 | print indent($level); |
127 | printf "%s (0x%lx) %s\n", class($rv), $$rv, printref($rv); |
128 | } |
129 | |
130 | sub printref { |
131 | my $rv = shift; |
132 | my $rcl = class($rv->RV); |
133 | if ($rcl eq 'PV') { |
134 | return "\\" . cstring($rv->RV->$rcl); |
135 | } elsif ($rcl eq 'NV') { |
136 | return "\\" . $rv->RV->$rcl; |
137 | } elsif ($rcl eq 'IV') { |
138 | return sprintf "\\%" . ($rv->RV->FLAGS & SVf_IVisUV ? "u" : "d"), |
139 | $rv->RV->int_value; |
140 | } elsif ($rcl eq 'RV') { |
141 | return "\\" . printref($rv->RV); |
142 | } |
143 | } |
144 | |
ad4997d3 |
145 | sub B::NULL::terse { |
146 | my ($sv, $level) = @_; |
147 | print indent($level); |
148 | printf "%s (0x%lx)\n", class($sv), $$sv; |
149 | } |
150 | |
151 | sub B::SPECIAL::terse { |
152 | my ($sv, $level) = @_; |
153 | print indent($level); |
154 | printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv]; |
a798dbf2 |
155 | } |
156 | |
157 | 1; |
7f20e9dd |
158 | |
159 | __END__ |
160 | |
161 | =head1 NAME |
162 | |
163 | B::Terse - Walk Perl syntax tree, printing terse info about ops |
164 | |
165 | =head1 SYNOPSIS |
166 | |
ad4997d3 |
167 | perl -MO=Terse[,OPTIONS] foo.pl |
7f20e9dd |
168 | |
169 | =head1 DESCRIPTION |
170 | |
ad4997d3 |
171 | See F<ext/B/README>. |
7f20e9dd |
172 | |
173 | =head1 AUTHOR |
174 | |
ad4997d3 |
175 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> |
7f20e9dd |
176 | |
177 | =cut |