This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
devel/mktodo.pl: Reorder else clauses
[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,
f59197b8 33 todo => "", # If no --todo, this is a blead perl
ba120f6f 34 shlib => 'blib/arch/auto/Devel/PPPort/PPPort.so',
0c96388f 35);
adfe19db
MHM
36
37GetOptions(\%opt, qw(
ac18778d 38perl=s todo=s blead version=s shlib=s debug base verbose check!
adfe19db
MHM
39 )) or die;
40
0c96388f
MHM
41identify();
42
43print "\n", ident_str(), "\n\n";
44
adfe19db
MHM
45my $fullperl = `which $opt{perl}`;
46chomp $fullperl;
47
0c96388f
MHM
48$ENV{SKIP_SLOW_TESTS} = 1;
49
c0a15b19 50regen_Makefile();
adfe19db 51
b2049988
MHM
52my %stdsym = map { ($_ => 1) } qw (
53 strlen
54 snprintf
55 strcmp
56 memcpy
57 strncmp
58 memmove
59 memcmp
60 tolower
61 exit
62 memset
63 vsnprintf
64 siglongjmp
65 sprintf
66);
67
adfe19db 68my %sym;
ba120f6f 69for (`$Config{nm} $fullperl`) {
adfe19db
MHM
70 chomp;
71 /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
72}
73keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
74
c0a15b19 75my %todo = %{load_todo($opt{todo}, $opt{version})} if $opt{todo};
adfe19db
MHM
76my @recheck;
77
ba120f6f
MHM
78my $symmap = get_apicheck_symbol_map();
79
adfe19db
MHM
80for (;;) {
81 my $retry = 1;
ba120f6f 82 my $trynm = 1;
adfe19db 83 regen_apicheck();
ba120f6f 84
adfe19db 85retry:
c0a15b19 86 my(@new, @already_in_sym, %seen);
ba120f6f
MHM
87
88 my $r = run(qw(make));
f59197b8
KW
89 $r->{didnotrun} and die "couldn't run make: $!\n" .
90 join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
ba120f6f 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) {
c0a15b19 115 push @already_in_sym, [$1, "E (@s)"];
adfe19db
MHM
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));
f59197b8
KW
136 $r->{didnotrun} and die "couldn't run make test: $!\n" .
137 join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
ba120f6f
MHM
138 $r->{status} == 0 and last;
139
140 for my $l (@{$r->{stderr}}) {
141 if ($l =~ /undefined symbol: (\w+)/) {
142 push @u, $1;
143 }
144 }
145 }
146
147 for my $u (@u) {
148 for my $m (keys %{$symmap->{$u}}) {
149 if (!$seen{$m}++) {
150 my $pl = $m;
151 $pl =~ s/^[Pp]erl_//;
152 my @s = grep { exists $sym{$_} } $pl, "Perl_$pl", "perl_$pl";
153 push @new, [$m, @s ? "U (@s)" : "U"];
154 }
adfe19db
MHM
155 }
156 }
157 }
ba120f6f 158
c0a15b19 159 @new = grep !$todo{$_->[0]}, @new;
ba120f6f 160
adfe19db 161 unless (@new) {
c0a15b19 162 @new = grep !$todo{$_->[0]}, @already_in_sym;
adfe19db 163 }
ba120f6f 164
adfe19db
MHM
165 unless (@new) {
166 if ($retry > 0) {
167 $retry--;
c0a15b19 168 regen_Makefile();
adfe19db
MHM
169 goto retry;
170 }
171 print Dumper($r);
172 die "no new TODO symbols found...";
173 }
ba120f6f 174
0c96388f
MHM
175 # don't recheck undefined symbols reported by the dynamic linker
176 push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new;
ba120f6f 177
adfe19db 178 for (@new) {
c0a15b19
KW
179 display_sym('new', @$_);
180 $todo{$_->[0]} = $_->[1];
adfe19db 181 }
0c96388f 182
c0a15b19 183 write_todo($opt{todo}, $opt{version}, \%todo);
ba120f6f 184}
0c96388f 185
ba120f6f
MHM
186if ($opt{check}) {
187 my $ifmt = '%' . length(scalar @recheck) . 'd';
188 my $t0 = [gettimeofday];
b2049988 189
ba120f6f
MHM
190 RECHECK: for my $i (0 .. $#recheck) {
191 my $sym = $recheck[$i];
c0a15b19 192 my $cur = delete $todo{$sym};
b2049988 193
c0a15b19 194 display_sym('chk', $sym, $cur, sprintf(" [$ifmt/$ifmt, ETA %s]",
ba120f6f 195 $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck)));
b2049988 196
c0a15b19 197 write_todo($opt{todo}, $opt{version}, \%todo);
b2049988 198
ba120f6f
MHM
199 if ($cur eq "E (Perl_$sym)") {
200 # we can try a shortcut here
201 regen_apicheck($sym);
b2049988 202
ba120f6f 203 my $r = run(qw(make test));
b2049988 204
ba120f6f 205 if (!$r->{didnotrun} && $r->{status} == 0) {
c0a15b19 206 display_sym('del', $sym, $cur);
ba120f6f
MHM
207 next RECHECK;
208 }
209 }
b2049988 210
ba120f6f 211 # run the full test
c0a15b19 212 regen_Makefile();
b2049988 213
0c96388f 214 my $r = run(qw(make test));
b2049988 215
9251f208
KW
216 # This regenerated apicheck.c
217 dump_apicheck() if $opt{debug};
218
f59197b8
KW
219 $r->{didnotrun} and die "couldn't run make test: $!\n" .
220 join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
b2049988 221
ba120f6f 222 if ($r->{status} == 0) {
c0a15b19 223 display_sym('del', $sym, $cur);
ba120f6f
MHM
224 }
225 else {
c0a15b19 226 $todo{$sym} = $cur;
0c96388f 227 }
adfe19db
MHM
228 }
229}
230
c0a15b19 231write_todo($opt{todo}, $opt{version}, \%todo);
adfe19db
MHM
232
233run(qw(make realclean));
234
235exit 0;
236
c0a15b19 237sub display_sym
ba120f6f
MHM
238{
239 my($what, $sym, $reason, $extra) = @_;
240 $extra ||= '';
241 my %col = (
242 'new' => 'bold red',
243 'chk' => 'bold magenta',
244 'del' => 'bold green',
245 );
246 $what = colored("$what symbol", $col{$what});
247
248 printf "[%s] %s %-30s # %s%s\n",
249 $opt{version}, $what, $sym, $reason, $extra;
250}
251
c0a15b19 252sub regen_Makefile
adfe19db 253{
ba120f6f 254 my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0 -w');
adfe19db
MHM
255 push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base};
256
257 # just to be sure
258 run(qw(make realclean));
f59197b8
KW
259 my $r = run($fullperl, "Makefile.PL", @mf_arg);
260 unless ($r->{status} == 0) {
261 die "cannot run Makefile.PL: $!\n" .
262 join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
263 }
adfe19db
MHM
264}
265
266sub regen_apicheck
267{
268 unlink qw(apicheck.c apicheck.o);
0c96388f
MHM
269 runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_)
270 or die "cannot regenerate apicheck.c\n";
9251f208
KW
271 dump_apicheck() if $opt{debug};
272}
273
274sub dump_apicheck
275{
276 my $apicheck = "apicheck.c";
277 my $f = new IO::File $apicheck or die "cannot open $apicheck: $!\n";
278 my @lines = <$f>;
279 print STDERR __FILE__, ": ", __LINE__, ": $apicheck (",
280 scalar @lines,
281 " lines) for $fullperl";
282 print STDERR " and '" if @_;
283 print STDERR join "', '", @_;
284 print STDERR "'" if @_;
285 print STDERR ":\n";
286 my $n = 1;
287 print STDERR $n++, " ", $_ for @lines;
adfe19db
MHM
288}
289
290sub load_todo
291{
292 my($file, $expver) = @_;
293
294 if (-e $file) {
295 my $f = new IO::File $file or die "cannot open $file: $!\n";
296 my $ver = <$f>;
297 chomp $ver;
298 if ($ver eq $expver) {
299 my %sym;
300 while (<$f>) {
301 chomp;
302 /^(\w+)\s+#\s+(.*)/ or goto nuke_file;
303 exists $sym{$1} and goto nuke_file;
304 $sym{$1} = $2;
305 }
306 return \%sym;
307 }
308
309nuke_file:
310 undef $f;
311 unlink $file or die "cannot remove $file: $!\n";
312 }
313
314 return {};
315}
316
317sub write_todo
318{
319 my($file, $ver, $sym) = @_;
320 my $f;
321
322 $f = new IO::File ">$file" or die "cannot open $file: $!\n";
323 $f->print("$ver\n");
324
55179e46
KW
325 # Dictionary ordering, with only alphanumerics
326 for (sort dictionary_order keys %$sym) {
adfe19db
MHM
327 $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
328 }
329}
330
ba120f6f
MHM
331sub find_undefined_symbols
332{
333 my($perl, $shlib) = @_;
334
335 my $ps = read_sym(file => $perl, options => [qw( --defined-only )]);
336 my $ls = read_sym(file => $shlib, options => [qw( --undefined-only )]);
337
338 my @undefined;
339
340 for my $sym (keys %$ls) {
0d2a8114 341 next if $sym =~ /\@/ or $sym =~ /^_/ or exists $stdsym{$sym};
ba120f6f 342 unless (exists $ps->{$sym}) {
0d2a8114 343 push @undefined, $sym;
ba120f6f
MHM
344 }
345 }
346
347 return @undefined;
348}
349
350sub read_sym
351{
352 my %opt = ( options => [], @_ );
353
354 my $r = run($Config{nm}, @{$opt{options}}, $opt{file});
355
356 if ($r->{didnotrun} or $r->{status}) {
f59197b8
KW
357 die "cannot run $Config{nm}" .
358 join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
ba120f6f
MHM
359 }
360
361 my %sym;
362
363 for (@{$r->{stdout}}) {
364 chomp;
365 my($adr, $fmt, $sym) = /^\s*([[:xdigit:]]+)?\s+([ABCDGINRSTUVW?-])\s+(\S+)\s*$/i
366 or die "cannot parse $Config{nm} output:\n[$_]\n";
367 $sym{$sym} = { format => $fmt };
368 $sym{$sym}{address} = $adr if defined $adr;
369 }
370
371 return \%sym;
372}
373
374sub get_apicheck_symbol_map
375{
49ef49fe
CBW
376 my $r;
377
378 while (1) {
f59197b8
KW
379
380 # Create apicheck.i
49ef49fe
CBW
381 $r = run(qw(make apicheck.i));
382
f59197b8 383 # Quit the loop if it succeeded
49ef49fe
CBW
384 last unless $r->{didnotrun} or $r->{status};
385
f59197b8 386 # Get the list of macros that it failed on
49ef49fe
CBW
387 my %sym = map { /error: macro "(\w+)" (?:requires|passed) \d+ argument/ ? ($1 => 'A') : () }
388 @{$r->{stderr}};
389
390 if (keys %sym) {
55179e46 391 for my $s (sort dictionary_order keys %sym) {
c0a15b19
KW
392 display_sym('new', $s, $sym{$s});
393 $todo{$s} = $sym{$s};
49ef49fe 394 }
c0a15b19 395 write_todo($opt{todo}, $opt{version}, \%todo);
49ef49fe
CBW
396 regen_apicheck();
397 }
f59197b8 398 else { # It failed for some other reason: give up
49ef49fe
CBW
399 die "cannot run make apicheck.i ($r->{didnotrun} / $r->{status}):\n".
400 join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
401 }
ba120f6f
MHM
402 }
403
404 my $fh = IO::File->new('apicheck.i')
405 or die "cannot open apicheck.i: $!";
406
407 local $_;
408 my %symmap;
409 my $cur;
410
411 while (<$fh>) {
412 next if /^#/;
e49c33df
KW
413
414 if (! defined $cur) {
415 /_DPPP_test_(\w+)/ and $cur = $1;
416 }
417 else {
ba120f6f
MHM
418 for my $sym (/\b([A-Za-z_]\w+)\b/g) {
419 $symmap{$sym}{$cur}++;
420 }
421 undef $cur if /^}$/;
422 }
ba120f6f
MHM
423 }
424
425 return \%symmap;
426}