dist/Devel-PPPort/devel/mktodo.pl

   1 #!/usr/bin/perl -w
   2 ################################################################################
   3 #
   4 #  mktodo.pl -- generate baseline and todo files
   5 #
   6 # It makes the todo file for the single passed in perl binary.  If --base is
   7 # not specified it compiles with ppport.h.
   8 ################################################################################
   9 #
  10 #  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
  11 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
  12 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
  13 #
  14 #  This program is free software; you can redistribute it and/or
  15 #  modify it under the same terms as Perl itself.
  16 #
  17 ################################################################################
  18
  19 use strict;
  20 use Getopt::Long;
  21 use Data::Dumper;
  22 use IO::File;
  23 use IO::Select;
  24 use Config;
  25 use Time::HiRes qw( gettimeofday tv_interval );
  26
  27 require './devel/devtools.pl';
  28
  29 our %opt = (
  30   blead     => 0,     # ? Is this perl blead
  31   debug   => 0,     # Adding --verbose increases the detail
  32   base    => 0,     # Don't use ppport.h when generating
  33   verbose => 0,
  34   check   => 1,
  35   todo    => "",  # If no --todo, this is a blead perl
  36   shlib   => 'blib/arch/auto/Devel/PPPort/PPPort.so',
  37 );
  38
  39 GetOptions(\%opt, qw(
  40 perl=s todo=s blead version=s shlib=s debug base verbose check!
  41           )) or die;
  42
  43 identify();
  44
  45 print "\n", ident_str(), "\n\n";
  46
  47 my $fullperl = `which $opt{perl}`;
  48 chomp $fullperl;
  49
  50 $ENV{SKIP_SLOW_TESTS} = 1;
  51
  52 # Generate the Makefile using the passed in perl
  53 regen_Makefile();
  54
  55 # List of functions that are never considered undefined.  Add to as necessary
  56 my %stdsym = map { ($_ => 1) } qw (
  57   strlen
  58   snprintf
  59   strcmp
  60   memcpy
  61   strncmp
  62   memmove
  63   memcmp
  64   tolower
  65   exit
  66   memset
  67   vsnprintf
  68   siglongjmp
  69   sprintf
  70 );
  71
  72 # Initialize %sym so that the keys are all the Text symbols for this perl,
  73 # output from the system's 'nm'
  74 my %sym;
  75 for (`$Config{nm} $fullperl`) {
  76   chomp;
  77   /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
  78 }
  79 keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
  80
  81 # %todo is initialized to be the symbols in the current todo file, like so:
  82 # {
  83 #   'UTF8_SAFE_SKIP' => 'U',
  84 #   'newSVsv_flags' => 'U',
  85 #   'newSVsv_nomg' => 'U',
  86 # }
  87 #
  88 # The values are the outputs from nm, plus 'E' from us, for Error
  89 my %todo = %{load_todo($opt{todo}, $opt{version})} if $opt{todo};
  90
  91 my @recheck;
  92
  93 # Get an exhaustive list from apicheck.i of symbols, what functions contain
  94 # them, and how many in each function.
  95 # symbol        fcn            count
  96 # ------        ---            -----
  97 # 'UV' => {
  98 #             'SvUVX'          => 1,
  99 #             'toFOLD_uvchr'   => 2,
 100 #             'sv_uni_display' => 1,
 101 #             ...
 102 # }
 103 my $symmap = get_apicheck_symbol_map();
 104
 105 # In each iteration of the loop we create an apicheck.c.  This will contain a
 106 # generated wrapper function for each API function and macro.  The wrapper
 107 # contains one or more calls to its API element.  Then we attempt to compile
 108 # apicheck.c into apicheck.o.  If it compiles, then every API element exists
 109 # in this version of perl.  If not, we figure out which ones were undefined,
 110 # and set things up so that in the next iteration of the loop, the wrappers
 111 # for those elements are #ifdef'd out.
 112 for (;;) {
 113   my $retry = 1;
 114   my $trynm = 1;
 115
 116   regen_apicheck();
 117
 118 retry:
 119   my(@new, @already_in_sym, %seen);
 120
 121   my $r = run(qw(make));
 122   $r->{didnotrun} and die "couldn't run make: $!\n" .
 123         join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
 124
 125   # If there were warnings, we ask the user before continuing when creating
 126   # the base files of blead.  This leads to a potential early exit when things
 127   # aren't working right.
 128   if ($opt{blead} && $opt{base}) {
 129     undef $opt{blead};  # Only warn once.
 130     if (@{$r->{stderr}}) {
 131         print STDERR "Warnings and errors from compiling blead:\n";
 132         print STDERR @{$r->{stderr}};
 133         ask_or_quit("\nUnexpected warnings when compiling blead can lead to"
 134                   . " wrong results.  Please examine the above list.\n"
 135                   . "Shall I proceed?");
 136     }
 137     else {
 138         print STDERR "blead compiled without warnings nor errors.\n"
 139                    . "Proceeding with everything else\n";
 140     }
 141   }
 142
 143   # Examine stderr.  For each wrapper function listed in it, we create an
 144   # 'E' (for error) entry.   If the function (possibly prefixed by '[Pp]erl')
 145   # is in %sym, it is added to @already_in_sym.  Otherwise, @new.
 146   for my $l (@{$r->{stderr}}) {
 147     if ($l =~ /_DPPP_test_(\w+)/) {
 148       if (!$seen{$1}++) {
 149         my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1";
 150         if (@s) {
 151           push @already_in_sym, [$1, "E (@s)"];
 152         }
 153         else {
 154           push @new, [$1, "E"];
 155         }
 156       }
 157     }
 158   }
 159
 160   if ($r->{status} == 0) {
 161     my @u;
 162     my @usym;
 163
 164     # Here, apicheck.o was successfully created.  It likely will need
 165     # functions from outside it in order to form a complete executable a.out.
 166     # In the first iteration, look to see if all needed externs are available.
 167     # (We don't actually try to create an a.out)
 168     if ($trynm) {
 169       @u = eval { find_undefined_symbols($fullperl, $opt{shlib}) };
 170       warn "warning: $@" if $@;
 171       $trynm = 0;
 172     }
 173
 174     # If it didn't find any undefined symbols, everything should be working.
 175     # Run the test suite.
 176     unless (@u) {
 177       $r = run(qw(make test));
 178       $r->{didnotrun} and die "couldn't run make test: $!\n" .
 179         join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
 180
 181       $r->{status} == 0 and last;   # It worked!!
 182
 183       # Alas, something was wrong.  Add any undefined symbols listed in the
 184       # output to our list
 185       for my $l (@{$r->{stderr}}) {
 186         if ($l =~ /undefined symbol: (\w+)/) {
 187           push @u, $1;
 188         }
 189       }
 190     }
 191
 192     # For each undefined symbol
 193     for my $u (@u) {
 194
 195       # If this is an API symbol, $symmap->{$u} will exist and be a hash of
 196       # keys, being all the symbols referred to within it (with their values
 197       # btw being the count of occurrences in the element).
 198       for my $m (keys %{$symmap->{$u}}) {
 199         if (!$seen{$m}++) {
 200           my $pl = $m;
 201           $pl =~ s/^[Pp]erl_//;
 202           my @s = grep { exists $sym{$_} } $pl, "Perl_$pl", "perl_$pl";
 203
 204           # The comment for this entry that goes into the file that gets
 205           # written includes any [Pp]erl prefix.
 206           push @new, [$m, @s ? "U (@s)" : "U"];
 207         }
 208       }
 209     }
 210   }
 211
 212   # Remove from @new all the current todo symbols
 213   @new = grep !$todo{$_->[0]}, @new;
 214
 215   # If none remain, start over with those we know about, minus the todo
 216   # symbols.  khw doesn't understand why this is necessary
 217   unless (@new) {
 218     @new = grep !$todo{$_->[0]}, @already_in_sym;
 219   }
 220
 221   # This retries once if nothing new was found (khw guesses that is just to
 222   # be sure, or maybe it's because we ran nm the first time through)
 223   unless (@new) {
 224     if ($retry > 0) {
 225       $retry--;
 226       regen_Makefile();
 227       goto retry;
 228     }
 229     print Dumper($r);
 230     die "no new TODO symbols found...";
 231   }
 232
 233   # recheck symbols except undefined ones reported by the dynamic linker
 234   push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new;
 235
 236   # Display each newly found undefined symbol, and add it to the list of todo
 237   # symbols
 238   for (@new) {
 239     display_sym('new', @$_);
 240     $todo{$_->[0]} = $_->[1];
 241   }
 242
 243   # Write the revised todo, so that apicheck.c when generated in the next
 244   # iteration will have these #ifdef'd out
 245   write_todo($opt{todo}, $opt{version}, \%todo);
 246 } # End of loop
 247
 248 # If we are to check our work, do so.  This verifies that each symbol
 249 # identified above is really a problem in this version.  (khw doesn't know
 250 # under what circumstances this becomes an issue)
 251 #
 252 # We go through each symbol on the @recheck list, and create an apicheck.c
 253 # with it enabled.
 254 if ($opt{check}) {
 255
 256   # Create something like '%3d'
 257   my $ifmt = '%' . length(scalar @recheck) . 'd';
 258
 259   my $t0 = [gettimeofday];
 260
 261   RECHECK: for my $i (0 .. $#recheck) {
 262     my $sym = $recheck[$i];
 263
 264     # Assume it will work
 265     my $cur = delete $todo{$sym};
 266
 267     # Give a progress report
 268     display_sym('chk', $sym, $cur, sprintf(" [$ifmt/$ifmt, ETA %s]",
 269                $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck)));
 270
 271     # Write out the todo file without this symbol, meaning it will be enabled
 272     # in the generated apicheck.c file
 273     write_todo($opt{todo}, $opt{version}, \%todo);
 274
 275     # E is not an nm symbol, but was added by us to indicate 'Error'
 276     if ($cur eq "E (Perl_$sym)") {
 277
 278       # We can try a shortcut here.  Create an apicheck.c file for just this
 279       # symbol.
 280       regen_apicheck($sym);
 281
 282       my $r = run(qw(make test));
 283
 284       if (!$r->{didnotrun} && $r->{status} == 0) {
 285
 286         # Shortcut indicated that this function compiles..
 287         display_sym('del', $sym, $cur);
 288         next RECHECK;
 289       }
 290
 291       # Here, the api file with just this entry failed to compile.  (khw
 292       # doesn't know why we just don't give up on it now, but we don't.)  We
 293       # drop down below to generate and compile a full apicheck.c with this
 294       # symbol enabled.  (XXX Perhaps we could look at stderr and if it
 295       # contained things about parameter mismatch, (which is a common
 296       # occurrence), we could skip the steps below.)
 297     }
 298
 299     # Either can't shortcut, or the shortcut indicated that the function
 300     # doesn't compile in isolation.  Create, compile and test with this
 301     # function/symbol enabled.  (Remember that this should have succeeded
 302     # above to get to here when this symbol was disabled, so enabling just
 303     # this one will tell us for sure that it works or doesn't work.  (khw
 304     # wonders if this is actually a DAG, or perhaps with cycles, so this is
 305     # under it all, insufficient.)
 306     regen_Makefile();
 307
 308     my $r = run(qw(make test));
 309
 310     # This regenerated apicheck.c
 311     dump_apicheck() if $opt{debug};
 312
 313     $r->{didnotrun} and die "couldn't run make test: $!\n" .
 314         join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
 315
 316     if ($r->{status} == 0) {    # This symbol compiles and tests ok, so retain
 317                                 # in this version
 318       display_sym('del', $sym, $cur);
 319     }
 320     else { # Revert to this symbol is bad in this version
 321       $todo{$sym} = $cur;
 322     }
 323   }
 324 } # End of checking our work
 325
 326 write_todo($opt{todo}, $opt{version}, \%todo);
 327
 328 # Clean up after ourselves
 329 run(qw(make realclean));
 330
 331 exit 0;
 332
 333 sub display_sym
 334 {
 335   my($what, $sym, $reason, $extra) = @_;
 336   $extra ||= '';
 337   my %col = (
 338     'new' => 'bold red',
 339     'chk' => 'bold magenta',
 340     'del' => 'bold green',
 341   );
 342   $what = colored("$what symbol", $col{$what});
 343
 344   printf "[%s] %s %-30s # %s%s\n",
 345          $opt{version}, $what, $sym, $reason, $extra;
 346 }
 347
 348 sub regen_Makefile
 349 {
 350   # We make sure to add rules for creating apicheck.c
 351   my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0 -w');
 352
 353   # It doesn't include ppport.h if generating the base files.
 354   push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base};
 355
 356   # just to be sure
 357   run(qw(make realclean));
 358
 359   my $r = run($fullperl, "Makefile.PL", @mf_arg);
 360   unless ($r->{status} == 0) {
 361       die "cannot run Makefile.PL: $!\n" .
 362           join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
 363   }
 364 }
 365
 366 sub regen_apicheck      # Regeneration can also occur by calling 'make'
 367 {
 368   unlink qw(apicheck.c apicheck.o);
 369   runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_)
 370       or die "cannot regenerate apicheck.c\n";
 371   dump_apicheck() if $opt{debug};
 372 }
 373
 374 sub dump_apicheck
 375 {
 376     my $apicheck = "apicheck.c";
 377     my $f = new IO::File $apicheck or die "cannot open $apicheck: $!\n";
 378     my @lines = <$f>;
 379     print STDERR __FILE__, ": ", __LINE__, ": $apicheck (",
 380                                            scalar @lines,
 381                                            " lines) for $fullperl";
 382     print STDERR " and '" if @_;
 383     print STDERR join "', '", @_;
 384     print STDERR "'" if @_;
 385     print STDERR ":\n";
 386     my $n = 1;
 387     print STDERR $n++, " ", $_ for @lines;
 388 }
 389
 390 sub load_todo   # Return entries from $file; skip if the first line
 391                 # isn't $expver (expected version)
 392 {
 393   my($file, $expver) = @_;
 394
 395   if (-e $file) {
 396     my $f = new IO::File $file or die "cannot open $file: $!\n";
 397     my $ver = <$f>;
 398     chomp $ver;
 399     if ($ver eq $expver) {
 400       my %sym;
 401       while (<$f>) {
 402         chomp;
 403         /^(\w+)\s+#\s+(.*)/ or goto nuke_file;
 404         exists $sym{$1} and goto nuke_file;
 405         $sym{$1} = $2;
 406       }
 407       return \%sym;
 408     }
 409
 410 nuke_file:
 411     undef $f;
 412     unlink $file or die "cannot remove $file: $!\n";
 413   }
 414
 415   return {};
 416 }
 417
 418 sub write_todo  # Write out the todo file.  The keys of %sym are known to not
 419                 # be in this version, hence are 'todo'
 420 {
 421   my($file, $ver, $sym) = @_;
 422   my $f;
 423
 424   $f = new IO::File ">$file" or die "cannot open $file: $!\n";
 425   $f->print("$ver\n");
 426
 427   # Dictionary ordering, with only alphanumerics
 428   for (sort dictionary_order keys %$sym) {
 429     $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
 430   }
 431 }
 432
 433 sub find_undefined_symbols
 434 {
 435   # returns a list of undefined symbols in $shlib.  To be considered
 436   # undefined, it must also not be defined in $perl.  Symbols that begin with
 437   # underscore, or contain '@', or are some libc ones are not returned.
 438   # Presumably, the list of libc could be expanded if necessary.
 439
 440   my($perl, $shlib) = @_;
 441
 442   my $ps = read_sym(file => $perl,  options => [qw( --defined-only   )]);
 443   my $ls = read_sym(file => $shlib, options => [qw( --undefined-only )]);
 444
 445   my @undefined;
 446
 447   for my $sym (keys %$ls) {
 448     next if $sym =~ /\@/ or $sym =~ /^_/ or exists $stdsym{$sym};
 449     unless (exists $ps->{$sym}) {
 450         push @undefined, $sym;
 451     }
 452   }
 453
 454   return @undefined;
 455 }
 456
 457 sub read_sym
 458 {
 459   my %opt = ( options => [], @_ );
 460
 461   my $r = run($Config{nm}, @{$opt{options}}, $opt{file});
 462
 463   if ($r->{didnotrun} or $r->{status}) {
 464     die "cannot run $Config{nm}" .
 465           join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
 466   }
 467
 468   my %sym;
 469
 470   for (@{$r->{stdout}}) {
 471     chomp;
 472     my($adr, $fmt, $sym) = /^\s*([[:xdigit:]]+)?\s+([ABCDGINRSTUVW?-])\s+(\S+)\s*$/i
 473                            or die "cannot parse $Config{nm} output:\n[$_]\n";
 474     $sym{$sym} = { format => $fmt };
 475     $sym{$sym}{address} = $adr if defined $adr;
 476   }
 477
 478   return \%sym;
 479 }
 480
 481 sub get_apicheck_symbol_map
 482 {
 483   my $r;
 484
 485   while (1) {
 486
 487     # Create apicheck.i
 488     $r = run(qw(make apicheck.i));
 489
 490     # Quit the loop if it succeeded
 491     last unless $r->{didnotrun} or $r->{status};
 492
 493     # Get the list of macros that had parameter issues.  These are marked as
 494     # A, for absolute in nm terms
 495     my %sym = map { /error: macro "(\w+)" (?:requires|passed) \d+ argument/ ? ($1 => 'A') : () }
 496               @{$r->{stderr}};
 497
 498     # Display these, and add them to the global %todo.
 499     if (keys %sym) {
 500       for my $s (sort dictionary_order keys %sym) {
 501         display_sym('new', $s, $sym{$s});
 502         $todo{$s} = $sym{$s};
 503       }
 504
 505       # And rewrite the todo file, including these new symbols.
 506       write_todo($opt{todo}, $opt{version}, \%todo);
 507
 508       # Regenerate apicheck.c for the next iteration
 509       regen_apicheck();
 510     }
 511     else {  # It failed for some other reason than parameter issues: give up
 512       die "cannot run make apicheck.i ($r->{didnotrun} / $r->{status}):\n".
 513           join('', @{$r->{stdout}})."\n---\n".join('', @{$r->{stderr}});
 514     }
 515   }
 516
 517   # Here, have an apicheck.i.  Read it in
 518   my $fh = IO::File->new('apicheck.i')
 519            or die "cannot open apicheck.i: $!";
 520
 521   local $_;
 522   my %symmap;
 523   my $cur;
 524
 525   while (<$fh>) {
 526     next if /^#/;
 527
 528     # We only care about lines within one of our _DPPP_test_ functions.  If
 529     # we're in one, $cur is set to the name of the current one.
 530     if (! defined $cur) {   # Not within such a function; see if this starts
 531                             # one
 532       /_DPPP_test_(\w+)/ and $cur = $1;
 533     }
 534     else {
 535
 536       # For anything that looks like a symbol, note it as a key, and as its
 537       # value, the name of the function.  Actually the value is another key,
 538       # whose value is the count of this symbol's occurrences, so it looks
 539       # like:
 540       # 'UV' => {
 541       #             'SvUVX' => 1,
 542       #             'toFOLD_uvchr' => 2,
 543       #             'sv_uni_display' => 1,
 544       #             ...
 545       # }
 546       for my $sym (/\b([A-Za-z_]\w+)\b/g) {
 547         $symmap{$sym}{$cur}++;
 548       }
 549
 550       # This line marks the end of this function, as constructed by us.
 551       undef $cur if /^}$/;
 552     }
 553   }
 554
 555   return \%symmap;
 556 }