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.pm
CommitLineData
a798dbf2
MB
1# B.pm
2#
3# Copyright (c) 1996, 1997 Malcolm Beattie
4#
5# You may distribute under the terms of either the GNU General Public
6# License or the Artistic License, as specified in the README file.
7#
8package B;
9require DynaLoader;
10require Exporter;
11@ISA = qw(Exporter DynaLoader);
12@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
13 class peekop cast_I32 cstring cchar hash threadsv_names
14 main_root main_start main_cv svref_2object
15 walkoptree walkoptree_slow walkoptree_exec walksymtable
16 parents comppadlist sv_undef compile_stats timing_info);
17
18use strict;
19@B::SV::ISA = 'B::OBJECT';
20@B::NULL::ISA = 'B::SV';
21@B::PV::ISA = 'B::SV';
22@B::IV::ISA = 'B::SV';
23@B::NV::ISA = 'B::IV';
24@B::RV::ISA = 'B::SV';
25@B::PVIV::ISA = qw(B::PV B::IV);
26@B::PVNV::ISA = qw(B::PV B::NV);
27@B::PVMG::ISA = 'B::PVNV';
28@B::PVLV::ISA = 'B::PVMG';
29@B::BM::ISA = 'B::PVMG';
30@B::AV::ISA = 'B::PVMG';
31@B::GV::ISA = 'B::PVMG';
32@B::HV::ISA = 'B::PVMG';
33@B::CV::ISA = 'B::PVMG';
34@B::IO::ISA = 'B::CV';
35
36@B::OP::ISA = 'B::OBJECT';
37@B::UNOP::ISA = 'B::OP';
38@B::BINOP::ISA = 'B::UNOP';
39@B::LOGOP::ISA = 'B::UNOP';
40@B::CONDOP::ISA = 'B::UNOP';
41@B::LISTOP::ISA = 'B::BINOP';
42@B::SVOP::ISA = 'B::OP';
43@B::GVOP::ISA = 'B::OP';
44@B::PVOP::ISA = 'B::OP';
45@B::CVOP::ISA = 'B::OP';
46@B::LOOP::ISA = 'B::LISTOP';
47@B::PMOP::ISA = 'B::LISTOP';
48@B::COP::ISA = 'B::OP';
49
50@B::SPECIAL::ISA = 'B::OBJECT';
51
52{
53 # Stop "-w" from complaining about the lack of a real B::OBJECT class
54 package B::OBJECT;
55}
56
57my $debug;
58my $op_count = 0;
59my @parents = ();
60
61sub debug {
62 my ($class, $value) = @_;
63 $debug = $value;
64 walkoptree_debug($value);
65}
66
67# sub OPf_KIDS;
68# add to .xs for perl5.002
69sub OPf_KIDS () { 4 }
70
71sub class {
72 my $obj = shift;
73 my $name = ref $obj;
74 $name =~ s/^.*:://;
75 return $name;
76}
77
78sub parents { \@parents }
79
80# For debugging
81sub peekop {
82 my $op = shift;
83 return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
84}
85
86sub walkoptree_slow {
87 my($op, $method, $level) = @_;
88 $op_count++; # just for statistics
89 $level ||= 0;
90 warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
91 $op->$method($level);
92 if ($$op && ($op->flags & OPf_KIDS)) {
93 my $kid;
94 unshift(@parents, $op);
95 for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
96 walkoptree_slow($kid, $method, $level + 1);
97 }
98 shift @parents;
99 }
100}
101
102sub compile_stats {
103 return "Total number of OPs processed: $op_count\n";
104}
105
106sub timing_info {
107 my ($sec, $min, $hr) = localtime;
108 my ($user, $sys) = times;
109 sprintf("%02d:%02d:%02d user=$user sys=$sys",
110 $hr, $min, $sec, $user, $sys);
111}
112
113my %symtable;
114sub savesym {
115 my ($obj, $value) = @_;
116# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
117 $symtable{sprintf("sym_%x", $$obj)} = $value;
118}
119
120sub objsym {
121 my $obj = shift;
122 return $symtable{sprintf("sym_%x", $$obj)};
123}
124
125sub walkoptree_exec {
126 my ($op, $method, $level) = @_;
127 my ($sym, $ppname);
128 my $prefix = " " x $level;
129 for (; $$op; $op = $op->next) {
130 $sym = objsym($op);
131 if (defined($sym)) {
132 print $prefix, "goto $sym\n";
133 return;
134 }
135 savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
136 $op->$method($level);
137 $ppname = $op->ppaddr;
138 if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
139 print $prefix, uc($1), " => {\n";
140 walkoptree_exec($op->other, $method, $level + 1);
141 print $prefix, "}\n";
142 } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
143 my $pmreplstart = $op->pmreplstart;
144 if ($$pmreplstart) {
145 print $prefix, "PMREPLSTART => {\n";
146 walkoptree_exec($pmreplstart, $method, $level + 1);
147 print $prefix, "}\n";
148 }
149 } elsif ($ppname eq "pp_substcont") {
150 print $prefix, "SUBSTCONT => {\n";
151 walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
152 print $prefix, "}\n";
153 $op = $op->other;
154 } elsif ($ppname eq "pp_cond_expr") {
155 # pp_cond_expr never returns op_next
156 print $prefix, "TRUE => {\n";
157 walkoptree_exec($op->true, $method, $level + 1);
158 print $prefix, "}\n";
159 $op = $op->false;
160 redo;
161 } elsif ($ppname eq "pp_range") {
162 print $prefix, "TRUE => {\n";
163 walkoptree_exec($op->true, $method, $level + 1);
164 print $prefix, "}\n", $prefix, "FALSE => {\n";
165 walkoptree_exec($op->false, $method, $level + 1);
166 print $prefix, "}\n";
167 } elsif ($ppname eq "pp_enterloop") {
168 print $prefix, "REDO => {\n";
169 walkoptree_exec($op->redoop, $method, $level + 1);
170 print $prefix, "}\n", $prefix, "NEXT => {\n";
171 walkoptree_exec($op->nextop, $method, $level + 1);
172 print $prefix, "}\n", $prefix, "LAST => {\n";
173 walkoptree_exec($op->lastop, $method, $level + 1);
174 print $prefix, "}\n";
175 } elsif ($ppname eq "pp_subst") {
176 my $replstart = $op->pmreplstart;
177 if ($$replstart) {
178 print $prefix, "SUBST => {\n";
179 walkoptree_exec($replstart, $method, $level + 1);
180 print $prefix, "}\n";
181 }
182 }
183 }
184}
185
186sub walksymtable {
187 my ($symref, $method, $recurse, $prefix) = @_;
188 my $sym;
189 no strict 'vars';
190 local(*glob);
191 while (($sym, *glob) = each %$symref) {
192 if ($sym =~ /::$/) {
193 $sym = $prefix . $sym;
194 if ($sym ne "main::" && &$recurse($sym)) {
195 walksymtable(\%glob, $method, $recurse, $sym);
196 }
197 } else {
198 svref_2object(\*glob)->EGV->$method();
199 }
200 }
201}
202
203{
204 package B::Section;
205 my $output_fh;
206 my %sections;
207
208 sub new {
209 my ($class, $section, $symtable, $default) = @_;
210 $output_fh ||= FileHandle->new_tmpfile;
211 my $obj = bless [-1, $section, $symtable, $default], $class;
212 $sections{$section} = $obj;
213 return $obj;
214 }
215
216 sub get {
217 my ($class, $section) = @_;
218 return $sections{$section};
219 }
220
221 sub add {
222 my $section = shift;
223 while (defined($_ = shift)) {
224 print $output_fh "$section->[1]\t$_\n";
225 $section->[0]++;
226 }
227 }
228
229 sub index {
230 my $section = shift;
231 return $section->[0];
232 }
233
234 sub name {
235 my $section = shift;
236 return $section->[1];
237 }
238
239 sub symtable {
240 my $section = shift;
241 return $section->[2];
242 }
243
244 sub default {
245 my $section = shift;
246 return $section->[3];
247 }
248
249 sub output {
250 my ($section, $fh, $format) = @_;
251 my $name = $section->name;
252 my $sym = $section->symtable || {};
253 my $default = $section->default;
254
255 seek($output_fh, 0, 0);
256 while (<$output_fh>) {
257 chomp;
258 s/^(.*?)\t//;
259 if ($1 eq $name) {
260 s{(s\\_[0-9a-f]+)} {
261 exists($sym->{$1}) ? $sym->{$1} : $default;
262 }ge;
263 printf $fh $format, $_;
264 }
265 }
266 }
267}
268
269bootstrap B;
270
2711;