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
  34   shlib   => 'blib/arch/auto/Devel/PPPort/PPPort.so',
  35 );
  36
  37 GetOptions(\%opt, qw(
  38 perl=s todo=s blead version=s shlib=s debug base verbose check!
  39           )) or die;
  40
  41 identify();
  42
  43 print "\n", ident_str(), "\n\n";
  44
  45 my $fullperl = `which $opt{perl}`;
  46 chomp $fullperl;
  47
  48 $ENV{SKIP_SLOW_TESTS} = 1;
  49
  50 regen_Makefile();
  51
  52 my %stdsym = map { ($_ => 1) } qw (
  53   strlen
  54   snprintf
  55   strcmp
  56   memcpy
  57   strncmp
  58   memmove
  59   memcmp
  60   tolower
  61   exit
  62   memset
  63   vsnprintf
  64   siglongjmp
  65   sprintf
  66 );
  67
  68 my %sym;
  69 for (`$Config{nm} $fullperl`) {
  70   chomp;
  71   /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
  72 }
  73 keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
  74
  75 my %todo = %{load_todo($opt{todo}, $opt{version})} if $opt{todo};
  76 my @recheck;
  77
  78 my $symmap = get_apicheck_symbol_map();
  79
  80 for (;;) {
  81   my $retry = 1;
  82   my $trynm = 1;
  83   regen_apicheck();
  84
  85 retry:
  86   my(@new, @already_in_sym, %seen);
  87
  88   my $r = run(qw(make));
  89   $r->{didnotrun} and die "couldn't run make: $!\n" .
  90         join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
  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 @already_in_sym, [$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         join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
 138       $r->{status} == 0 and last;
 139
 140       for my $l (@{$r->{stderr}}) {
 141         if ($l =~ /undefined symbol: (\w+)/) {
 142           push @u, $1;
 143         }
 144       }
 145     }
 146
 147     for my $u (@u) {
 148       for my $m (keys %{$symmap->{$u}}) {
 149         if (!$seen{$m}++) {
 150           my $pl = $m;
 151           $pl =~ s/^[Pp]erl_//;
 152           my @s = grep { exists $sym{$_} } $pl, "Perl_$pl", "perl_$pl";
 153           push @new, [$m, @s ? "U (@s)" : "U"];
 154         }
 155       }
 156     }
 157   }
 158
 159   @new = grep !$todo{$_->[0]}, @new;
 160
 161   unless (@new) {
 162     @new = grep !$todo{$_->[0]}, @already_in_sym;
 163   }
 164
 165   unless (@new) {
 166     if ($retry > 0) {
 167       $retry--;
 168       regen_Makefile();
 169       goto retry;
 170     }
 171     print Dumper($r);
 172     die "no new TODO symbols found...";
 173   }
 174
 175   # don't recheck undefined symbols reported by the dynamic linker
 176   push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new;
 177
 178   for (@new) {
 179     display_sym('new', @$_);
 180     $todo{$_->[0]} = $_->[1];
 181   }
 182
 183   write_todo($opt{todo}, $opt{version}, \%todo);
 184 }
 185
 186 if ($opt{check}) {
 187   my $ifmt = '%' . length(scalar @recheck) . 'd';
 188   my $t0 = [gettimeofday];
 189
 190   RECHECK: for my $i (0 .. $#recheck) {
 191     my $sym = $recheck[$i];
 192     my $cur = delete $todo{$sym};
 193
 194     display_sym('chk', $sym, $cur, sprintf(" [$ifmt/$ifmt, ETA %s]",
 195                $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck)));
 196
 197     write_todo($opt{todo}, $opt{version}, \%todo);
 198
 199     if ($cur eq "E (Perl_$sym)") {
 200       # we can try a shortcut here
 201       regen_apicheck($sym);
 202
 203       my $r = run(qw(make test));
 204
 205       if (!$r->{didnotrun} && $r->{status} == 0) {
 206         display_sym('del', $sym, $cur);
 207         next RECHECK;
 208       }
 209     }
 210
 211     # run the full test
 212     regen_Makefile();
 213
 214     my $r = run(qw(make test));
 215
 216     # This regenerated apicheck.c
 217     dump_apicheck() if $opt{debug};
 218
 219     $r->{didnotrun} and die "couldn't run make test: $!\n" .
 220         join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
 221
 222     if ($r->{status} == 0) {
 223       display_sym('del', $sym, $cur);
 224     }
 225     else {
 226       $todo{$sym} = $cur;
 227     }
 228   }
 229 }
 230
 231 write_todo($opt{todo}, $opt{version}, \%todo);
 232
 233 run(qw(make realclean));
 234
 235 exit 0;
 236
 237 sub display_sym
 238 {
 239   my($what, $sym, $reason, $extra) = @_;
 240   $extra ||= '';
 241   my %col = (
 242     'new' => 'bold red',
 243     'chk' => 'bold magenta',
 244     'del' => 'bold green',
 245   );
 246   $what = colored("$what symbol", $col{$what});
 247
 248   printf "[%s] %s %-30s # %s%s\n",
 249          $opt{version}, $what, $sym, $reason, $extra;
 250 }
 251
 252 sub regen_Makefile
 253 {
 254   my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0 -w');
 255   push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base};
 256
 257   # just to be sure
 258   run(qw(make realclean));
 259   my $r = run($fullperl, "Makefile.PL", @mf_arg);
 260   unless ($r->{status} == 0) {
 261       die "cannot run Makefile.PL: $!\n" .
 262           join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
 263   }
 264 }
 265
 266 sub regen_apicheck
 267 {
 268   unlink qw(apicheck.c apicheck.o);
 269   runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_)
 270       or die "cannot regenerate apicheck.c\n";
 271   dump_apicheck() if $opt{debug};
 272 }
 273
 274 sub dump_apicheck
 275 {
 276     my $apicheck = "apicheck.c";
 277     my $f = new IO::File $apicheck or die "cannot open $apicheck: $!\n";
 278     my @lines = <$f>;
 279     print STDERR __FILE__, ": ", __LINE__, ": $apicheck (",
 280                                            scalar @lines,
 281                                            " lines) for $fullperl";
 282     print STDERR " and '" if @_;
 283     print STDERR join "', '", @_;
 284     print STDERR "'" if @_;
 285     print STDERR ":\n";
 286     my $n = 1;
 287     print STDERR $n++, " ", $_ for @lines;
 288 }
 289
 290 sub load_todo
 291 {
 292   my($file, $expver) = @_;
 293
 294   if (-e $file) {
 295     my $f = new IO::File $file or die "cannot open $file: $!\n";
 296     my $ver = <$f>;
 297     chomp $ver;
 298     if ($ver eq $expver) {
 299       my %sym;
 300       while (<$f>) {
 301         chomp;
 302         /^(\w+)\s+#\s+(.*)/ or goto nuke_file;
 303         exists $sym{$1} and goto nuke_file;
 304         $sym{$1} = $2;
 305       }
 306       return \%sym;
 307     }
 308
 309 nuke_file:
 310     undef $f;
 311     unlink $file or die "cannot remove $file: $!\n";
 312   }
 313
 314   return {};
 315 }
 316
 317 sub write_todo
 318 {
 319   my($file, $ver, $sym) = @_;
 320   my $f;
 321
 322   $f = new IO::File ">$file" or die "cannot open $file: $!\n";
 323   $f->print("$ver\n");
 324
 325   # Dictionary ordering, with only alphanumerics
 326   for (sort dictionary_order keys %$sym) {
 327     $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
 328   }
 329 }
 330
 331 sub find_undefined_symbols
 332 {
 333   my($perl, $shlib) = @_;
 334
 335   my $ps = read_sym(file => $perl,  options => [qw( --defined-only   )]);
 336   my $ls = read_sym(file => $shlib, options => [qw( --undefined-only )]);
 337
 338   my @undefined;
 339
 340   for my $sym (keys %$ls) {
 341     next if $sym =~ /\@/ or $sym =~ /^_/ or exists $stdsym{$sym};
 342     unless (exists $ps->{$sym}) {
 343         push @undefined, $sym;
 344     }
 345   }
 346
 347   return @undefined;
 348 }
 349
 350 sub read_sym
 351 {
 352   my %opt = ( options => [], @_ );
 353
 354   my $r = run($Config{nm}, @{$opt{options}}, $opt{file});
 355
 356   if ($r->{didnotrun} or $r->{status}) {
 357     die "cannot run $Config{nm}" .
 358           join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
 359   }
 360
 361   my %sym;
 362
 363   for (@{$r->{stdout}}) {
 364     chomp;
 365     my($adr, $fmt, $sym) = /^\s*([[:xdigit:]]+)?\s+([ABCDGINRSTUVW?-])\s+(\S+)\s*$/i
 366                            or die "cannot parse $Config{nm} output:\n[$_]\n";
 367     $sym{$sym} = { format => $fmt };
 368     $sym{$sym}{address} = $adr if defined $adr;
 369   }
 370
 371   return \%sym;
 372 }
 373
 374 sub get_apicheck_symbol_map
 375 {
 376   my $r;
 377
 378   while (1) {
 379
 380     # Create apicheck.i
 381     $r = run(qw(make apicheck.i));
 382
 383     # Quit the loop if it succeeded
 384     last unless $r->{didnotrun} or $r->{status};
 385
 386     # Get the list of macros that it failed on
 387     my %sym = map { /error: macro "(\w+)" (?:requires|passed) \d+ argument/ ? ($1 => 'A') : () }
 388               @{$r->{stderr}};
 389
 390     if (keys %sym) {
 391       for my $s (sort dictionary_order keys %sym) {
 392         display_sym('new', $s, $sym{$s});
 393         $todo{$s} = $sym{$s};
 394       }
 395       write_todo($opt{todo}, $opt{version}, \%todo);
 396       regen_apicheck();
 397     }
 398     else {  # It failed for some other reason: give up
 399       die "cannot run make apicheck.i ($r->{didnotrun} / $r->{status}):\n".
 400           join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
 401     }
 402   }
 403
 404   my $fh = IO::File->new('apicheck.i')
 405            or die "cannot open apicheck.i: $!";
 406
 407   local $_;
 408   my %symmap;
 409   my $cur;
 410
 411   while (<$fh>) {
 412     next if /^#/;
 413     if (defined $cur) {
 414       for my $sym (/\b([A-Za-z_]\w+)\b/g) {
 415         $symmap{$sym}{$cur}++;
 416       }
 417       undef $cur if /^}$/;
 418     }
 419     else {
 420       /_DPPP_test_(\w+)/ and $cur = $1;
 421     }
 422   }
 423
 424   return \%symmap;
 425 }