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