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