Commit | Line | Data |
adfe19db |
1 | #!/usr/bin/perl -w |
2 | ################################################################################ |
3 | # |
4 | # mktodo.pl -- generate baseline and todo files |
5 | # |
6 | ################################################################################ |
7 | # |
0c96388f |
8 | # $Revision: 11 $ |
adfe19db |
9 | # $Author: mhx $ |
0c96388f |
10 | # $Date: 2006/05/25 17:22:32 +0200 $ |
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; |
0c96388f |
28 | use Time::HiRes qw( gettimeofday tv_interval ); |
adfe19db |
29 | |
0c96388f |
30 | require 'devel/devtools.pl'; |
adfe19db |
31 | |
0c96388f |
32 | our %opt = ( |
33 | debug => 0, |
34 | base => 0, |
35 | verbose => 0, |
36 | ); |
adfe19db |
37 | |
38 | GetOptions(\%opt, qw( |
0c96388f |
39 | perl=s todo=s version=s debug base verbose |
adfe19db |
40 | )) or die; |
41 | |
0c96388f |
42 | identify(); |
43 | |
44 | print "\n", ident_str(), "\n\n"; |
45 | |
adfe19db |
46 | my $fullperl = `which $opt{perl}`; |
47 | chomp $fullperl; |
48 | |
0c96388f |
49 | $ENV{SKIP_SLOW_TESTS} = 1; |
50 | |
adfe19db |
51 | regen_all(); |
52 | |
53 | my %sym; |
54 | for (`nm $fullperl`) { |
55 | chomp; |
56 | /\s+T\s+(\w+)\s*$/ and $sym{$1}++; |
57 | } |
58 | keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n"; |
59 | |
60 | my %all = %{load_todo($opt{todo}, $opt{version})}; |
61 | my @recheck; |
62 | |
63 | for (;;) { |
64 | my $retry = 1; |
65 | regen_apicheck(); |
66 | retry: |
67 | my $r = run(qw(make test)); |
68 | $r->{didnotrun} and die "couldn't run make test: $!\n"; |
69 | $r->{status} == 0 and last; |
70 | my(@new, @tmp, %seen); |
71 | for my $l (@{$r->{stderr}}) { |
72 | if ($l =~ /_DPPP_test_(\w+)/) { |
73 | if (!$seen{$1}++) { |
74 | my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1"; |
75 | if (@s) { |
76 | push @tmp, [$1, "E (@s)"]; |
77 | } |
78 | else { |
79 | push @new, [$1, "E"]; |
80 | } |
81 | } |
82 | } |
83 | if ($l =~ /undefined symbol: (?:[Pp]erl_)?(\w+)/) { |
84 | if (!$seen{$1}++) { |
85 | my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1"; |
86 | push @new, [$1, @s ? "U (@s)" : "U"]; |
87 | } |
88 | } |
89 | } |
90 | @new = grep !$all{$_->[0]}, @new; |
91 | unless (@new) { |
92 | @new = grep !$all{$_->[0]}, @tmp; |
93 | # TODO: @recheck was here, find a better way to get recheck syms |
adfe19db |
94 | # * try to grep out warnings before making symlist ? |
95 | } |
96 | unless (@new) { |
97 | if ($retry > 0) { |
98 | $retry--; |
99 | regen_all(); |
100 | goto retry; |
101 | } |
102 | print Dumper($r); |
103 | die "no new TODO symbols found..."; |
104 | } |
0c96388f |
105 | # don't recheck undefined symbols reported by the dynamic linker |
106 | push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new; |
adfe19db |
107 | for (@new) { |
108 | printf "[$opt{version}] new symbol: %-30s # %s\n", @$_; |
109 | $all{$_->[0]} = $_->[1]; |
110 | } |
111 | write_todo($opt{todo}, $opt{version}, \%all); |
112 | } |
113 | |
0c96388f |
114 | my $ifmt = '%' . length(scalar @recheck) . 'd'; |
115 | my $t0 = [gettimeofday]; |
116 | |
117 | RECHECK: for my $i (0 .. $#recheck) { |
118 | my $sym = $recheck[$i]; |
adfe19db |
119 | my $cur = delete $all{$sym}; |
0c96388f |
120 | |
121 | printf "[$opt{version}] chk symbol: %-30s # %s [$ifmt/$ifmt, ETA %s]\n", |
122 | $sym, $cur, $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck); |
123 | |
adfe19db |
124 | write_todo($opt{todo}, $opt{version}, \%all); |
0c96388f |
125 | |
126 | if ($cur eq "E (Perl_$sym)") { |
127 | # we can try a shortcut here |
128 | regen_apicheck($sym); |
129 | |
130 | my $r = run(qw(make test)); |
131 | |
132 | if (!$r->{didnotrun} && $r->{status} == 0) { |
133 | printf "[$opt{version}] del symbol: %-30s # %s\n", $sym, $cur; |
134 | next RECHECK; |
135 | } |
136 | } |
137 | |
138 | # run the full test |
adfe19db |
139 | regen_all(); |
0c96388f |
140 | |
adfe19db |
141 | my $r = run(qw(make test)); |
0c96388f |
142 | |
adfe19db |
143 | $r->{didnotrun} and die "couldn't run make test: $!\n"; |
0c96388f |
144 | |
adfe19db |
145 | if ($r->{status} == 0) { |
146 | printf "[$opt{version}] del symbol: %-30s # %s\n", $sym, $cur; |
147 | } |
148 | else { |
149 | $all{$sym} = $cur; |
150 | } |
151 | } |
152 | |
153 | write_todo($opt{todo}, $opt{version}, \%all); |
154 | |
155 | run(qw(make realclean)); |
156 | |
157 | exit 0; |
158 | |
159 | sub regen_all |
160 | { |
0c96388f |
161 | my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0'); |
adfe19db |
162 | push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base}; |
163 | |
164 | # just to be sure |
165 | run(qw(make realclean)); |
166 | run($fullperl, "Makefile.PL", @mf_arg)->{status} == 0 |
167 | or die "cannot run Makefile.PL: $!\n"; |
168 | } |
169 | |
170 | sub regen_apicheck |
171 | { |
172 | unlink qw(apicheck.c apicheck.o); |
0c96388f |
173 | runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_) |
174 | or die "cannot regenerate apicheck.c\n"; |
adfe19db |
175 | } |
176 | |
177 | sub load_todo |
178 | { |
179 | my($file, $expver) = @_; |
180 | |
181 | if (-e $file) { |
182 | my $f = new IO::File $file or die "cannot open $file: $!\n"; |
183 | my $ver = <$f>; |
184 | chomp $ver; |
185 | if ($ver eq $expver) { |
186 | my %sym; |
187 | while (<$f>) { |
188 | chomp; |
189 | /^(\w+)\s+#\s+(.*)/ or goto nuke_file; |
190 | exists $sym{$1} and goto nuke_file; |
191 | $sym{$1} = $2; |
192 | } |
193 | return \%sym; |
194 | } |
195 | |
196 | nuke_file: |
197 | undef $f; |
198 | unlink $file or die "cannot remove $file: $!\n"; |
199 | } |
200 | |
201 | return {}; |
202 | } |
203 | |
204 | sub write_todo |
205 | { |
206 | my($file, $ver, $sym) = @_; |
207 | my $f; |
208 | |
209 | $f = new IO::File ">$file" or die "cannot open $file: $!\n"; |
210 | $f->print("$ver\n"); |
211 | |
212 | for (sort keys %$sym) { |
213 | $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_}); |
214 | } |
215 | } |
216 | |