This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
mv Devel-PPPort from cpan to dist
[perl5.git] / dist / Devel-PPPort / devel / mktodo.pl
1 #!/usr/bin/perl -w
2 ################################################################################
3 #
4 #  mktodo.pl -- generate baseline and todo files
5 #
6 ################################################################################
7 #
8 #  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
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
17 use strict;
18 use Getopt::Long;
19 use Data::Dumper;
20 use IO::File;
21 use IO::Select;
22 use Config;
23 use Time::HiRes qw( gettimeofday tv_interval );
24
25 require './devel/devtools.pl';
26
27 our %opt = (
28   debug   => 0,
29   base    => 0,
30   verbose => 0,
31   check   => 1,
32   shlib   => 'blib/arch/auto/Devel/PPPort/PPPort.so',
33 );
34
35 GetOptions(\%opt, qw(
36             perl=s todo=s version=s shlib=s debug base verbose check!
37           )) or die;
38
39 identify();
40
41 print "\n", ident_str(), "\n\n";
42
43 my $fullperl = `which $opt{perl}`;
44 chomp $fullperl;
45
46 $ENV{SKIP_SLOW_TESTS} = 1;
47
48 regen_all();
49
50 my %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
66 my %sym;
67 for (`$Config{nm} $fullperl`) {
68   chomp;
69   /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
70 }
71 keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
72
73 my %all = %{load_todo($opt{todo}, $opt{version})};
74 my @recheck;
75
76 my $symmap = get_apicheck_symbol_map();
77
78 for (;;) {
79   my $retry = 1;
80   my $trynm = 1;
81   regen_apicheck();
82
83 retry:
84   my(@new, @tmp, %seen);
85
86   my $r = run(qw(make));
87   $r->{didnotrun} and die "couldn't run make: $!\n";
88
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     }
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         }
133       }
134     }
135   }
136
137   @new = grep !$all{$_->[0]}, @new;
138
139   unless (@new) {
140     @new = grep !$all{$_->[0]}, @tmp;
141   }
142
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   }
152
153   # don't recheck undefined symbols reported by the dynamic linker
154   push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new;
155
156   for (@new) {
157     sym('new', @$_);
158     $all{$_->[0]} = $_->[1];
159   }
160
161   write_todo($opt{todo}, $opt{version}, \%all);
162 }
163
164 if ($opt{check}) {
165   my $ifmt = '%' . length(scalar @recheck) . 'd';
166   my $t0 = [gettimeofday];
167
168   RECHECK: for my $i (0 .. $#recheck) {
169     my $sym = $recheck[$i];
170     my $cur = delete $all{$sym};
171
172     sym('chk', $sym, $cur, sprintf(" [$ifmt/$ifmt, ETA %s]",
173                $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck)));
174
175     write_todo($opt{todo}, $opt{version}, \%all);
176
177     if ($cur eq "E (Perl_$sym)") {
178       # we can try a shortcut here
179       regen_apicheck($sym);
180
181       my $r = run(qw(make test));
182
183       if (!$r->{didnotrun} && $r->{status} == 0) {
184         sym('del', $sym, $cur);
185         next RECHECK;
186       }
187     }
188
189     # run the full test
190     regen_all();
191
192     my $r = run(qw(make test));
193
194     $r->{didnotrun} and die "couldn't run make test: $!\n";
195
196     if ($r->{status} == 0) {
197       sym('del', $sym, $cur);
198     }
199     else {
200       $all{$sym} = $cur;
201     }
202   }
203 }
204
205 write_todo($opt{todo}, $opt{version}, \%all);
206
207 run(qw(make realclean));
208
209 exit 0;
210
211 sub 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
226 sub regen_all
227 {
228   my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0 -w');
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
237 sub regen_apicheck
238 {
239   unlink qw(apicheck.c apicheck.o);
240   runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_)
241       or die "cannot regenerate apicheck.c\n";
242 }
243
244 sub 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
263 nuke_file:
264     undef $f;
265     unlink $file or die "cannot remove $file: $!\n";
266   }
267
268   return {};
269 }
270
271 sub 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
279   for (sort keys %$sym) {
280     $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
281   }
282 }
283
284 sub find_undefined_symbols
285 {
286   my($perl, $shlib) = @_;
287
288   my $ps = read_sym(file => $perl,  options => [qw( --defined-only   )]);
289   my $ls = read_sym(file => $shlib, options => [qw( --undefined-only )]);
290
291   my @undefined;
292
293   for my $sym (keys %$ls) {
294     unless (exists $ps->{$sym}) {
295       if ($sym !~ /\@/ and $sym !~ /^_/) {
296         push @undefined, $sym unless $stdsym{$sym};
297       }
298     }
299   }
300
301   return @undefined;
302 }
303
304 sub read_sym
305 {
306   my %opt = ( options => [], @_ );
307
308   my $r = run($Config{nm}, @{$opt{options}}, $opt{file});
309
310   if ($r->{didnotrun} or $r->{status}) {
311     die "cannot run $Config{nm}";
312   }
313
314   my %sym;
315
316   for (@{$r->{stdout}}) {
317     chomp;
318     my($adr, $fmt, $sym) = /^\s*([[:xdigit:]]+)?\s+([ABCDGINRSTUVW?-])\s+(\S+)\s*$/i
319                            or die "cannot parse $Config{nm} output:\n[$_]\n";
320     $sym{$sym} = { format => $fmt };
321     $sym{$sym}{address} = $adr if defined $adr;
322   }
323
324   return \%sym;
325 }
326
327 sub get_apicheck_symbol_map
328 {
329   my $r;
330
331   while (1) {
332     $r = run(qw(make apicheck.i));
333
334     last unless $r->{didnotrun} or $r->{status};
335
336     my %sym = map { /error: macro "(\w+)" (?:requires|passed) \d+ argument/ ? ($1 => 'A') : () }
337               @{$r->{stderr}};
338
339     if (keys %sym) {
340       for my $s (sort keys %sym) {
341         sym('new', $s, $sym{$s});
342         $all{$s} = $sym{$s};
343       }
344       write_todo($opt{todo}, $opt{version}, \%all);
345       regen_apicheck();
346     }
347     else {
348       die "cannot run make apicheck.i ($r->{didnotrun} / $r->{status}):\n".
349           join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
350     }
351   }
352
353   my $fh = IO::File->new('apicheck.i')
354            or die "cannot open apicheck.i: $!";
355
356   local $_;
357   my %symmap;
358   my $cur;
359
360   while (<$fh>) {
361     next if /^#/;
362     if (defined $cur) {
363       for my $sym (/\b([A-Za-z_]\w+)\b/g) {
364         $symmap{$sym}{$cur}++;
365       }
366       undef $cur if /^}$/;
367     }
368     else {
369       /_DPPP_test_(\w+)/ and $cur = $1;
370     }
371   }
372
373   return \%symmap;
374 }