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   blead     => 0,     # ? Is this perl blead
  29   debug   => 0,
  30   base    => 0,
  31   verbose => 0,
  32   check   => 1,
  33   todo    => "",    # If no --todo, this is a blead perl, and the make should
  34                     # work without error
  35   shlib   => 'blib/arch/auto/Devel/PPPort/PPPort.so',
  36 );
  37
  38 GetOptions(\%opt, qw(
  39 perl=s todo=s blead version=s shlib=s debug base verbose check!
  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 %stdsym = map { ($_ => 1) } qw (
  54   strlen
  55   snprintf
  56   strcmp
  57   memcpy
  58   strncmp
  59   memmove
  60   memcmp
  61   tolower
  62   exit
  63   memset
  64   vsnprintf
  65   siglongjmp
  66   sprintf
  67 );
  68
  69 my %sym;
  70 for (`$Config{nm} $fullperl`) {
  71   chomp;
  72   /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
  73 }
  74 keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
  75
  76 my %all = %{load_todo($opt{todo}, $opt{version})} if $opt{todo};
  77 my @recheck;
  78
  79 my $symmap = get_apicheck_symbol_map();
  80
  81 for (;;) {
  82   my $retry = 1;
  83   my $trynm = 1;
  84   regen_apicheck();
  85
  86 retry:
  87   my(@new, @tmp, %seen);
  88
  89   my $r = run(qw(make));
  90   $r->{didnotrun} and die "couldn't run make: $!\n";
  91
  92   # If there were warnings, we ask the user before continuing when creating
  93   # the base files of blead.  This leads to a potential early exit when things
  94   # aren't working right.
  95   if ($opt{blead} && $opt{base}) {
  96     undef $opt{blead};  # Only warn once.
  97     if (@{$r->{stderr}}) {
  98         print STDERR "Warnings and errors from compiling blead:\n";
  99         print STDERR @{$r->{stderr}};
 100         ask_or_quit("\nUnexpected warnings when compiling blead can lead to"
 101                   . " wrong results.  Please examine the above list.\n"
 102                   . "Shall I proceed?");
 103     }
 104     else {
 105         print STDERR "blead compiled without warnings nor errors.\n"
 106                    . "Proceeding with everything else\n";
 107     }
 108   }
 109
 110   for my $l (@{$r->{stderr}}) {
 111     if ($l =~ /_DPPP_test_(\w+)/) {
 112       if (!$seen{$1}++) {
 113         my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1";
 114         if (@s) {
 115           push @tmp, [$1, "E (@s)"];
 116         }
 117         else {
 118           push @new, [$1, "E"];
 119         }
 120       }
 121     }
 122   }
 123
 124   if ($r->{status} == 0) {
 125     my @u;
 126     my @usym;
 127
 128     if ($trynm) {
 129       @u = eval { find_undefined_symbols($fullperl, $opt{shlib}) };
 130       warn "warning: $@" if $@;
 131       $trynm = 0;
 132     }
 133
 134     unless (@u) {
 135       $r = run(qw(make test));
 136       $r->{didnotrun} and die "couldn't run make test: $!\n";
 137       $r->{status} == 0 and last;
 138
 139       for my $l (@{$r->{stderr}}) {
 140         if ($l =~ /undefined symbol: (\w+)/) {
 141           push @u, $1;
 142         }
 143       }
 144     }
 145
 146     for my $u (@u) {
 147       for my $m (keys %{$symmap->{$u}}) {
 148         if (!$seen{$m}++) {
 149           my $pl = $m;
 150           $pl =~ s/^[Pp]erl_//;
 151           my @s = grep { exists $sym{$_} } $pl, "Perl_$pl", "perl_$pl";
 152           push @new, [$m, @s ? "U (@s)" : "U"];
 153         }
 154       }
 155     }
 156   }
 157
 158   @new = grep !$all{$_->[0]}, @new;
 159
 160   unless (@new) {
 161     @new = grep !$all{$_->[0]}, @tmp;
 162   }
 163
 164   unless (@new) {
 165     if ($retry > 0) {
 166       $retry--;
 167       regen_all();
 168       goto retry;
 169     }
 170     print Dumper($r);
 171     die "no new TODO symbols found...";
 172   }
 173
 174   # don't recheck undefined symbols reported by the dynamic linker
 175   push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new;
 176
 177   for (@new) {
 178     sym('new', @$_);
 179     $all{$_->[0]} = $_->[1];
 180   }
 181
 182   write_todo($opt{todo}, $opt{version}, \%all);
 183 }
 184
 185 if ($opt{check}) {
 186   my $ifmt = '%' . length(scalar @recheck) . 'd';
 187   my $t0 = [gettimeofday];
 188
 189   RECHECK: for my $i (0 .. $#recheck) {
 190     my $sym = $recheck[$i];
 191     my $cur = delete $all{$sym};
 192
 193     sym('chk', $sym, $cur, sprintf(" [$ifmt/$ifmt, ETA %s]",
 194                $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck)));
 195
 196     write_todo($opt{todo}, $opt{version}, \%all);
 197
 198     if ($cur eq "E (Perl_$sym)") {
 199       # we can try a shortcut here
 200       regen_apicheck($sym);
 201
 202       my $r = run(qw(make test));
 203
 204       if (!$r->{didnotrun} && $r->{status} == 0) {
 205         sym('del', $sym, $cur);
 206         next RECHECK;
 207       }
 208     }
 209
 210     # run the full test
 211     regen_all();
 212
 213     my $r = run(qw(make test));
 214
 215     $r->{didnotrun} and die "couldn't run make test: $!\n";
 216
 217     if ($r->{status} == 0) {
 218       sym('del', $sym, $cur);
 219     }
 220     else {
 221       $all{$sym} = $cur;
 222     }
 223   }
 224 }
 225
 226 write_todo($opt{todo}, $opt{version}, \%all);
 227
 228 run(qw(make realclean));
 229
 230 exit 0;
 231
 232 sub sym
 233 {
 234   my($what, $sym, $reason, $extra) = @_;
 235   $extra ||= '';
 236   my %col = (
 237     'new' => 'bold red',
 238     'chk' => 'bold magenta',
 239     'del' => 'bold green',
 240   );
 241   $what = colored("$what symbol", $col{$what});
 242
 243   printf "[%s] %s %-30s # %s%s\n",
 244          $opt{version}, $what, $sym, $reason, $extra;
 245 }
 246
 247 sub regen_all
 248 {
 249   my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0 -w');
 250   push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base};
 251
 252   # just to be sure
 253   run(qw(make realclean));
 254   run($fullperl, "Makefile.PL", @mf_arg)->{status} == 0
 255       or die "cannot run Makefile.PL: $!\n";
 256 }
 257
 258 sub regen_apicheck
 259 {
 260   unlink qw(apicheck.c apicheck.o);
 261   runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_)
 262       or die "cannot regenerate apicheck.c\n";
 263 }
 264
 265 sub load_todo
 266 {
 267   my($file, $expver) = @_;
 268
 269   if (-e $file) {
 270     my $f = new IO::File $file or die "cannot open $file: $!\n";
 271     my $ver = <$f>;
 272     chomp $ver;
 273     if ($ver eq $expver) {
 274       my %sym;
 275       while (<$f>) {
 276         chomp;
 277         /^(\w+)\s+#\s+(.*)/ or goto nuke_file;
 278         exists $sym{$1} and goto nuke_file;
 279         $sym{$1} = $2;
 280       }
 281       return \%sym;
 282     }
 283
 284 nuke_file:
 285     undef $f;
 286     unlink $file or die "cannot remove $file: $!\n";
 287   }
 288
 289   return {};
 290 }
 291
 292 sub write_todo
 293 {
 294   my($file, $ver, $sym) = @_;
 295   my $f;
 296
 297   $f = new IO::File ">$file" or die "cannot open $file: $!\n";
 298   $f->print("$ver\n");
 299
 300   # Dictionary ordering, with only alphanumerics
 301   for (sort dictionary_order keys %$sym) {
 302     $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
 303   }
 304 }
 305
 306 sub find_undefined_symbols
 307 {
 308   my($perl, $shlib) = @_;
 309
 310   my $ps = read_sym(file => $perl,  options => [qw( --defined-only   )]);
 311   my $ls = read_sym(file => $shlib, options => [qw( --undefined-only )]);
 312
 313   my @undefined;
 314
 315   for my $sym (keys %$ls) {
 316     unless (exists $ps->{$sym}) {
 317       if ($sym !~ /\@/ and $sym !~ /^_/) {
 318         push @undefined, $sym unless $stdsym{$sym};
 319       }
 320     }
 321   }
 322
 323   return @undefined;
 324 }
 325
 326 sub read_sym
 327 {
 328   my %opt = ( options => [], @_ );
 329
 330   my $r = run($Config{nm}, @{$opt{options}}, $opt{file});
 331
 332   if ($r->{didnotrun} or $r->{status}) {
 333     die "cannot run $Config{nm}";
 334   }
 335
 336   my %sym;
 337
 338   for (@{$r->{stdout}}) {
 339     chomp;
 340     my($adr, $fmt, $sym) = /^\s*([[:xdigit:]]+)?\s+([ABCDGINRSTUVW?-])\s+(\S+)\s*$/i
 341                            or die "cannot parse $Config{nm} output:\n[$_]\n";
 342     $sym{$sym} = { format => $fmt };
 343     $sym{$sym}{address} = $adr if defined $adr;
 344   }
 345
 346   return \%sym;
 347 }
 348
 349 sub get_apicheck_symbol_map
 350 {
 351   my $r;
 352
 353   while (1) {
 354     $r = run(qw(make apicheck.i));
 355
 356     last unless $r->{didnotrun} or $r->{status};
 357
 358     my %sym = map { /error: macro "(\w+)" (?:requires|passed) \d+ argument/ ? ($1 => 'A') : () }
 359               @{$r->{stderr}};
 360
 361     if (keys %sym) {
 362       for my $s (sort dictionary_order keys %sym) {
 363         sym('new', $s, $sym{$s});
 364         $all{$s} = $sym{$s};
 365       }
 366       write_todo($opt{todo}, $opt{version}, \%all);
 367       regen_apicheck();
 368     }
 369     else {
 370       die "cannot run make apicheck.i ($r->{didnotrun} / $r->{status}):\n".
 371           join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
 372     }
 373   }
 374
 375   my $fh = IO::File->new('apicheck.i')
 376            or die "cannot open apicheck.i: $!";
 377
 378   local $_;
 379   my %symmap;
 380   my $cur;
 381
 382   while (<$fh>) {
 383     next if /^#/;
 384     if (defined $cur) {
 385       for my $sym (/\b([A-Za-z_]\w+)\b/g) {
 386         $symmap{$sym}{$cur}++;
 387       }
 388       undef $cur if /^}$/;
 389     }
 390     else {
 391       /_DPPP_test_(\w+)/ and $cur = $1;
 392     }
 393   }
 394
 395   return \%symmap;
 396 }