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
17use strict;
18use Getopt::Long;
19use Data::Dumper;
20use IO::File;
21use IO::Select;
22use Config;
23use Time::HiRes qw( gettimeofday tv_interval );
24
25require './devel/devtools.pl';
26
27our %opt = (
28  debug   => 0,
29  base    => 0,
30  verbose => 0,
31  check   => 1,
32  shlib   => 'blib/arch/auto/Devel/PPPort/PPPort.so',
33);
34
35GetOptions(\%opt, qw(
36            perl=s todo=s version=s shlib=s debug base verbose check!
37          )) or die;
38
39identify();
40
41print "\n", ident_str(), "\n\n";
42
43my $fullperl = `which $opt{perl}`;
44chomp $fullperl;
45
46$ENV{SKIP_SLOW_TESTS} = 1;
47
48regen_all();
49
50my %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
66my %sym;
67for (`$Config{nm} $fullperl`) {
68  chomp;
69  /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
70}
71keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
72
73my %all = %{load_todo($opt{todo}, $opt{version})};
74my @recheck;
75
76my $symmap = get_apicheck_symbol_map();
77
78for (;;) {
79  my $retry = 1;
80  my $trynm = 1;
81  regen_apicheck();
82
83retry:
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
164if ($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
205write_todo($opt{todo}, $opt{version}, \%all);
206
207run(qw(make realclean));
208
209exit 0;
210
211sub 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
226sub 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
237sub 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
244sub 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
263nuke_file:
264    undef $f;
265    unlink $file or die "cannot remove $file: $!\n";
266  }
267
268  return {};
269}
270
271sub 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
284sub 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
304sub 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
327sub 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}
375