| 1 | #!/usr/bin/perl -w |
| 2 | ################################################################################ |
| 3 | # |
| 4 | # mktodo.pl -- generate baseline and todo files |
| 5 | # |
| 6 | ################################################################################ |
| 7 | # |
| 8 | # $Revision: 18 $ |
| 9 | # $Author: mhx $ |
| 10 | # $Date: 2011/04/13 09:38:10 +0200 $ |
| 11 | # |
| 12 | ################################################################################ |
| 13 | # |
| 14 | # Version 3.x, Copyright (C) 2004-2010, Marcus Holland-Moritz. |
| 15 | # Version 2.x, Copyright (C) 2001, Paul Marquess. |
| 16 | # Version 1.x, Copyright (C) 1999, Kenneth Albanowski. |
| 17 | # |
| 18 | # This program is free software; you can redistribute it and/or |
| 19 | # modify it under the same terms as Perl itself. |
| 20 | # |
| 21 | ################################################################################ |
| 22 | |
| 23 | use strict; |
| 24 | use Getopt::Long; |
| 25 | use Data::Dumper; |
| 26 | use IO::File; |
| 27 | use IO::Select; |
| 28 | use Config; |
| 29 | use Time::HiRes qw( gettimeofday tv_interval ); |
| 30 | |
| 31 | require 'devel/devtools.pl'; |
| 32 | |
| 33 | our %opt = ( |
| 34 | debug => 0, |
| 35 | base => 0, |
| 36 | verbose => 0, |
| 37 | check => 1, |
| 38 | shlib => 'blib/arch/auto/Devel/PPPort/PPPort.so', |
| 39 | ); |
| 40 | |
| 41 | GetOptions(\%opt, qw( |
| 42 | perl=s todo=s version=s shlib=s debug base verbose check! |
| 43 | )) or die; |
| 44 | |
| 45 | identify(); |
| 46 | |
| 47 | print "\n", ident_str(), "\n\n"; |
| 48 | |
| 49 | my $fullperl = `which $opt{perl}`; |
| 50 | chomp $fullperl; |
| 51 | |
| 52 | $ENV{SKIP_SLOW_TESTS} = 1; |
| 53 | |
| 54 | regen_all(); |
| 55 | |
| 56 | my %sym; |
| 57 | for (`$Config{nm} $fullperl`) { |
| 58 | chomp; |
| 59 | /\s+T\s+(\w+)\s*$/ and $sym{$1}++; |
| 60 | } |
| 61 | keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n"; |
| 62 | |
| 63 | my %all = %{load_todo($opt{todo}, $opt{version})}; |
| 64 | my @recheck; |
| 65 | |
| 66 | my $symmap = get_apicheck_symbol_map(); |
| 67 | |
| 68 | for (;;) { |
| 69 | my $retry = 1; |
| 70 | my $trynm = 1; |
| 71 | regen_apicheck(); |
| 72 | |
| 73 | retry: |
| 74 | my(@new, @tmp, %seen); |
| 75 | |
| 76 | my $r = run(qw(make)); |
| 77 | $r->{didnotrun} and die "couldn't run make: $!\n"; |
| 78 | |
| 79 | for my $l (@{$r->{stderr}}) { |
| 80 | if ($l =~ /_DPPP_test_(\w+)/) { |
| 81 | if (!$seen{$1}++) { |
| 82 | my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1"; |
| 83 | if (@s) { |
| 84 | push @tmp, [$1, "E (@s)"]; |
| 85 | } |
| 86 | else { |
| 87 | push @new, [$1, "E"]; |
| 88 | } |
| 89 | } |
| 90 | } |
| 91 | } |
| 92 | |
| 93 | if ($r->{status} == 0) { |
| 94 | my @u; |
| 95 | my @usym; |
| 96 | |
| 97 | if ($trynm) { |
| 98 | @u = eval { find_undefined_symbols($fullperl, $opt{shlib}) }; |
| 99 | warn "warning: $@" if $@; |
| 100 | $trynm = 0; |
| 101 | } |
| 102 | |
| 103 | unless (@u) { |
| 104 | $r = run(qw(make test)); |
| 105 | $r->{didnotrun} and die "couldn't run make test: $!\n"; |
| 106 | $r->{status} == 0 and last; |
| 107 | |
| 108 | for my $l (@{$r->{stderr}}) { |
| 109 | if ($l =~ /undefined symbol: (\w+)/) { |
| 110 | push @u, $1; |
| 111 | } |
| 112 | } |
| 113 | } |
| 114 | |
| 115 | for my $u (@u) { |
| 116 | for my $m (keys %{$symmap->{$u}}) { |
| 117 | if (!$seen{$m}++) { |
| 118 | my $pl = $m; |
| 119 | $pl =~ s/^[Pp]erl_//; |
| 120 | my @s = grep { exists $sym{$_} } $pl, "Perl_$pl", "perl_$pl"; |
| 121 | push @new, [$m, @s ? "U (@s)" : "U"]; |
| 122 | } |
| 123 | } |
| 124 | } |
| 125 | } |
| 126 | |
| 127 | @new = grep !$all{$_->[0]}, @new; |
| 128 | |
| 129 | unless (@new) { |
| 130 | @new = grep !$all{$_->[0]}, @tmp; |
| 131 | } |
| 132 | |
| 133 | unless (@new) { |
| 134 | if ($retry > 0) { |
| 135 | $retry--; |
| 136 | regen_all(); |
| 137 | goto retry; |
| 138 | } |
| 139 | print Dumper($r); |
| 140 | die "no new TODO symbols found..."; |
| 141 | } |
| 142 | |
| 143 | # don't recheck undefined symbols reported by the dynamic linker |
| 144 | push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new; |
| 145 | |
| 146 | for (@new) { |
| 147 | sym('new', @$_); |
| 148 | $all{$_->[0]} = $_->[1]; |
| 149 | } |
| 150 | |
| 151 | write_todo($opt{todo}, $opt{version}, \%all); |
| 152 | } |
| 153 | |
| 154 | if ($opt{check}) { |
| 155 | my $ifmt = '%' . length(scalar @recheck) . 'd'; |
| 156 | my $t0 = [gettimeofday]; |
| 157 | |
| 158 | RECHECK: for my $i (0 .. $#recheck) { |
| 159 | my $sym = $recheck[$i]; |
| 160 | my $cur = delete $all{$sym}; |
| 161 | |
| 162 | sym('chk', $sym, $cur, sprintf(" [$ifmt/$ifmt, ETA %s]", |
| 163 | $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck))); |
| 164 | |
| 165 | write_todo($opt{todo}, $opt{version}, \%all); |
| 166 | |
| 167 | if ($cur eq "E (Perl_$sym)") { |
| 168 | # we can try a shortcut here |
| 169 | regen_apicheck($sym); |
| 170 | |
| 171 | my $r = run(qw(make test)); |
| 172 | |
| 173 | if (!$r->{didnotrun} && $r->{status} == 0) { |
| 174 | sym('del', $sym, $cur); |
| 175 | next RECHECK; |
| 176 | } |
| 177 | } |
| 178 | |
| 179 | # run the full test |
| 180 | regen_all(); |
| 181 | |
| 182 | my $r = run(qw(make test)); |
| 183 | |
| 184 | $r->{didnotrun} and die "couldn't run make test: $!\n"; |
| 185 | |
| 186 | if ($r->{status} == 0) { |
| 187 | sym('del', $sym, $cur); |
| 188 | } |
| 189 | else { |
| 190 | $all{$sym} = $cur; |
| 191 | } |
| 192 | } |
| 193 | } |
| 194 | |
| 195 | write_todo($opt{todo}, $opt{version}, \%all); |
| 196 | |
| 197 | run(qw(make realclean)); |
| 198 | |
| 199 | exit 0; |
| 200 | |
| 201 | sub sym |
| 202 | { |
| 203 | my($what, $sym, $reason, $extra) = @_; |
| 204 | $extra ||= ''; |
| 205 | my %col = ( |
| 206 | 'new' => 'bold red', |
| 207 | 'chk' => 'bold magenta', |
| 208 | 'del' => 'bold green', |
| 209 | ); |
| 210 | $what = colored("$what symbol", $col{$what}); |
| 211 | |
| 212 | printf "[%s] %s %-30s # %s%s\n", |
| 213 | $opt{version}, $what, $sym, $reason, $extra; |
| 214 | } |
| 215 | |
| 216 | sub regen_all |
| 217 | { |
| 218 | my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0 -w'); |
| 219 | push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base}; |
| 220 | |
| 221 | # just to be sure |
| 222 | run(qw(make realclean)); |
| 223 | run($fullperl, "Makefile.PL", @mf_arg)->{status} == 0 |
| 224 | or die "cannot run Makefile.PL: $!\n"; |
| 225 | } |
| 226 | |
| 227 | sub regen_apicheck |
| 228 | { |
| 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"; |
| 232 | } |
| 233 | |
| 234 | sub load_todo |
| 235 | { |
| 236 | my($file, $expver) = @_; |
| 237 | |
| 238 | if (-e $file) { |
| 239 | my $f = new IO::File $file or die "cannot open $file: $!\n"; |
| 240 | my $ver = <$f>; |
| 241 | chomp $ver; |
| 242 | if ($ver eq $expver) { |
| 243 | my %sym; |
| 244 | while (<$f>) { |
| 245 | chomp; |
| 246 | /^(\w+)\s+#\s+(.*)/ or goto nuke_file; |
| 247 | exists $sym{$1} and goto nuke_file; |
| 248 | $sym{$1} = $2; |
| 249 | } |
| 250 | return \%sym; |
| 251 | } |
| 252 | |
| 253 | nuke_file: |
| 254 | undef $f; |
| 255 | unlink $file or die "cannot remove $file: $!\n"; |
| 256 | } |
| 257 | |
| 258 | return {}; |
| 259 | } |
| 260 | |
| 261 | sub write_todo |
| 262 | { |
| 263 | my($file, $ver, $sym) = @_; |
| 264 | my $f; |
| 265 | |
| 266 | $f = new IO::File ">$file" or die "cannot open $file: $!\n"; |
| 267 | $f->print("$ver\n"); |
| 268 | |
| 269 | for (sort keys %$sym) { |
| 270 | $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_}); |
| 271 | } |
| 272 | } |
| 273 | |
| 274 | sub find_undefined_symbols |
| 275 | { |
| 276 | my($perl, $shlib) = @_; |
| 277 | |
| 278 | my $ps = read_sym(file => $perl, options => [qw( --defined-only )]); |
| 279 | my $ls = read_sym(file => $shlib, options => [qw( --undefined-only )]); |
| 280 | |
| 281 | my @undefined; |
| 282 | |
| 283 | for my $sym (keys %$ls) { |
| 284 | unless (exists $ps->{$sym}) { |
| 285 | if ($sym !~ /\@/ and $sym !~ /^_/) { |
| 286 | push @undefined, $sym; |
| 287 | } |
| 288 | } |
| 289 | } |
| 290 | |
| 291 | return @undefined; |
| 292 | } |
| 293 | |
| 294 | sub read_sym |
| 295 | { |
| 296 | my %opt = ( options => [], @_ ); |
| 297 | |
| 298 | my $r = run($Config{nm}, @{$opt{options}}, $opt{file}); |
| 299 | |
| 300 | if ($r->{didnotrun} or $r->{status}) { |
| 301 | die "cannot run $Config{nm}"; |
| 302 | } |
| 303 | |
| 304 | my %sym; |
| 305 | |
| 306 | for (@{$r->{stdout}}) { |
| 307 | chomp; |
| 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; |
| 312 | } |
| 313 | |
| 314 | return \%sym; |
| 315 | } |
| 316 | |
| 317 | sub get_apicheck_symbol_map |
| 318 | { |
| 319 | my $r; |
| 320 | |
| 321 | while (1) { |
| 322 | $r = run(qw(make apicheck.i)); |
| 323 | |
| 324 | last unless $r->{didnotrun} or $r->{status}; |
| 325 | |
| 326 | my %sym = map { /error: macro "(\w+)" (?:requires|passed) \d+ argument/ ? ($1 => 'A') : () } |
| 327 | @{$r->{stderr}}; |
| 328 | |
| 329 | if (keys %sym) { |
| 330 | for my $s (sort keys %sym) { |
| 331 | sym('new', $s, $sym{$s}); |
| 332 | $all{$s} = $sym{$s}; |
| 333 | } |
| 334 | write_todo($opt{todo}, $opt{version}, \%all); |
| 335 | regen_apicheck(); |
| 336 | } |
| 337 | else { |
| 338 | die "cannot run make apicheck.i ($r->{didnotrun} / $r->{status}):\n". |
| 339 | join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}}); |
| 340 | } |
| 341 | } |
| 342 | |
| 343 | my $fh = IO::File->new('apicheck.i') |
| 344 | or die "cannot open apicheck.i: $!"; |
| 345 | |
| 346 | local $_; |
| 347 | my %symmap; |
| 348 | my $cur; |
| 349 | |
| 350 | while (<$fh>) { |
| 351 | next if /^#/; |
| 352 | if (defined $cur) { |
| 353 | for my $sym (/\b([A-Za-z_]\w+)\b/g) { |
| 354 | $symmap{$sym}{$cur}++; |
| 355 | } |
| 356 | undef $cur if /^}$/; |
| 357 | } |
| 358 | else { |
| 359 | /_DPPP_test_(\w+)/ and $cur = $1; |
| 360 | } |
| 361 | } |
| 362 | |
| 363 | return \%symmap; |
| 364 | } |