Commit | Line | Data |
adfe19db |
1 | #!/usr/bin/perl -w |
2 | ################################################################################ |
3 | # |
4 | # mktodo.pl -- generate baseline and todo files |
5 | # |
6 | ################################################################################ |
7 | # |
0d0f8426 |
8 | # $Revision: 8 $ |
adfe19db |
9 | # $Author: mhx $ |
0d0f8426 |
10 | # $Date: 2006/01/14 22:41:14 +0100 $ |
adfe19db |
11 | # |
12 | ################################################################################ |
13 | # |
0d0f8426 |
14 | # Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz. |
adfe19db |
15 | # Version 2.x, Copyright (C) 2001, Paul Marquess. |
16 | # Version 1.x, Copyright (C) 1999, Kenneth Albanowski. |
17 | # |
18 | # This program is free software; you can redistribute it and/or |
19 | # modify it under the same terms as Perl itself. |
20 | # |
21 | ################################################################################ |
22 | |
23 | use strict; |
24 | use Getopt::Long; |
25 | use Data::Dumper; |
26 | use IO::File; |
27 | use IO::Select; |
28 | |
29 | my %opt = ( |
30 | debug => 0, |
31 | base => 0, |
32 | ); |
33 | |
34 | print "\n$0 @ARGV\n\n"; |
35 | |
36 | GetOptions(\%opt, qw( |
37 | perl=s todo=s version=s debug base |
38 | )) or die; |
39 | |
40 | my $fullperl = `which $opt{perl}`; |
41 | chomp $fullperl; |
42 | |
43 | regen_all(); |
44 | |
45 | my %sym; |
46 | for (`nm $fullperl`) { |
47 | chomp; |
48 | /\s+T\s+(\w+)\s*$/ and $sym{$1}++; |
49 | } |
50 | keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n"; |
51 | |
52 | my %all = %{load_todo($opt{todo}, $opt{version})}; |
53 | my @recheck; |
54 | |
55 | for (;;) { |
56 | my $retry = 1; |
57 | regen_apicheck(); |
58 | retry: |
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+)/) { |
65 | if (!$seen{$1}++) { |
66 | my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1"; |
67 | if (@s) { |
68 | push @tmp, [$1, "E (@s)"]; |
69 | } |
70 | else { |
71 | push @new, [$1, "E"]; |
72 | } |
73 | } |
74 | } |
75 | if ($l =~ /undefined symbol: (?:[Pp]erl_)?(\w+)/) { |
76 | if (!$seen{$1}++) { |
77 | my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1"; |
78 | push @new, [$1, @s ? "U (@s)" : "U"]; |
79 | } |
80 | } |
81 | } |
82 | @new = grep !$all{$_->[0]}, @new; |
83 | unless (@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 ? |
88 | } |
89 | unless (@new) { |
90 | if ($retry > 0) { |
91 | $retry--; |
92 | regen_all(); |
93 | goto retry; |
94 | } |
95 | print Dumper($r); |
96 | die "no new TODO symbols found..."; |
97 | } |
98 | push @recheck, map { $_->[0] } @new; |
99 | for (@new) { |
100 | printf "[$opt{version}] new symbol: %-30s # %s\n", @$_; |
101 | $all{$_->[0]} = $_->[1]; |
102 | } |
103 | write_todo($opt{todo}, $opt{version}, \%all); |
104 | } |
105 | |
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); |
110 | regen_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; |
115 | } |
116 | else { |
117 | $all{$sym} = $cur; |
118 | } |
119 | } |
120 | |
121 | write_todo($opt{todo}, $opt{version}, \%all); |
122 | |
123 | run(qw(make realclean)); |
124 | |
125 | exit 0; |
126 | |
127 | sub regen_all |
128 | { |
129 | my @mf_arg = qw( --with-apicheck OPTIMIZE=-O0 ); |
130 | push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base}; |
131 | |
132 | # just to be sure |
133 | run(qw(make realclean)); |
134 | run($fullperl, "Makefile.PL", @mf_arg)->{status} == 0 |
135 | or die "cannot run Makefile.PL: $!\n"; |
136 | } |
137 | |
138 | sub regen_apicheck |
139 | { |
140 | unlink qw(apicheck.c apicheck.o); |
141 | system "$fullperl apicheck_c.PL >/dev/null"; |
142 | } |
143 | |
144 | sub load_todo |
145 | { |
146 | my($file, $expver) = @_; |
147 | |
148 | if (-e $file) { |
149 | my $f = new IO::File $file or die "cannot open $file: $!\n"; |
150 | my $ver = <$f>; |
151 | chomp $ver; |
152 | if ($ver eq $expver) { |
153 | my %sym; |
154 | while (<$f>) { |
155 | chomp; |
156 | /^(\w+)\s+#\s+(.*)/ or goto nuke_file; |
157 | exists $sym{$1} and goto nuke_file; |
158 | $sym{$1} = $2; |
159 | } |
160 | return \%sym; |
161 | } |
162 | |
163 | nuke_file: |
164 | undef $f; |
165 | unlink $file or die "cannot remove $file: $!\n"; |
166 | } |
167 | |
168 | return {}; |
169 | } |
170 | |
171 | sub write_todo |
172 | { |
173 | my($file, $ver, $sym) = @_; |
174 | my $f; |
175 | |
176 | $f = new IO::File ">$file" or die "cannot open $file: $!\n"; |
177 | $f->print("$ver\n"); |
178 | |
179 | for (sort keys %$sym) { |
180 | $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_}); |
181 | } |
182 | } |
183 | |
184 | sub run |
185 | { |
186 | my $prog = shift; |
187 | my @args = @_; |
188 | |
189 | # print "[$prog @args]\n"; |
190 | |
191 | system "$prog @args >tmp.out 2>tmp.err"; |
192 | |
193 | my $out = new IO::File "tmp.out" || die "tmp.out: $!\n"; |
194 | my $err = new IO::File "tmp.err" || die "tmp.err: $!\n"; |
195 | |
196 | my %rval = ( |
197 | status => $? >> 8, |
198 | stdout => [<$out>], |
199 | stderr => [<$err>], |
200 | didnotrun => 0, |
201 | ); |
202 | |
203 | unlink "tmp.out", "tmp.err"; |
204 | |
205 | $? & 128 and $rval{core} = 1; |
206 | $? & 127 and $rval{signal} = $? & 127; |
207 | |
208 | \%rval; |
209 | } |
210 | |