This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
devel/mktodo: Add ability for multiple source dirs
[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   blead     => 0,     # ? Is this perl blead
29   debug   => 0,
30   base    => 0,
31   verbose => 0,
32   check   => 1,
33   todo    => "",    # If no --todo, this is a blead perl, and the make should
34                     # work without error
35   shlib   => 'blib/arch/auto/Devel/PPPort/PPPort.so',
36 );
37
38 GetOptions(\%opt, qw(
39 perl=s todo=s blead version=s shlib=s debug base verbose check!
40           )) or die;
41
42 identify();
43
44 print "\n", ident_str(), "\n\n";
45
46 my $fullperl = `which $opt{perl}`;
47 chomp $fullperl;
48
49 $ENV{SKIP_SLOW_TESTS} = 1;
50
51 regen_all();
52
53 my %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
69 my %sym;
70 for (`$Config{nm} $fullperl`) {
71   chomp;
72   /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
73 }
74 keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
75
76 my %all = %{load_todo($opt{todo}, $opt{version})} if $opt{todo};
77 my @recheck;
78
79 my $symmap = get_apicheck_symbol_map();
80
81 for (;;) {
82   my $retry = 1;
83   my $trynm = 1;
84   regen_apicheck();
85
86 retry:
87   my(@new, @tmp, %seen);
88
89   my $r = run(qw(make));
90   $r->{didnotrun} and die "couldn't run make: $!\n";
91
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
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     }
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         }
154       }
155     }
156   }
157
158   @new = grep !$all{$_->[0]}, @new;
159
160   unless (@new) {
161     @new = grep !$all{$_->[0]}, @tmp;
162   }
163
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   }
173
174   # don't recheck undefined symbols reported by the dynamic linker
175   push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new;
176
177   for (@new) {
178     sym('new', @$_);
179     $all{$_->[0]} = $_->[1];
180   }
181
182   write_todo($opt{todo}, $opt{version}, \%all);
183 }
184
185 if ($opt{check}) {
186   my $ifmt = '%' . length(scalar @recheck) . 'd';
187   my $t0 = [gettimeofday];
188
189   RECHECK: for my $i (0 .. $#recheck) {
190     my $sym = $recheck[$i];
191     my $cur = delete $all{$sym};
192
193     sym('chk', $sym, $cur, sprintf(" [$ifmt/$ifmt, ETA %s]",
194                $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck)));
195
196     write_todo($opt{todo}, $opt{version}, \%all);
197
198     if ($cur eq "E (Perl_$sym)") {
199       # we can try a shortcut here
200       regen_apicheck($sym);
201
202       my $r = run(qw(make test));
203
204       if (!$r->{didnotrun} && $r->{status} == 0) {
205         sym('del', $sym, $cur);
206         next RECHECK;
207       }
208     }
209
210     # run the full test
211     regen_all();
212
213     my $r = run(qw(make test));
214
215     $r->{didnotrun} and die "couldn't run make test: $!\n";
216
217     if ($r->{status} == 0) {
218       sym('del', $sym, $cur);
219     }
220     else {
221       $all{$sym} = $cur;
222     }
223   }
224 }
225
226 write_todo($opt{todo}, $opt{version}, \%all);
227
228 run(qw(make realclean));
229
230 exit 0;
231
232 sub 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
247 sub regen_all
248 {
249   my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0 -w');
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
258 sub regen_apicheck
259 {
260   unlink qw(apicheck.c apicheck.o);
261   runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_)
262       or die "cannot regenerate apicheck.c\n";
263 }
264
265 sub 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
284 nuke_file:
285     undef $f;
286     unlink $file or die "cannot remove $file: $!\n";
287   }
288
289   return {};
290 }
291
292 sub 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
300   # Dictionary ordering, with only alphanumerics
301   for (sort dictionary_order keys %$sym) {
302     $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
303   }
304 }
305
306 sub 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 !~ /^_/) {
318         push @undefined, $sym unless $stdsym{$sym};
319       }
320     }
321   }
322
323   return @undefined;
324 }
325
326 sub 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
349 sub get_apicheck_symbol_map
350 {
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) {
362       for my $s (sort dictionary_order keys %sym) {
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     }
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 }