My favorites | Sign in
Project Home Wiki Issues Source
Repository:
Checkout   Browse   Changes   Clones  
Changes to /status_upd
1d5d8f92128b vs. 1049b74d7832 Compare: vs.  Format:
Revision 1049b74d7832
Go to: 
Project members, sign in to write a code review
/status_upd   1d5d8f92128b /status_upd   1049b74d7832
1 #!/usr/bin/perl -w 1 #!/usr/bin/perl -w
2 # status_upd [-suqftad] [ 1.32 | path ] 2 # status_upd [-suqftad] [ 1.32 | path ]
3 # process perlall maketest logfiles: 3 # process perlall maketest logfiles:
4 # `perl$ver Makefile.PL && make test > log.test-$platform-$ver; make clean` 4 # `perl$ver Makefile.PL && make test > log.test-$platform-$ver; make clean`
5 # and find, sort by FAIL/TODO and platform+version 5 # and find, sort by FAIL/TODO and platform+version
6 6
7 use strict; 7 use strict;
8 use Getopt::Long; 8 use Getopt::Long;
9 9
10 BEGIN { 10 BEGIN {
11 sub _auto_use { # autoinstall the non-core modules, and use them 11 sub _auto_use { # autoinstall the non-core modules, and use them
12 my @m; 12 my @m;
13 for (@_) { push @m, $_ unless eval "require $_;" } 13 for (@_) { push @m, $_ unless eval "require $_;" }
14 if (@m) { # Checked the API back to 1.76_01 (v5.8.4) 14 if (@m) { # Checked the API back to 1.76_01 (v5.8.4)
15 require CPAN; CPAN->import; 15 require CPAN; CPAN->import;
16 warn "CPAN::Shell->install(qw(@m))\n"; CPAN::Shell->install(@m); } 16 warn "CPAN::Shell->install(qw(@m))\n"; CPAN::Shell->install(@m); }
17 #$_->import for @m; 17 #$_->import for @m;
18 } 18 }
19 _auto_use qw(Data::Dumper Set::Object); 19 _auto_use qw(Data::Dumper Set::Object);
20 Set::Object->import('reftype'); 20 Set::Object->import('reftype');
21 Data::Dumper->import; 21 Data::Dumper->import;
22 } 22 }
23 23
24 sub help { 24 sub help {
25 print <<EOF; 25 print <<EOF;
26 status_upd -fqd [ 1.32 | path ] 26 status_upd -fqd [ 1.32 | path ]
27 27
28 OPTIONS: 28 OPTIONS:
29 -q quiet 29 -q quiet
30 -f fail only 30 -f fail only
31 -t todo only 31 -t todo only
32 -d no unify dumps 32 -d no unify dumps
33 -a all, do not skip too old logs 33 -a all, do not skip too old logs
34 -s sort by test (ignored) 34 -s sort by test (ignored)
35 -u update STATUS (ignored) 35 -u update STATUS (ignored)
36 -h help 36 -h help
37 EOF 37 EOF
38 exit; 38 exit;
39 } 39 }
40 40
41 my $logs = "log.test-*-5.*"; 41 my $logs = "log.test-*-5.*";
42 my $dir = "."; 42 my $dir = ".";
43 my $STATUS = "./STATUS"; 43 my $STATUS = "./STATUS";
44 44
45 chdir ".." if ! -d "t" and -d "../t"; 45 chdir ".." if ! -d "t" and -d "../t";
46 chdir "../.." if ! -d "t" and -d "../../t"; 46 chdir "../.." if ! -d "t" and -d "../../t";
47 my ($sortbytest, $update, $quiet, $failonly, $todoonly, $noskip, $nodump, $help); 47 my ($sortbytest, $update, $quiet, $failonly, $todoonly, $noskip, $nodump, $help);
48 Getopt::Long::Configure ("bundling"); 48 Getopt::Long::Configure ("bundling");
49 GetOptions ("sort|s" => \$sortbytest, #ignored 49 GetOptions ("sort|s" => \$sortbytest, #ignored
50 "update|u" => \$update, #ignored 50 "update|u" => \$update, #ignored
51 "quiet|q" => \$quiet, 51 "quiet|q" => \$quiet,
52 "fail|f" => \$failonly, 52 "fail|f" => \$failonly,
53 "todo|pass|t" => \$todoonly, 53 "todo|pass|t" => \$todoonly,
54 "all|a" => \$noskip, 54 "all|a" => \$noskip,
55 "dump|d" => \$nodump, 55 "dump|d" => \$nodump,
56 "help|h" => \$help); 56 "help|h" => \$help);
57 57
58 help if $help; 58 help if $help;
59 59
60 for (@ARGV) { 60 for (@ARGV) {
61 -d "t/reports/$_" and $dir = "t/reports/$_"; 61 -d "t/reports/$_" and $dir = "t/reports/$_";
62 -d "$_" and $dir = $_; 62 -d "$_" and $dir = $_;
63 } 63 }
64 64
65 # read stdout lines from a grep command and 65 # read stdout lines from a grep command and
66 # prints and return a string of the sorted 66 # prints and return a string of the sorted
67 # results and a hash for further processing. 67 # results and a hash for further processing.
68 sub status { 68 sub status {
69 my $h = shift; 69 my $h = shift;
70 my @g = @_; 70 my @g = @_;
71 my $s = ""; 71 my $s = "";
72 my %h = %$h; 72 my %h = %$h;
73 my $prefix = ''; 73 my $prefix = '';
74 my $oldprefix = ''; 74 my $oldprefix = '';
75 my $skipped = 0; 75 my $skipped = 0;
76 while (@g) { 76 while (@g) {
77 if ($g[0] =~ /^--/) { 77 if ($g[0] =~ /^--/) {
78 $oldprefix = $prefix if $prefix; 78 $oldprefix = $prefix if $prefix;
79 $prefix = ''; 79 $prefix = '';
80 shift @g; 80 shift @g;
81 next; 81 next;
82 } 82 }
83 my $file = shift @g; 83 my $file = shift @g;
84 my $failed = shift @g; 84 my $failed = shift @g;
85 my $ctime = 0; 85 my $ctime = 0;
86 chomp $file; 86 chomp $file;
87 unless ($prefix) { 87 unless ($prefix) {
88 my ($f) = $file =~ m{(log.test-.*?)-t/}; 88 my ($f) = $file =~ m{(log.test-.*?)-t/};
89 ($prefix) = $file =~ m{log.test-(.*?)-t/}; 89 ($prefix) = $file =~ m{log.test-(.*?)-t/};
90 if ($prefix and $oldprefix ne $prefix and $prefix !~ /\.\d+$/) { 90 if ($prefix and $oldprefix ne $prefix and $prefix !~ /\.\d+$/) {
91 #$prefix =~ s/ATGRZ.+?-/cygwin-/; 91 #$prefix =~ s/ATGRZ.+?-/cygwin-/;
92 $ctime = -f $f ? sprintf("%0.3f", -C $f) : 0; 92 $ctime = -f $f ? sprintf("%0.3f", -C $f) : 0;
93 print "\n$prefix: age=$ctime" unless $quiet; 93 print "\n$prefix: age=$ctime" unless $quiet;
94 if ($ctime > 1.5 and !$noskip) { 94 if ($ctime > 1.5 and !$noskip) {
95 $skipped = 1; 95 $skipped = 1;
96 print " skipped: too old" unless $quiet; 96 print " skipped: too old" unless $quiet;
97 $s .= "\n$prefix:\n" unless $quiet; 97 $s .= "\n$prefix:\n" unless $quiet;
98 } else { 98 } else {
99 $s .= "\n$prefix:\n"; 99 $s .= "\n$prefix:\n";
100 $skipped = 0; 100 $skipped = 0;
101 } 101 }
102 print "\n" unless $quiet; 102 print "\n" unless $quiet;
103 } 103 }
104 next if $f and $f =~ /\.\d+/; 104 next if $f and $f =~ /\.\d+/;
105 } 105 }
106 next unless $prefix; 106 next unless $prefix;
107 next unless $file; 107 next unless $file;
108 next if $file and $file =~ m{\.\d+-t/}; 108 next if $file and $file =~ m{\.\d+-t/};
109 chomp $file; 109 chomp $file;
110 ($file) = $file =~ m{log.test-.*-(t/[\w\.]+\s?)}; 110 ($file) = $file =~ m{log.test-.*-(t/[\w\.]+\s?)};
111 next unless $file; 111 next unless $file;
112 $file =~ s{\s*$}{}; 112 $file =~ s{\s*$}{};
113 $file =~ s{^\s*}{}; 113 $file =~ s{^\s*}{};
114 $failed =~ s{^.+(Failed tests?:?)}{$1}i; 114 $failed =~ s{^.+(Failed tests?:?)}{$1}i;
115 $failed =~ s{^.+TODO passed:}{TODO passed:}; 115 $failed =~ s{^.+TODO passed:}{TODO passed:};
116 chomp $failed; 116 chomp $failed;
117 $failed =~ s/(\d)-(\d)/$1..$2/g; 117 $failed =~ s/(\d)-(\d)/$1..$2/g;
118 my $f = $failed; 118 my $f = $failed;
119 $f =~ s{^Failed tests?:?\s*(.+)$}{$1}i; 119 $f =~ s{^Failed tests?:?\s*(.+)$}{$1}i;
120 $f =~ s{^TODO passed:\s*}{}; 120 $f =~ s{^TODO passed:\s*}{};
121 $f =~ s/ //g; 121 $f =~ s/ //g;
122 my $c = "$file\t" if $failed; 122 my $c = "$file\t" if $failed;
123 $c .= "\t" if length($file) < 8; 123 $c .= "\t" if length($file) < 8;
124 $c .= "$failed\n"; 124 $c .= "$failed\n";
125 next if $skipped; 125 next if $skipped;
126 $h{$prefix}->{$file} = $f; 126 $h{$prefix}->{$file} = $f;
127 print "$c" unless $quiet; 127 print "$c" unless $quiet;
128 $s .= $c; 128 $s .= $c;
129 } 129 }
130 print "\n" unless $quiet; 130 print "\n" unless $quiet;
131 [ $s, \%h ]; 131 [ $s, \%h ];
132 } 132 }
133 133
134 # split into platform, version, [feature] 134 # split into platform, version, [feature]
135 # debian-squeeze-amd64-5.10.1-nt => ("debian-squeeze-amd64", "5.10", "nt") 135 # debian-squeeze-amd64-5.10.1-nt => ("debian-squeeze-amd64", "5.10", "nt")
136 sub platform_version_split { 136 sub platform_version_split {
137 local $_ = shift; 137 local $_ = shift;
138 my ($p,$v,$f) = m/^(.+)-(5\.[\d\.]+)([-dntm]+)?$/; 138 my ($p,$v,$f) = m/^(.+)-(5\.[\d\.]+)([-dntm]+)?$/;
139 $f =~ s/^-// if $f; # d, d-nt, nt, m or empty 139 $f =~ s/^-// if $f; # d, d-nt, nt, m or empty
140 $v =~ s/(\d\.\d+)\.\d+/$1/ if $v; 140 $v =~ s/(\d\.\d+)\.\d+/$1/ if $v;
141 return ($p,$v,$f); 141 return ($p,$v,$f);
142 } 142 }
143 143
144 sub h_size($) { scalar keys %{$_[0]} } 144 sub h_size($) { scalar keys %{$_[0]} }
145 sub split_tests($) { 145 sub split_tests($) {
146 my $t = shift; 146 my $t = shift;
147 map { 147 map {
148 if (/(\d+)\.\.(\d+)/) { 148 if (/(\d+)\.\.(\d+)/) {
149 ($1 .. $2) 149 ($1 .. $2)
150 } else { 150 } else {
151 $_ 151 $_
152 } 152 }
153 } split /,\s*/, $t; 153 } split /,\s*/, $t;
154 } 154 }
155 155
156 sub in_both ($$) { 156 sub in_both ($$) {
157 # only the elements on both lists 157 # only the elements on both lists
158 my %h1 = map { $_ => 1 } @{$_[0]}; 158 my %h1 = map { $_ => 1 } @{$_[0]};
159 my %h2 = map { $_ => 1 } @{$_[1]}; 159 my %h2 = map { $_ => 1 } @{$_[1]};
160 for (keys %h1) { 160 for (keys %h1) {
161 my $e = $h1{$_}; 161 my $e = $h1{$_};
162 undef $h1{$_} unless $h2{$e}; 162 undef $h1{$_} unless $h2{$e};
163 } 163 }
164 sort keys %h1; 164 sort keys %h1;
165 } 165 }
166 166
167 # every 167 # every
168 sub all_common { 168 sub all_common {
169 my $h = shift; # platform_version -> test_file -> test_no_failed 169 my $h = shift; # platform_version -> test_file -> test_no_failed
170 my $result = shift; # skip already deleted results, initially empty 170 my $result = shift; # skip already deleted results, initially empty
171 my (%tests); 171 my (%tests);
172 if (@_ == 1) { # shortcut: only one feature 172 if (@_ == 1) { # shortcut: only one feature
173 delete $h->{$_[0]}->{''}; 173 delete $h->{$_[0]}->{''};
174 return $h->{$_[0]}; 174 return $h->{$_[0]};
175 } 175 }
176 return {} unless @_;
176 # init with shortest list, sort hash by least number of keys 177 # init with shortest list, sort hash by least number of keys
177 my @p = sort { h_size($h->{$a}) <=> h_size($h->{$b}) } @_; 178 my @p = sort { h_size($h->{$a}) <=> h_size($h->{$b}) } @_;
178 my $pivot = $p[0]; 179 my $pivot = $p[0];
179 if (keys %{$h->{$pivot}} == 1 and exists $h->{$pivot}->{''}) { # shortcut: empty result 180 if (keys %{$h->{$pivot}} == 1 and exists $h->{$pivot}->{''}) { # shortcut: empty result
180 return {}; 181 return {};
181 } 182 }
182 my $pivotset = Set::Object->new(keys %{$h->{$pivot}}); 183 my $pivotset = Set::Object->new(keys %{$h->{$pivot}});
183 for ($pivotset->members) { 184 for ($pivotset->members) {
184 if (my $k = $h->{$pivot}->{$_}) { 185 if (my $k = $h->{$pivot}->{$_}) {
185 $tests{$_} = Set::Object->new(split_tests($k)); 186 $tests{$_} = Set::Object->new(split_tests($k));
186 } 187 }
187 } 188 }
188 for my $p (@_) { # check for common keys (in every) 189 for my $p (@_) { # check for common keys (in every)
189 my $c = $pivotset * Set::Object->new(keys %{$h->{$p}}); 190 my $c = $pivotset * Set::Object->new(keys %{$h->{$p}});
190 for ($c->members) { 191 for ($c->members) {
191 if ($_ and exists $tests{$_}) { 192 if ($_ and exists $tests{$_}) {
192 $result->{$_} = $result->{$_} ? $tests{$_} * $result->{$_} : $tests{$_}; 193 $result->{$_} = $result->{$_} ? $tests{$_} * $result->{$_} : $tests{$_};
193 $result->{$_} = $result->{$_} * Set::Object->new( split_tests($h->{$p}->{$_}) ) 194 $result->{$_} = $result->{$_} * Set::Object->new( split_tests($h->{$p}->{$_}) )
194 if $result->{$_}->members; 195 if $result->{$_}->members;
195 $result->{$_} = $result->{$_}->members;# status_upd -fqd 196 $result->{$_} = $result->{$_}->members;# status_upd -fqd
196 } 197 }
197 delete $result->{$_} unless $result->{$_}; 198 delete $result->{$_} unless $result->{$_};
198 } 199 }
199 } 200 }
200 delete $result->{''}; 201 delete $result->{''};
201 return $result; 202 return $result;
202 } 203 }
203 204
204 # XXX FIXME does not work yet 205 # XXX FIXME does not work yet
205 sub unify_results { 206 sub unify_results {
206 my $h = shift; # platform_version -> file -> failed 207 my $h = shift; # platform_version -> file -> failed
207 my $name = shift; # todo or fail 208 my $name = shift; # todo or fail
208 # first check for common results in files, all platforms 209 # first check for common results in files, all platforms
209 my @platforms = keys %$h; 210 my @platforms = keys %$h;
210 my $result = all_common($h, {}, @platforms); 211 my $result = all_common($h, {}, @platforms);
211 if (%$result) { 212 if (%$result) {
212 print Data::Dumper->Dump([$result],["common_$name"]); 213 print Data::Dumper->Dump([$result],["common_$name"]);
213 214
214 # initialize for next round: delete already common found 215 # initialize for next round: delete already common found
215 for my $p (@platforms) { 216 for my $p (@platforms) {
216 for (keys %{$h->{$p}}) { 217 for (keys %{$h->{$p}}) {
217 if ($result->{$_} and $result->{$_} ne $h->{$p}->{$_}) { # strip out common tests 218 if ($result->{$_} and $result->{$_} ne $h->{$p}->{$_}) { # strip out common tests
218 my $both = Set::Object->new(split_tests $h->{$p}->{$_}) 219 my $both = Set::Object->new(split_tests $h->{$p}->{$_})
219 - Set::Object->new($result->{$_}); 220 - Set::Object->new($result->{$_});
220 if ($both->members) { 221 if ($both->members) {
221 $h->{$p}->{$_} = join(",", $both->members); 222 $h->{$p}->{$_} = join(",", $both->members);
222 } else { 223 } else {
223 undef $h->{$p}->{$_}; 224 undef $h->{$p}->{$_};
224 } 225 }
225 } 226 }
226 } 227 }
227 } 228 }
228 } 229 }
229 230
230 my $h_sav = $h; 231 my $h_sav = $h;
231 # ignore the platform for now. we don't have any platform issues. 232 # ignore the platform for now. we don't have any platform issues.
232 # check for all pairs version - feature the shortest commons 233 # check for all pairs version - feature the shortest commons
233 # 1. sort by versions (ignore platform + features) *-v-* 234 # 1. sort by versions (ignore platform + features) *-v-*
234 # ignore older devel versions (5.11), just blead 235 # ignore older devel versions (5.11), just blead
235 my %versions; 236 my %versions;
236 for (@platforms) { 237 for (@platforms) {
237 my ($p,$v,$f) = platform_version_split($_); 238 my ($p,$v,$f) = platform_version_split($_);
238 push @{$versions{$v}}, ($_) if $v; 239 push @{$versions{$v}}, ($_) if $v;
239 } 240 }
240 for my $v (sort keys %versions) { 241 for my $v (sort keys %versions) {
241 if ($v !~ /^5\.(7|9|11|13)$/) { # skip 5.11, 5.9, 5.7, but not blead (5.15 currently) 242 if ($v !~ /^5\.(7|9|11|13)$/) { # skip 5.11, 5.9, 5.7, but not blead (5.15 currently)
242 my $v1 = all_common($h, $result, @{$versions{$v}}); 243 my $v1 = all_common($h, $result, @{$versions{$v}});
243 if (%$v1) { 244 if (%$v1) {
244 print Data::Dumper->Dump([$v1],["v$v $name"]); 245 print Data::Dumper->Dump([$v1],["v$v $name"]);
245 } 246 }
246 } 247 }
247 } 248 }
248 249
249 # 2. sort by feature (ignore platform + version) *-*-f 250 # 2. sort by feature (ignore platform + version) *-*-f
250 $h = $h_sav; 251 $h = $h_sav;
251 my %feat; 252 my %feat;
252 for (@platforms) { 253 for (@platforms) {
253 my ($p,$v,$f) = platform_version_split($_); 254 my ($p,$v,$f) = platform_version_split($_);
254 $f = "" unless $f; 255 $f = "" unless $f;
255 push @{$feat{$f}}, ($_); 256 push @{$feat{$f}}, ($_);
256 } 257 }
257 for my $f (sort keys %feat) { 258 for my $f (sort keys %feat) {
258 my $f1 = all_common($h, $result, @{$feat{$f}}); 259 my $f1 = all_common($h, $result, @{$feat{$f}});
259 if (%$f1) { 260 if (%$f1) {
260 print Data::Dumper->Dump([$f1],["feature $f $name"]); 261 print Data::Dumper->Dump([$f1],["feature $f $name"]);
261 } 262 }
262 } 263 }
263 } 264 }
264 265
265 my $dlogs = '`ls '.($dir eq '.'?$logs:"$dir/$logs").'|egrep -v \'\.[1-9]+$\'`'; 266 my $dlogs = '`ls '.($dir eq '.'?$logs:"$dir/$logs").'|egrep -v \'\.[1-9]+$\'`';
266 #warn $dlogs."\n" unless $quiet; #` 267 #warn $dlogs."\n" unless $quiet; #`
267 my $cmd = 'grep -a -i "tests" ' . $dlogs . " | grep -v t/CORE"; 268 my $cmd = 'grep -a -i "tests" ' . $dlogs . " | grep -v t/CORE";
268 warn "$cmd\n" unless $quiet; 269 warn "$cmd\n" unless $quiet;
269 my %h; 270 my %h;
270 my %h_sav = %h; 271 my %h_sav = %h;
271 if (my @g = `$cmd`) { 272 if (my @g = `$cmd`) {
272 for my $file (@g) { 273 for my $file (@g) {
273 my $prefix; 274 my $prefix;
274 if (($prefix) = $file =~ m{log.test-(.*?):}) { 275 if (($prefix) = $file =~ m{log.test-(.*?):}) {
275 ($file) = $file =~ m/(log.test-.*?):/; 276 ($file) = $file =~ m/(log.test-.*?):/;
276 my $ctime = -f $file ? sprintf("%0.3f", -C $file) : 0; 277 my $ctime = -f $file ? sprintf("%0.3f", -C $file) : 0;
277 if ($ctime < 1.5 or $noskip) { 278 if ($ctime < 1.5 or $noskip) {
278 $h{$prefix}->{''} = ''; 279 $h{$prefix}->{''} = '';
279 } 280 }
280 } 281 }
281 } 282 }
282 } else { 283 } else {
283 die "no $logs found\n"; 284 die "no $logs found\n";
284 } 285 }
285 286
286 if (!$todoonly) { 287 if (!$todoonly) {
287 my $cmd = 'grep -a -B1 -i "Failed test" ' . $dlogs . " | grep -v t/CORE"; 288 my $cmd = 'grep -a -B1 -i "Failed test" ' . $dlogs . " | grep -v t/CORE";
288 print "$cmd\n" unless $quiet; 289 print "$cmd\n" unless $quiet;
289 if (my @g = `$cmd`) { 290 if (my @g = `$cmd`) {
290 my $failed = status(\%h, @g); 291 my $failed = status(\%h, @g);
291 print $failed->[0] if $nodump and $quiet; 292 print $failed->[0] if $nodump and $quiet;
292 my $failedu = unify_results($failed->[1], "fail") unless $nodump; 293 my $failedu = unify_results($failed->[1], "fail") unless $nodump;
293 } 294 }
294 } 295 }
295 %h = %h_sav; 296 %h = %h_sav;
296 if (!$failonly) { 297 if (!$failonly) {
297 my $cmd = 'grep -a -B1 -i "TODO passed" ' . $dlogs . " | grep -v t/CORE"; 298 my $cmd = 'grep -a -B1 -i "TODO passed" ' . $dlogs . " | grep -v t/CORE";
298 print "\n$cmd\n" unless $quiet; 299 print "\n$cmd\n" unless $quiet;
299 if (my @g = `$cmd`) { 300 if (my @g = `$cmd`) {
300 my $todo = status(\%h, @g); 301 my $todo = status(\%h, @g);
301 print $todo->[0] if $nodump and $quiet; 302 print $todo->[0] if $nodump and $quiet;
302 my $todou = unify_results($todo->[1], "todo_pass") unless $nodump; 303 my $todou = unify_results($todo->[1], "todo_pass") unless $nodump;
303 } 304 }
304 } 305 }
305 306
306 # XXX TODO: update the TEST STATUS section in "./STATUS" 307 # XXX TODO: update the TEST STATUS section in "./STATUS"
307 if ($update) { 308 if ($update) {
308 die "file not found $STATUS\n" unless -e $STATUS; 309 die "file not found $STATUS\n" unless -e $STATUS;
309 die "-u update STATUS not yet implemented\n"; 310 die "-u update STATUS not yet implemented\n";
310 # sort away platforms 311 # sort away platforms
311 } 312 }
312 313
313 # Local Variables: 314 # Local Variables:
314 # mode: cperl 315 # mode: cperl
315 # cperl-indent-level: 2 316 # cperl-indent-level: 2
316 # fill-column: 100 317 # fill-column: 100
317 # End: 318 # End:
318 # vim: expandtab shiftwidth=2: 319 # vim: expandtab shiftwidth=2:
Powered by Google Project Hosting