This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
applied patch, moved #define mkfifo ... from perl.h to POSIX.xs
[perl5.git] / ext / B / B.pm
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 #
8 package B;
9 require DynaLoader;
10 require 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
18 use 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
57 my $debug;
58 my $op_count = 0;
59 my @parents = ();
60
61 sub 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
69 sub OPf_KIDS () { 4 }
70
71 sub class {
72     my $obj = shift;
73     my $name = ref $obj;
74     $name =~ s/^.*:://;
75     return $name;
76 }
77
78 sub parents { \@parents }
79
80 # For debugging
81 sub peekop {
82     my $op = shift;
83     return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
84 }
85
86 sub 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
102 sub compile_stats {
103     return "Total number of OPs processed: $op_count\n";
104 }
105
106 sub 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
113 my %symtable;
114 sub 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
120 sub objsym {
121     my $obj = shift;
122     return $symtable{sprintf("sym_%x", $$obj)};
123 }
124
125 sub 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
186 sub 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
269 bootstrap B;
270
271 1;