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