2 ################################################################################
4 # mktodo.pl -- generate baseline and todo files
6 ################################################################################
10 # $Date: 2009/01/18 14:10:51 +0100 $
12 ################################################################################
14 # Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
15 # Version 2.x, Copyright (C) 2001, Paul Marquess.
16 # Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
18 # This program is free software; you can redistribute it and/or
19 # modify it under the same terms as Perl itself.
21 ################################################################################
29 use Time::HiRes qw( gettimeofday tv_interval );
31 require 'devel/devtools.pl';
38 shlib => 'blib/arch/auto/Devel/PPPort/PPPort.so',
42 perl=s todo=s version=s shlib=s debug base verbose check!
47 print "\n", ident_str(), "\n\n";
49 my $fullperl = `which $opt{perl}`;
52 $ENV{SKIP_SLOW_TESTS} = 1;
57 for (`$Config{nm} $fullperl`) {
59 /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
61 keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
63 my %all = %{load_todo($opt{todo}, $opt{version})};
66 my $symmap = get_apicheck_symbol_map();
74 my(@new, @tmp, %seen);
76 my $r = run(qw(make));
77 $r->{didnotrun} and die "couldn't run make: $!\n";
79 for my $l (@{$r->{stderr}}) {
80 if ($l =~ /_DPPP_test_(\w+)/) {
82 my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1";
84 push @tmp, [$1, "E (@s)"];
93 if ($r->{status} == 0) {
98 @u = eval { find_undefined_symbols($fullperl, $opt{shlib}) };
99 warn "warning: $@" if $@;
104 $r = run(qw(make test));
105 $r->{didnotrun} and die "couldn't run make test: $!\n";
106 $r->{status} == 0 and last;
108 for my $l (@{$r->{stderr}}) {
109 if ($l =~ /undefined symbol: (\w+)/) {
116 for my $m (keys %{$symmap->{$u}}) {
119 $pl =~ s/^[Pp]erl_//;
120 my @s = grep { exists $sym{$_} } $pl, "Perl_$pl", "perl_$pl";
121 push @new, [$m, @s ? "U (@s)" : "U"];
127 @new = grep !$all{$_->[0]}, @new;
130 @new = grep !$all{$_->[0]}, @tmp;
140 die "no new TODO symbols found...";
143 # don't recheck undefined symbols reported by the dynamic linker
144 push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new;
148 $all{$_->[0]} = $_->[1];
151 write_todo($opt{todo}, $opt{version}, \%all);
155 my $ifmt = '%' . length(scalar @recheck) . 'd';
156 my $t0 = [gettimeofday];
158 RECHECK: for my $i (0 .. $#recheck) {
159 my $sym = $recheck[$i];
160 my $cur = delete $all{$sym};
162 sym('chk', $sym, $cur, sprintf(" [$ifmt/$ifmt, ETA %s]",
163 $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck)));
165 write_todo($opt{todo}, $opt{version}, \%all);
167 if ($cur eq "E (Perl_$sym)") {
168 # we can try a shortcut here
169 regen_apicheck($sym);
171 my $r = run(qw(make test));
173 if (!$r->{didnotrun} && $r->{status} == 0) {
174 sym('del', $sym, $cur);
182 my $r = run(qw(make test));
184 $r->{didnotrun} and die "couldn't run make test: $!\n";
186 if ($r->{status} == 0) {
187 sym('del', $sym, $cur);
195 write_todo($opt{todo}, $opt{version}, \%all);
197 run(qw(make realclean));
203 my($what, $sym, $reason, $extra) = @_;
207 'chk' => 'bold magenta',
208 'del' => 'bold green',
210 $what = colored("$what symbol", $col{$what});
212 printf "[%s] %s %-30s # %s%s\n",
213 $opt{version}, $what, $sym, $reason, $extra;
218 my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0 -w');
219 push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base};
222 run(qw(make realclean));
223 run($fullperl, "Makefile.PL", @mf_arg)->{status} == 0
224 or die "cannot run Makefile.PL: $!\n";
229 unlink qw(apicheck.c apicheck.o);
230 runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_)
231 or die "cannot regenerate apicheck.c\n";
236 my($file, $expver) = @_;
239 my $f = new IO::File $file or die "cannot open $file: $!\n";
242 if ($ver eq $expver) {
246 /^(\w+)\s+#\s+(.*)/ or goto nuke_file;
247 exists $sym{$1} and goto nuke_file;
255 unlink $file or die "cannot remove $file: $!\n";
263 my($file, $ver, $sym) = @_;
266 $f = new IO::File ">$file" or die "cannot open $file: $!\n";
269 for (sort keys %$sym) {
270 $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
274 sub find_undefined_symbols
276 my($perl, $shlib) = @_;
278 my $ps = read_sym(file => $perl, options => [qw( --defined-only )]);
279 my $ls = read_sym(file => $shlib, options => [qw( --undefined-only )]);
283 for my $sym (keys %$ls) {
284 unless (exists $ps->{$sym}) {
285 if ($sym !~ /\@/ and $sym !~ /^_/) {
286 push @undefined, $sym;
296 my %opt = ( options => [], @_ );
298 my $r = run($Config{nm}, @{$opt{options}}, $opt{file});
300 if ($r->{didnotrun} or $r->{status}) {
301 die "cannot run $Config{nm}";
306 for (@{$r->{stdout}}) {
308 my($adr, $fmt, $sym) = /^\s*([[:xdigit:]]+)?\s+([ABCDGINRSTUVW?-])\s+(\S+)\s*$/i
309 or die "cannot parse $Config{nm} output:\n[$_]\n";
310 $sym{$sym} = { format => $fmt };
311 $sym{$sym}{address} = $adr if defined $adr;
317 sub get_apicheck_symbol_map
319 my $r = run(qw(make apicheck.i));
321 if ($r->{didnotrun} or $r->{status}) {
322 die "cannot run make apicheck.i";
325 my $fh = IO::File->new('apicheck.i')
326 or die "cannot open apicheck.i: $!";
335 for my $sym (/\b([A-Za-z_]\w+)\b/g) {
336 $symmap{$sym}{$cur}++;
341 /_DPPP_test_(\w+)/ and $cur = $1;