Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package B::Terse; |
2 | ||
3 | our $VERSION = '1.00'; | |
4 | ||
5 | use strict; | |
6 | use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow | |
7 | main_start main_root cstring svref_2object SVf_IVisUV); | |
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 | } | |
19 | ||
20 | sub compile { | |
21 | my $order = @_ ? shift : ""; | |
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 { | |
43 | my $level = @_ ? shift : 0; | |
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); | |
108 | printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->SAFENAME; | |
109 | } | |
110 | ||
111 | sub B::IV::terse { | |
112 | my ($sv, $level) = @_; | |
113 | print indent($level); | |
114 | my $v = $sv->FLAGS & SVf_IVisUV ? "%u" : "%d"; | |
115 | printf "%s (0x%lx) $v\n", class($sv), $$sv, $sv->int_value; | |
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 | ||
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 | ||
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]; | |
155 | } | |
156 | ||
157 | 1; | |
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 | ||
167 | perl -MO=Terse[,OPTIONS] foo.pl | |
168 | ||
169 | =head1 DESCRIPTION | |
170 | ||
171 | See F<ext/B/README>. | |
172 | ||
173 | =head1 AUTHOR | |
174 | ||
175 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> | |
176 | ||
177 | =cut |