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