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   debug   => 0,
  29   base    => 0,
  30   verbose => 0,
  31   check   => 1,
  32   shlib   => 'blib/arch/auto/Devel/PPPort/PPPort.so',
  33 );
  34
  35 GetOptions(\%opt, qw(
  36             perl=s todo=s version=s shlib=s debug base verbose check!
  37           )) or die;
  38
  39 identify();
  40
  41 print "\n", ident_str(), "\n\n";
  42
  43 my $fullperl = `which $opt{perl}`;
  44 chomp $fullperl;
  45
  46 $ENV{SKIP_SLOW_TESTS} = 1;
  47
  48 regen_all();
  49
  50 my %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
  66 my %sym;
  67 for (`$Config{nm} $fullperl`) {
  68   chomp;
  69   /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
  70 }
  71 keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
  72
  73 my %all = %{load_todo($opt{todo}, $opt{version})};
  74 my @recheck;
  75
  76 my $symmap = get_apicheck_symbol_map();
  77
  78 for (;;) {
  79   my $retry = 1;
  80   my $trynm = 1;
  81   regen_apicheck();
  82
  83 retry:
  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
 164 if ($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
 205 write_todo($opt{todo}, $opt{version}, \%all);
 206
 207 run(qw(make realclean));
 208
 209 exit 0;
 210
 211 sub 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
 226 sub 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
 237 sub 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
 244 sub 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
 263 nuke_file:
 264     undef $f;
 265     unlink $file or die "cannot remove $file: $!\n";
 266   }
 267
 268   return {};
 269 }
 270
 271 sub 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   # Dictionary ordering, with only alphanumerics
 280   for (sort dictionary_order keys %$sym) {
 281     $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
 282   }
 283 }
 284
 285 sub find_undefined_symbols
 286 {
 287   my($perl, $shlib) = @_;
 288
 289   my $ps = read_sym(file => $perl,  options => [qw( --defined-only   )]);
 290   my $ls = read_sym(file => $shlib, options => [qw( --undefined-only )]);
 291
 292   my @undefined;
 293
 294   for my $sym (keys %$ls) {
 295     unless (exists $ps->{$sym}) {
 296       if ($sym !~ /\@/ and $sym !~ /^_/) {
 297         push @undefined, $sym unless $stdsym{$sym};
 298       }
 299     }
 300   }
 301
 302   return @undefined;
 303 }
 304
 305 sub read_sym
 306 {
 307   my %opt = ( options => [], @_ );
 308
 309   my $r = run($Config{nm}, @{$opt{options}}, $opt{file});
 310
 311   if ($r->{didnotrun} or $r->{status}) {
 312     die "cannot run $Config{nm}";
 313   }
 314
 315   my %sym;
 316
 317   for (@{$r->{stdout}}) {
 318     chomp;
 319     my($adr, $fmt, $sym) = /^\s*([[:xdigit:]]+)?\s+([ABCDGINRSTUVW?-])\s+(\S+)\s*$/i
 320                            or die "cannot parse $Config{nm} output:\n[$_]\n";
 321     $sym{$sym} = { format => $fmt };
 322     $sym{$sym}{address} = $adr if defined $adr;
 323   }
 324
 325   return \%sym;
 326 }
 327
 328 sub get_apicheck_symbol_map
 329 {
 330   my $r;
 331
 332   while (1) {
 333     $r = run(qw(make apicheck.i));
 334
 335     last unless $r->{didnotrun} or $r->{status};
 336
 337     my %sym = map { /error: macro "(\w+)" (?:requires|passed) \d+ argument/ ? ($1 => 'A') : () }
 338               @{$r->{stderr}};
 339
 340     if (keys %sym) {
 341       for my $s (sort dictionary_order keys %sym) {
 342         sym('new', $s, $sym{$s});
 343         $all{$s} = $sym{$s};
 344       }
 345       write_todo($opt{todo}, $opt{version}, \%all);
 346       regen_apicheck();
 347     }
 348     else {
 349       die "cannot run make apicheck.i ($r->{didnotrun} / $r->{status}):\n".
 350           join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
 351     }
 352   }
 353
 354   my $fh = IO::File->new('apicheck.i')
 355            or die "cannot open apicheck.i: $!";
 356
 357   local $_;
 358   my %symmap;
 359   my $cur;
 360
 361   while (<$fh>) {
 362     next if /^#/;
 363     if (defined $cur) {
 364       for my $sym (/\b([A-Za-z_]\w+)\b/g) {
 365         $symmap{$sym}{$cur}++;
 366       }
 367       undef $cur if /^}$/;
 368     }
 369     else {
 370       /_DPPP_test_(\w+)/ and $cur = $1;
 371     }
 372   }
 373
 374   return \%symmap;
 375 }