ext/Devel-PPPort/devel/mktodo.pl

   1 #!/usr/bin/perl -w
   2 ################################################################################
   3 #
   4 #  mktodo.pl -- generate baseline and todo files
   5 #
   6 ################################################################################
   7 #
   8 #  $Revision: 16 $
   9 #  $Author: mhx $
  10 #  $Date: 2009/01/18 14:10:51 +0100 $
  11 #
  12 ################################################################################
  13 #
  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.
  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 = run(qw(make apicheck.i));
 320
 321   if ($r->{didnotrun} or $r->{status}) {
 322     die "cannot run make apicheck.i";
 323   }
 324
 325   my $fh = IO::File->new('apicheck.i')
 326            or die "cannot open apicheck.i: $!";
 327
 328   local $_;
 329   my %symmap;
 330   my $cur;
 331
 332   while (<$fh>) {
 333     next if /^#/;
 334     if (defined $cur) {
 335       for my $sym (/\b([A-Za-z_]\w+)\b/g) {
 336         $symmap{$sym}{$cur}++;
 337       }
 338       undef $cur if /^}$/;
 339     }
 340     else {
 341       /_DPPP_test_(\w+)/ and $cur = $1;
 342     }
 343   }
 344
 345   return \%symmap;
 346 }