3 # Copyright (c) 1996, 1997 Malcolm Beattie
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.
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);
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';
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';
50 @B::SPECIAL::ISA = 'B::OBJECT';
53 # Stop "-w" from complaining about the lack of a real B::OBJECT class
62 my ($class, $value) = @_;
64 walkoptree_debug($value);
68 # add to .xs for perl5.002
78 sub parents { \@parents }
83 return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
87 my($op, $method, $level) = @_;
88 $op_count++; # just for statistics
90 warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
92 if ($$op && ($op->flags & OPf_KIDS)) {
94 unshift(@parents, $op);
95 for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
96 walkoptree_slow($kid, $method, $level + 1);
103 return "Total number of OPs processed: $op_count\n";
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);
115 my ($obj, $value) = @_;
116 # warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
117 $symtable{sprintf("sym_%x", $$obj)} = $value;
122 return $symtable{sprintf("sym_%x", $$obj)};
125 sub walkoptree_exec {
126 my ($op, $method, $level) = @_;
128 my $prefix = " " x $level;
129 for (; $$op; $op = $op->next) {
132 print $prefix, "goto $sym\n";
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;
145 print $prefix, "PMREPLSTART => {\n";
146 walkoptree_exec($pmreplstart, $method, $level + 1);
147 print $prefix, "}\n";
149 } elsif ($ppname eq "pp_substcont") {
150 print $prefix, "SUBSTCONT => {\n";
151 walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
152 print $prefix, "}\n";
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";
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;
178 print $prefix, "SUBST => {\n";
179 walkoptree_exec($replstart, $method, $level + 1);
180 print $prefix, "}\n";
187 my ($symref, $method, $recurse, $prefix) = @_;
191 while (($sym, *glob) = each %$symref) {
193 $sym = $prefix . $sym;
194 if ($sym ne "main::" && &$recurse($sym)) {
195 walksymtable(\%glob, $method, $recurse, $sym);
198 svref_2object(\*glob)->EGV->$method();
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;
217 my ($class, $section) = @_;
218 return $sections{$section};
223 while (defined($_ = shift)) {
224 print $output_fh "$section->[1]\t$_\n";
231 return $section->[0];
236 return $section->[1];
241 return $section->[2];
246 return $section->[3];
250 my ($section, $fh, $format) = @_;
251 my $name = $section->name;
252 my $sym = $section->symtable || {};
253 my $default = $section->default;
255 seek($output_fh, 0, 0);
256 while (<$output_fh>) {
261 exists($sym->{$1}) ? $sym->{$1} : $default;
263 printf $fh $format, $_;