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