2 ################################################################################
4 # mktodo.pl -- generate baseline and todo files
6 ################################################################################
10 # $Date: 2005/01/31 08:10:50 +0100 $
12 ################################################################################
14 # Version 3.x, Copyright (C) 2004-2005, Marcus Holland-Moritz.
15 # Version 2.x, Copyright (C) 2001, Paul Marquess.
16 # Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
18 # This program is free software; you can redistribute it and/or
19 # modify it under the same terms as Perl itself.
21 ################################################################################
34 print "\n$0 @ARGV\n\n";
37 perl=s todo=s version=s debug base
40 my $fullperl = `which $opt{perl}`;
46 for (`nm $fullperl`) {
48 /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
50 keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
52 my %all = %{load_todo($opt{todo}, $opt{version})};
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+)/) {
66 my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1";
68 push @tmp, [$1, "E (@s)"];
75 if ($l =~ /undefined symbol: (?:[Pp]erl_)?(\w+)/) {
77 my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1";
78 push @new, [$1, @s ? "U (@s)" : "U"];
82 @new = grep !$all{$_->[0]}, @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 ?
96 die "no new TODO symbols found...";
98 push @recheck, map { $_->[0] } @new;
100 printf "[$opt{version}] new symbol: %-30s # %s\n", @$_;
101 $all{$_->[0]} = $_->[1];
103 write_todo($opt{todo}, $opt{version}, \%all);
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);
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;
121 write_todo($opt{todo}, $opt{version}, \%all);
123 run(qw(make realclean));
129 my @mf_arg = qw( --with-apicheck OPTIMIZE=-O0 );
130 push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base};
133 run(qw(make realclean));
134 run($fullperl, "Makefile.PL", @mf_arg)->{status} == 0
135 or die "cannot run Makefile.PL: $!\n";
140 unlink qw(apicheck.c apicheck.o);
141 system "$fullperl apicheck_c.PL >/dev/null";
146 my($file, $expver) = @_;
149 my $f = new IO::File $file or die "cannot open $file: $!\n";
152 if ($ver eq $expver) {
156 /^(\w+)\s+#\s+(.*)/ or goto nuke_file;
157 exists $sym{$1} and goto nuke_file;
165 unlink $file or die "cannot remove $file: $!\n";
173 my($file, $ver, $sym) = @_;
176 $f = new IO::File ">$file" or die "cannot open $file: $!\n";
179 for (sort keys %$sym) {
180 $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
189 # print "[$prog @args]\n";
191 system "$prog @args >tmp.out 2>tmp.err";
193 my $out = new IO::File "tmp.out" || die "tmp.out: $!\n";
194 my $err = new IO::File "tmp.err" || die "tmp.err: $!\n";
203 unlink "tmp.out", "tmp.err";
205 $? & 128 and $rval{core} = 1;
206 $? & 127 and $rval{signal} = $? & 127;