This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perldelta - Remove all but one XXX notices
[perl5.git] / cpan / Devel-PPPort / devel / mktodo.pl
CommitLineData
adfe19db
MHM
1#!/usr/bin/perl -w
2################################################################################
3#
4# mktodo.pl -- generate baseline and todo files
5#
6################################################################################
7#
49ef49fe 8# $Revision: 18 $
adfe19db 9# $Author: mhx $
49ef49fe 10# $Date: 2011/04/13 09:38:10 +0200 $
adfe19db
MHM
11#
12################################################################################
13#
49ef49fe 14# Version 3.x, Copyright (C) 2004-2010, Marcus Holland-Moritz.
adfe19db
MHM
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
23use strict;
24use Getopt::Long;
25use Data::Dumper;
26use IO::File;
27use IO::Select;
ba120f6f 28use Config;
0c96388f 29use Time::HiRes qw( gettimeofday tv_interval );
adfe19db 30
0c96388f 31require 'devel/devtools.pl';
adfe19db 32
0c96388f
MHM
33our %opt = (
34 debug => 0,
35 base => 0,
36 verbose => 0,
ba120f6f
MHM
37 check => 1,
38 shlib => 'blib/arch/auto/Devel/PPPort/PPPort.so',
0c96388f 39);
adfe19db
MHM
40
41GetOptions(\%opt, qw(
ba120f6f 42 perl=s todo=s version=s shlib=s debug base verbose check!
adfe19db
MHM
43 )) or die;
44
0c96388f
MHM
45identify();
46
47print "\n", ident_str(), "\n\n";
48
adfe19db
MHM
49my $fullperl = `which $opt{perl}`;
50chomp $fullperl;
51
0c96388f
MHM
52$ENV{SKIP_SLOW_TESTS} = 1;
53
adfe19db
MHM
54regen_all();
55
56my %sym;
ba120f6f 57for (`$Config{nm} $fullperl`) {
adfe19db
MHM
58 chomp;
59 /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
60}
61keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
62
63my %all = %{load_todo($opt{todo}, $opt{version})};
64my @recheck;
65
ba120f6f
MHM
66my $symmap = get_apicheck_symbol_map();
67
adfe19db
MHM
68for (;;) {
69 my $retry = 1;
ba120f6f 70 my $trynm = 1;
adfe19db 71 regen_apicheck();
ba120f6f 72
adfe19db 73retry:
adfe19db 74 my(@new, @tmp, %seen);
ba120f6f
MHM
75
76 my $r = run(qw(make));
77 $r->{didnotrun} and die "couldn't run make: $!\n";
78
adfe19db
MHM
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
MHM
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
MHM
123 }
124 }
125 }
ba120f6f 126
adfe19db 127 @new = grep !$all{$_->[0]}, @new;
ba120f6f 128
adfe19db
MHM
129 unless (@new) {
130 @new = grep !$all{$_->[0]}, @tmp;
adfe19db 131 }
ba120f6f 132
adfe19db
MHM
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
MHM
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
MHM
148 $all{$_->[0]} = $_->[1];
149 }
0c96388f 150
adfe19db 151 write_todo($opt{todo}, $opt{version}, \%all);
ba120f6f 152}
0c96388f 153
ba120f6f
MHM
154if ($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
MHM
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
MHM
192 }
193}
194
195write_todo($opt{todo}, $opt{version}, \%all);
196
197run(qw(make realclean));
198
199exit 0;
200
ba120f6f
MHM
201sub 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
MHM
216sub regen_all
217{
ba120f6f 218 my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0 -w');
adfe19db
MHM
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
227sub regen_apicheck
228{
229 unlink qw(apicheck.c apicheck.o);
0c96388f
MHM
230 runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_)
231 or die "cannot regenerate apicheck.c\n";
adfe19db
MHM
232}
233
234sub 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
253nuke_file:
254 undef $f;
255 unlink $file or die "cannot remove $file: $!\n";
256 }
257
258 return {};
259}
260
261sub 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
MHM
274sub 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
294sub 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
317sub get_apicheck_symbol_map
318{
49ef49fe
CBW
319 my $r;
320
321 while (1) {
322 $r = run(qw(make apicheck.i));
323
324 last unless $r->{didnotrun} or $r->{status};
325
326 my %sym = map { /error: macro "(\w+)" (?:requires|passed) \d+ argument/ ? ($1 => 'A') : () }
327 @{$r->{stderr}};
328
329 if (keys %sym) {
330 for my $s (sort keys %sym) {
331 sym('new', $s, $sym{$s});
332 $all{$s} = $sym{$s};
333 }
334 write_todo($opt{todo}, $opt{version}, \%all);
335 regen_apicheck();
336 }
337 else {
338 die "cannot run make apicheck.i ($r->{didnotrun} / $r->{status}):\n".
339 join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
340 }
ba120f6f
MHM
341 }
342
343 my $fh = IO::File->new('apicheck.i')
344 or die "cannot open apicheck.i: $!";
345
346 local $_;
347 my %symmap;
348 my $cur;
349
350 while (<$fh>) {
351 next if /^#/;
352 if (defined $cur) {
353 for my $sym (/\b([A-Za-z_]\w+)\b/g) {
354 $symmap{$sym}{$cur}++;
355 }
356 undef $cur if /^}$/;
357 }
358 else {
359 /_DPPP_test_(\w+)/ and $cur = $1;
360 }
361 }
362
363 return \%symmap;
364}