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: 11 $
   9 #  $Author: mhx $
  10 #  $Date: 2006/05/25 17:22:32 +0200 $
  11 #
  12 ################################################################################
  13 #
  14 #  Version 3.x, Copyright (C) 2004-2006, 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 Time::HiRes qw( gettimeofday tv_interval );
  29
  30 require 'devel/devtools.pl';
  31
  32 our %opt = (
  33   debug   => 0,
  34   base    => 0,
  35   verbose => 0,
  36 );
  37
  38 GetOptions(\%opt, qw(
  39             perl=s todo=s version=s debug base verbose
  40           )) or die;
  41
  42 identify();
  43
  44 print "\n", ident_str(), "\n\n";
  45
  46 my $fullperl = `which $opt{perl}`;
  47 chomp $fullperl;
  48
  49 $ENV{SKIP_SLOW_TESTS} = 1;
  50
  51 regen_all();
  52
  53 my %sym;
  54 for (`nm $fullperl`) {
  55   chomp;
  56   /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
  57 }
  58 keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
  59
  60 my %all = %{load_todo($opt{todo}, $opt{version})};
  61 my @recheck;
  62
  63 for (;;) {
  64   my $retry = 1;
  65   regen_apicheck();
  66 retry:
  67   my $r = run(qw(make test));
  68   $r->{didnotrun} and die "couldn't run make test: $!\n";
  69   $r->{status} == 0 and last;
  70   my(@new, @tmp, %seen);
  71   for my $l (@{$r->{stderr}}) {
  72     if ($l =~ /_DPPP_test_(\w+)/) {
  73       if (!$seen{$1}++) {
  74         my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1";
  75         if (@s) {
  76           push @tmp, [$1, "E (@s)"];
  77         }
  78         else {
  79           push @new, [$1, "E"];
  80         }
  81       }
  82     }
  83     if ($l =~ /undefined symbol: (?:[Pp]erl_)?(\w+)/) {
  84       if (!$seen{$1}++) {
  85         my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1";
  86         push @new, [$1, @s ? "U (@s)" : "U"];
  87       }
  88     }
  89   }
  90   @new = grep !$all{$_->[0]}, @new;
  91   unless (@new) {
  92     @new = grep !$all{$_->[0]}, @tmp;
  93     # TODO: @recheck was here, find a better way to get recheck syms
  94     #       * try to grep out warnings before making symlist ?
  95   }
  96   unless (@new) {
  97     if ($retry > 0) {
  98       $retry--;
  99       regen_all();
 100       goto retry;
 101     }
 102     print Dumper($r);
 103     die "no new TODO symbols found...";
 104   }
 105   # don't recheck undefined symbols reported by the dynamic linker
 106   push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new;
 107   for (@new) {
 108     printf "[$opt{version}] new symbol: %-30s # %s\n", @$_;
 109     $all{$_->[0]} = $_->[1];
 110   }
 111   write_todo($opt{todo}, $opt{version}, \%all);
 112 }
 113
 114 my $ifmt = '%' . length(scalar @recheck) . 'd';
 115 my $t0 = [gettimeofday];
 116
 117 RECHECK: for my $i (0 .. $#recheck) {
 118   my $sym = $recheck[$i];
 119   my $cur = delete $all{$sym};
 120
 121   printf "[$opt{version}] chk symbol: %-30s # %s [$ifmt/$ifmt, ETA %s]\n",
 122          $sym, $cur, $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck);
 123
 124   write_todo($opt{todo}, $opt{version}, \%all);
 125
 126   if ($cur eq "E (Perl_$sym)") {
 127     # we can try a shortcut here
 128     regen_apicheck($sym);
 129
 130     my $r = run(qw(make test));
 131
 132     if (!$r->{didnotrun} && $r->{status} == 0) {
 133       printf "[$opt{version}] del symbol: %-30s # %s\n", $sym, $cur;
 134       next RECHECK;
 135     }
 136   }
 137
 138   # run the full test
 139   regen_all();
 140
 141   my $r = run(qw(make test));
 142
 143   $r->{didnotrun} and die "couldn't run make test: $!\n";
 144
 145   if ($r->{status} == 0) {
 146     printf "[$opt{version}] del symbol: %-30s # %s\n", $sym, $cur;
 147   }
 148   else {
 149     $all{$sym} = $cur;
 150   }
 151 }
 152
 153 write_todo($opt{todo}, $opt{version}, \%all);
 154
 155 run(qw(make realclean));
 156
 157 exit 0;
 158
 159 sub regen_all
 160 {
 161   my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0');
 162   push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base};
 163
 164   # just to be sure
 165   run(qw(make realclean));
 166   run($fullperl, "Makefile.PL", @mf_arg)->{status} == 0
 167       or die "cannot run Makefile.PL: $!\n";
 168 }
 169
 170 sub regen_apicheck
 171 {
 172   unlink qw(apicheck.c apicheck.o);
 173   runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_)
 174       or die "cannot regenerate apicheck.c\n";
 175 }
 176
 177 sub load_todo
 178 {
 179   my($file, $expver) = @_;
 180
 181   if (-e $file) {
 182     my $f = new IO::File $file or die "cannot open $file: $!\n";
 183     my $ver = <$f>;
 184     chomp $ver;
 185     if ($ver eq $expver) {
 186       my %sym;
 187       while (<$f>) {
 188         chomp;
 189         /^(\w+)\s+#\s+(.*)/ or goto nuke_file;
 190         exists $sym{$1} and goto nuke_file;
 191         $sym{$1} = $2;
 192       }
 193       return \%sym;
 194     }
 195
 196 nuke_file:
 197     undef $f;
 198     unlink $file or die "cannot remove $file: $!\n";
 199   }
 200
 201   return {};
 202 }
 203
 204 sub write_todo
 205 {
 206   my($file, $ver, $sym) = @_;
 207   my $f;
 208
 209   $f = new IO::File ">$file" or die "cannot open $file: $!\n";
 210   $f->print("$ver\n");
 211
 212   for (sort keys %$sym) {
 213     $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
 214   }
 215 }
 216