Commit | Line | Data |
adfe19db |
1 | #!/usr/bin/perl -w |
2 | ################################################################################ |
3 | # |
4 | # mktodo.pl -- generate baseline and todo files |
5 | # |
6 | ################################################################################ |
7 | # |
c1a049cb |
8 | # $Revision: 15 $ |
adfe19db |
9 | # $Author: mhx $ |
c1a049cb |
10 | # $Date: 2008/01/04 10:47:39 +0100 $ |
adfe19db |
11 | # |
12 | ################################################################################ |
13 | # |
c1a049cb |
14 | # Version 3.x, Copyright (C) 2004-2008, Marcus Holland-Moritz. |
adfe19db |
15 | # Version 2.x, Copyright (C) 2001, Paul Marquess. |
16 | # Version 1.x, Copyright (C) 1999, Kenneth Albanowski. |
17 | # |
18 | # This program is free software; you can redistribute it and/or |
19 | # modify it under the same terms as Perl itself. |
20 | # |
21 | ################################################################################ |
22 | |
23 | use strict; |
24 | use Getopt::Long; |
25 | use Data::Dumper; |
26 | use IO::File; |
27 | use IO::Select; |
ba120f6f |
28 | use Config; |
0c96388f |
29 | use Time::HiRes qw( gettimeofday tv_interval ); |
adfe19db |
30 | |
0c96388f |
31 | require 'devel/devtools.pl'; |
adfe19db |
32 | |
0c96388f |
33 | our %opt = ( |
34 | debug => 0, |
35 | base => 0, |
36 | verbose => 0, |
ba120f6f |
37 | check => 1, |
38 | shlib => 'blib/arch/auto/Devel/PPPort/PPPort.so', |
0c96388f |
39 | ); |
adfe19db |
40 | |
41 | GetOptions(\%opt, qw( |
ba120f6f |
42 | perl=s todo=s version=s shlib=s debug base verbose check! |
adfe19db |
43 | )) or die; |
44 | |
0c96388f |
45 | identify(); |
46 | |
47 | print "\n", ident_str(), "\n\n"; |
48 | |
adfe19db |
49 | my $fullperl = `which $opt{perl}`; |
50 | chomp $fullperl; |
51 | |
0c96388f |
52 | $ENV{SKIP_SLOW_TESTS} = 1; |
53 | |
adfe19db |
54 | regen_all(); |
55 | |
56 | my %sym; |
ba120f6f |
57 | for (`$Config{nm} $fullperl`) { |
adfe19db |
58 | chomp; |
59 | /\s+T\s+(\w+)\s*$/ and $sym{$1}++; |
60 | } |
61 | keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n"; |
62 | |
63 | my %all = %{load_todo($opt{todo}, $opt{version})}; |
64 | my @recheck; |
65 | |
ba120f6f |
66 | my $symmap = get_apicheck_symbol_map(); |
67 | |
adfe19db |
68 | for (;;) { |
69 | my $retry = 1; |
ba120f6f |
70 | my $trynm = 1; |
adfe19db |
71 | regen_apicheck(); |
ba120f6f |
72 | |
adfe19db |
73 | retry: |
adfe19db |
74 | my(@new, @tmp, %seen); |
ba120f6f |
75 | |
76 | my $r = run(qw(make)); |
77 | $r->{didnotrun} and die "couldn't run make: $!\n"; |
78 | |
adfe19db |
79 | for my $l (@{$r->{stderr}}) { |
80 | if ($l =~ /_DPPP_test_(\w+)/) { |
81 | if (!$seen{$1}++) { |
82 | my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1"; |
83 | if (@s) { |
84 | push @tmp, [$1, "E (@s)"]; |
85 | } |
86 | else { |
87 | push @new, [$1, "E"]; |
88 | } |
89 | } |
90 | } |
ba120f6f |
91 | } |
92 | |
93 | if ($r->{status} == 0) { |
94 | my @u; |
95 | my @usym; |
96 | |
97 | if ($trynm) { |
98 | @u = eval { find_undefined_symbols($fullperl, $opt{shlib}) }; |
99 | warn "warning: $@" if $@; |
100 | $trynm = 0; |
101 | } |
102 | |
103 | unless (@u) { |
104 | $r = run(qw(make test)); |
105 | $r->{didnotrun} and die "couldn't run make test: $!\n"; |
106 | $r->{status} == 0 and last; |
107 | |
108 | for my $l (@{$r->{stderr}}) { |
109 | if ($l =~ /undefined symbol: (\w+)/) { |
110 | push @u, $1; |
111 | } |
112 | } |
113 | } |
114 | |
115 | for my $u (@u) { |
116 | for my $m (keys %{$symmap->{$u}}) { |
117 | if (!$seen{$m}++) { |
118 | my $pl = $m; |
119 | $pl =~ s/^[Pp]erl_//; |
120 | my @s = grep { exists $sym{$_} } $pl, "Perl_$pl", "perl_$pl"; |
121 | push @new, [$m, @s ? "U (@s)" : "U"]; |
122 | } |
adfe19db |
123 | } |
124 | } |
125 | } |
ba120f6f |
126 | |
adfe19db |
127 | @new = grep !$all{$_->[0]}, @new; |
ba120f6f |
128 | |
adfe19db |
129 | unless (@new) { |
130 | @new = grep !$all{$_->[0]}, @tmp; |
adfe19db |
131 | } |
ba120f6f |
132 | |
adfe19db |
133 | unless (@new) { |
134 | if ($retry > 0) { |
135 | $retry--; |
136 | regen_all(); |
137 | goto retry; |
138 | } |
139 | print Dumper($r); |
140 | die "no new TODO symbols found..."; |
141 | } |
ba120f6f |
142 | |
0c96388f |
143 | # don't recheck undefined symbols reported by the dynamic linker |
144 | push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new; |
ba120f6f |
145 | |
adfe19db |
146 | for (@new) { |
ba120f6f |
147 | sym('new', @$_); |
adfe19db |
148 | $all{$_->[0]} = $_->[1]; |
149 | } |
0c96388f |
150 | |
adfe19db |
151 | write_todo($opt{todo}, $opt{version}, \%all); |
ba120f6f |
152 | } |
0c96388f |
153 | |
ba120f6f |
154 | if ($opt{check}) { |
155 | my $ifmt = '%' . length(scalar @recheck) . 'd'; |
156 | my $t0 = [gettimeofday]; |
157 | |
158 | RECHECK: for my $i (0 .. $#recheck) { |
159 | my $sym = $recheck[$i]; |
160 | my $cur = delete $all{$sym}; |
161 | |
162 | sym('chk', $sym, $cur, sprintf(" [$ifmt/$ifmt, ETA %s]", |
163 | $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck))); |
164 | |
165 | write_todo($opt{todo}, $opt{version}, \%all); |
166 | |
167 | if ($cur eq "E (Perl_$sym)") { |
168 | # we can try a shortcut here |
169 | regen_apicheck($sym); |
170 | |
171 | my $r = run(qw(make test)); |
172 | |
173 | if (!$r->{didnotrun} && $r->{status} == 0) { |
174 | sym('del', $sym, $cur); |
175 | next RECHECK; |
176 | } |
177 | } |
178 | |
179 | # run the full test |
180 | regen_all(); |
181 | |
0c96388f |
182 | my $r = run(qw(make test)); |
ba120f6f |
183 | |
184 | $r->{didnotrun} and die "couldn't run make test: $!\n"; |
185 | |
186 | if ($r->{status} == 0) { |
187 | sym('del', $sym, $cur); |
188 | } |
189 | else { |
190 | $all{$sym} = $cur; |
0c96388f |
191 | } |
adfe19db |
192 | } |
193 | } |
194 | |
195 | write_todo($opt{todo}, $opt{version}, \%all); |
196 | |
197 | run(qw(make realclean)); |
198 | |
199 | exit 0; |
200 | |
ba120f6f |
201 | sub sym |
202 | { |
203 | my($what, $sym, $reason, $extra) = @_; |
204 | $extra ||= ''; |
205 | my %col = ( |
206 | 'new' => 'bold red', |
207 | 'chk' => 'bold magenta', |
208 | 'del' => 'bold green', |
209 | ); |
210 | $what = colored("$what symbol", $col{$what}); |
211 | |
212 | printf "[%s] %s %-30s # %s%s\n", |
213 | $opt{version}, $what, $sym, $reason, $extra; |
214 | } |
215 | |
adfe19db |
216 | sub regen_all |
217 | { |
ba120f6f |
218 | my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0 -w'); |
adfe19db |
219 | push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base}; |
220 | |
221 | # just to be sure |
222 | run(qw(make realclean)); |
223 | run($fullperl, "Makefile.PL", @mf_arg)->{status} == 0 |
224 | or die "cannot run Makefile.PL: $!\n"; |
225 | } |
226 | |
227 | sub regen_apicheck |
228 | { |
229 | unlink qw(apicheck.c apicheck.o); |
0c96388f |
230 | runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_) |
231 | or die "cannot regenerate apicheck.c\n"; |
adfe19db |
232 | } |
233 | |
234 | sub load_todo |
235 | { |
236 | my($file, $expver) = @_; |
237 | |
238 | if (-e $file) { |
239 | my $f = new IO::File $file or die "cannot open $file: $!\n"; |
240 | my $ver = <$f>; |
241 | chomp $ver; |
242 | if ($ver eq $expver) { |
243 | my %sym; |
244 | while (<$f>) { |
245 | chomp; |
246 | /^(\w+)\s+#\s+(.*)/ or goto nuke_file; |
247 | exists $sym{$1} and goto nuke_file; |
248 | $sym{$1} = $2; |
249 | } |
250 | return \%sym; |
251 | } |
252 | |
253 | nuke_file: |
254 | undef $f; |
255 | unlink $file or die "cannot remove $file: $!\n"; |
256 | } |
257 | |
258 | return {}; |
259 | } |
260 | |
261 | sub write_todo |
262 | { |
263 | my($file, $ver, $sym) = @_; |
264 | my $f; |
265 | |
266 | $f = new IO::File ">$file" or die "cannot open $file: $!\n"; |
267 | $f->print("$ver\n"); |
268 | |
269 | for (sort keys %$sym) { |
270 | $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_}); |
271 | } |
272 | } |
273 | |
ba120f6f |
274 | sub find_undefined_symbols |
275 | { |
276 | my($perl, $shlib) = @_; |
277 | |
278 | my $ps = read_sym(file => $perl, options => [qw( --defined-only )]); |
279 | my $ls = read_sym(file => $shlib, options => [qw( --undefined-only )]); |
280 | |
281 | my @undefined; |
282 | |
283 | for my $sym (keys %$ls) { |
284 | unless (exists $ps->{$sym}) { |
285 | if ($sym !~ /\@/ and $sym !~ /^_/) { |
286 | push @undefined, $sym; |
287 | } |
288 | } |
289 | } |
290 | |
291 | return @undefined; |
292 | } |
293 | |
294 | sub read_sym |
295 | { |
296 | my %opt = ( options => [], @_ ); |
297 | |
298 | my $r = run($Config{nm}, @{$opt{options}}, $opt{file}); |
299 | |
300 | if ($r->{didnotrun} or $r->{status}) { |
301 | die "cannot run $Config{nm}"; |
302 | } |
303 | |
304 | my %sym; |
305 | |
306 | for (@{$r->{stdout}}) { |
307 | chomp; |
308 | my($adr, $fmt, $sym) = /^\s*([[:xdigit:]]+)?\s+([ABCDGINRSTUVW?-])\s+(\S+)\s*$/i |
309 | or die "cannot parse $Config{nm} output:\n[$_]\n"; |
310 | $sym{$sym} = { format => $fmt }; |
311 | $sym{$sym}{address} = $adr if defined $adr; |
312 | } |
313 | |
314 | return \%sym; |
315 | } |
316 | |
317 | sub get_apicheck_symbol_map |
318 | { |
319 | my $r = run(qw(make apicheck.i)); |
320 | |
321 | if ($r->{didnotrun} or $r->{status}) { |
322 | die "cannot run make apicheck.i"; |
323 | } |
324 | |
325 | my $fh = IO::File->new('apicheck.i') |
326 | or die "cannot open apicheck.i: $!"; |
327 | |
328 | local $_; |
329 | my %symmap; |
330 | my $cur; |
331 | |
332 | while (<$fh>) { |
333 | next if /^#/; |
334 | if (defined $cur) { |
335 | for my $sym (/\b([A-Za-z_]\w+)\b/g) { |
336 | $symmap{$sym}{$cur}++; |
337 | } |
338 | undef $cur if /^}$/; |
339 | } |
340 | else { |
341 | /_DPPP_test_(\w+)/ and $cur = $1; |
342 | } |
343 | } |
344 | |
345 | return \%symmap; |
346 | } |