This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
e3cd3a3237f0acb598618c2acfb3ae0a80ab1f44
[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
34   shlib   => 'blib/arch/auto/Devel/PPPort/PPPort.so',
35 );
36
37 GetOptions(\%opt, qw(
38 perl=s todo=s blead version=s shlib=s debug base verbose check!
39           )) or die;
40
41 identify();
42
43 print "\n", ident_str(), "\n\n";
44
45 my $fullperl = `which $opt{perl}`;
46 chomp $fullperl;
47
48 $ENV{SKIP_SLOW_TESTS} = 1;
49
50 regen_Makefile();
51
52 my %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
68 my %sym;
69 for (`$Config{nm} $fullperl`) {
70   chomp;
71   /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
72 }
73 keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
74
75 my %todo = %{load_todo($opt{todo}, $opt{version})} if $opt{todo};
76 my @recheck;
77
78 my $symmap = get_apicheck_symbol_map();
79
80 for (;;) {
81   my $retry = 1;
82   my $trynm = 1;
83   regen_apicheck();
84
85 retry:
86   my(@new, @already_in_sym, %seen);
87
88   my $r = run(qw(make));
89   $r->{didnotrun} and die "couldn't run make: $!\n" .
90         join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
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 @already_in_sym, [$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         join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
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         }
155       }
156     }
157   }
158
159   @new = grep !$todo{$_->[0]}, @new;
160
161   unless (@new) {
162     @new = grep !$todo{$_->[0]}, @already_in_sym;
163   }
164
165   unless (@new) {
166     if ($retry > 0) {
167       $retry--;
168       regen_Makefile();
169       goto retry;
170     }
171     print Dumper($r);
172     die "no new TODO symbols found...";
173   }
174
175   # don't recheck undefined symbols reported by the dynamic linker
176   push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new;
177
178   for (@new) {
179     display_sym('new', @$_);
180     $todo{$_->[0]} = $_->[1];
181   }
182
183   write_todo($opt{todo}, $opt{version}, \%todo);
184 }
185
186 if ($opt{check}) {
187   my $ifmt = '%' . length(scalar @recheck) . 'd';
188   my $t0 = [gettimeofday];
189
190   RECHECK: for my $i (0 .. $#recheck) {
191     my $sym = $recheck[$i];
192     my $cur = delete $todo{$sym};
193
194     display_sym('chk', $sym, $cur, sprintf(" [$ifmt/$ifmt, ETA %s]",
195                $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck)));
196
197     write_todo($opt{todo}, $opt{version}, \%todo);
198
199     if ($cur eq "E (Perl_$sym)") {
200       # we can try a shortcut here
201       regen_apicheck($sym);
202
203       my $r = run(qw(make test));
204
205       if (!$r->{didnotrun} && $r->{status} == 0) {
206         display_sym('del', $sym, $cur);
207         next RECHECK;
208       }
209     }
210
211     # run the full test
212     regen_Makefile();
213
214     my $r = run(qw(make test));
215
216     # This regenerated apicheck.c
217     dump_apicheck() if $opt{debug};
218
219     $r->{didnotrun} and die "couldn't run make test: $!\n" .
220         join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
221
222     if ($r->{status} == 0) {
223       display_sym('del', $sym, $cur);
224     }
225     else {
226       $todo{$sym} = $cur;
227     }
228   }
229 }
230
231 write_todo($opt{todo}, $opt{version}, \%todo);
232
233 run(qw(make realclean));
234
235 exit 0;
236
237 sub display_sym
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
252 sub regen_Makefile
253 {
254   my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0 -w');
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));
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   }
264 }
265
266 sub regen_apicheck
267 {
268   unlink qw(apicheck.c apicheck.o);
269   runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_)
270       or die "cannot regenerate apicheck.c\n";
271   dump_apicheck() if $opt{debug};
272 }
273
274 sub 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;
288 }
289
290 sub 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
309 nuke_file:
310     undef $f;
311     unlink $file or die "cannot remove $file: $!\n";
312   }
313
314   return {};
315 }
316
317 sub 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
325   # Dictionary ordering, with only alphanumerics
326   for (sort dictionary_order keys %$sym) {
327     $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
328   }
329 }
330
331 sub 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) {
341     next if $sym =~ /\@/ or $sym =~ /^_/ or exists $stdsym{$sym};
342     unless (exists $ps->{$sym}) {
343         push @undefined, $sym;
344     }
345   }
346
347   return @undefined;
348 }
349
350 sub 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}) {
357     die "cannot run $Config{nm}" .
358           join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
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
374 sub get_apicheck_symbol_map
375 {
376   my $r;
377
378   while (1) {
379
380     # Create apicheck.i
381     $r = run(qw(make apicheck.i));
382
383     # Quit the loop if it succeeded
384     last unless $r->{didnotrun} or $r->{status};
385
386     # Get the list of macros that it failed on
387     my %sym = map { /error: macro "(\w+)" (?:requires|passed) \d+ argument/ ? ($1 => 'A') : () }
388               @{$r->{stderr}};
389
390     if (keys %sym) {
391       for my $s (sort dictionary_order keys %sym) {
392         display_sym('new', $s, $sym{$s});
393         $todo{$s} = $sym{$s};
394       }
395       write_todo($opt{todo}, $opt{version}, \%todo);
396       regen_apicheck();
397     }
398     else {  # It failed for some other reason: give up
399       die "cannot run make apicheck.i ($r->{didnotrun} / $r->{status}):\n".
400           join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
401     }
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 /^#/;
413
414     if (! defined $cur) {
415       /_DPPP_test_(\w+)/ and $cur = $1;
416     }
417     else {
418       for my $sym (/\b([A-Za-z_]\w+)\b/g) {
419         $symmap{$sym}{$cur}++;
420       }
421       undef $cur if /^}$/;
422     }
423   }
424
425   return \%symmap;
426 }