Commit | Line | Data |
---|---|---|
7eeb782e AT |
1 | #!/usr/bin/perl |
2 | ||
3 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # | |
4 | # This program is distributed with GNU Go, a Go program. # | |
5 | # # | |
6 | # Write gnugo@gnu.org or see http://www.gnu.org/software/gnugo/ # | |
7 | # for more information. # | |
8 | # # | |
9 | # Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 # | |
10 | # and 2008 by the Free Software Foundation. # | |
11 | # # | |
12 | # This program is free software; you can redistribute it and/or # | |
13 | # modify it under the terms of the GNU General Public License # | |
14 | # as published by the Free Software Foundation - version 3 # | |
15 | # or (at your option) any later version. # | |
16 | # # | |
17 | # This program is distributed in the hope that it will be # | |
18 | # useful, but WITHOUT ANY WARRANTY; without even the implied # | |
19 | # warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR # | |
20 | # PURPOSE. See the GNU General Public License in file COPYING # | |
21 | # for more details. # | |
22 | # # | |
23 | # You should have received a copy of the GNU General Public # | |
24 | # License along with this program; if not, write to the Free # | |
25 | # Software Foundation, Inc., 51 Franklin Street, Fifth Floor, # | |
26 | # Boston, MA 02111, USA. # | |
27 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # | |
28 | # | |
29 | # Here is a perlscript regress.plx. | |
30 | # | |
31 | # It parses the XML files created by regress.pl and generates HTML. | |
32 | # It is designed to be run as a CGI script. | |
33 | ||
34 | ||
35 | ||
36 | #BEGIN { | |
37 | # use CGI::Carp qw(carpout); | |
38 | # my $errfile = "C:/temp/web.err"; | |
39 | # #open (WEBERR, ">$errfile") or die "Couldn't open $errfile."; | |
40 | # carpout(STDOUT); | |
41 | #} | |
42 | # | |
43 | ||
44 | use strict; | |
45 | use warnings; | |
46 | ||
47 | use CGI qw/:standard/; | |
48 | use CGI::Carp 'fatalsToBrowser'; | |
49 | ||
50 | use FindBin; | |
51 | use lib "$FindBin::Bin/../interface"; | |
52 | ||
53 | use GoImage::Stone; | |
54 | ||
55 | use HTML::Entities ;#qw/encode_entity/; | |
56 | ||
57 | ||
58 | #set $name to whatever this script is called in the URL. | |
59 | #eg, if you access it from http://example.com/regress/ | |
60 | #then set $name = "" | |
61 | ||
62 | my $name = "regress.plx"; | |
63 | ||
64 | my $debug=2; | |
65 | ||
66 | my %colors = ("ALIVE", "green", | |
67 | "DEAD", "cyan", | |
68 | "CRITICAL", "red", | |
69 | "UNKNOWN", "yellow", | |
70 | "UNCHECKED", "magenta"); | |
71 | ||
72 | my $query = new CGI; | |
73 | my ($tstfile, $num, $sortby, $sgf, $reset, $trace, $bycat, | |
74 | $unexpected, $slow, $special, $move, $small); | |
75 | ||
76 | ($tstfile, $num) = ($query->query_string() =~ /keywords=(.*)%3A(.*)/); | |
77 | ||
78 | if (!$tstfile) { | |
79 | $tstfile = $query->param("tstfile"); | |
80 | $num = $query->param("num"); | |
81 | $sortby = $query->param("sortby"); | |
82 | $sgf = $query->param("sgf"); | |
83 | $reset = $query->param("reset"); | |
84 | $trace = $query->param("trace"); | |
85 | $bycat = $query->param("bycat"); | |
86 | $unexpected = $query->param("unexpected"); | |
87 | $slow = $query->param("slow"); | |
88 | $special = $query->param("special"); | |
89 | $move = $query->param("move"); | |
90 | $small = $query->param("small"); | |
91 | } | |
92 | ||
93 | sub sgfFile(%); | |
94 | ||
95 | ||
96 | #print "HTTP/1.0 200 OK\r\n"; | |
97 | print "Content-type: " . | |
98 | do { | |
99 | my $plain = $trace; | |
100 | if ($sgf) { "application/x-go-sgf" } | |
101 | elsif ($plain) { "text/plain" } | |
102 | else {"text/html"; } | |
103 | } . "\r\n\r\n"; | |
104 | ||
105 | if ($tstfile) { | |
106 | $tstfile = $1 if $tstfile =~ /(.*)\.tst$/; | |
107 | } | |
108 | if ($tstfile && !($tstfile =~ /^[a-zA-Z0-9_]+$/)) { | |
109 | print "bad test file: $tstfile\n"; | |
110 | exit; | |
111 | } | |
112 | ||
113 | if ($reset) { | |
114 | unlink glob("html/*.html");# or die "couldn't delete html files: $!"; | |
115 | unlink glob("html/*/*.html");# or die "couldn't delete html/* files: $!"; | |
116 | unlink "html/one.perldata";# or die "couldn't delete data file"; | |
117 | print "Cleaned up!<HR>\n"; | |
118 | } | |
119 | ||
120 | if ($trace) { | |
121 | open (TRACER, "html/$tstfile.tst/$num.trace") or | |
122 | do {print "Couldn't find trace file: $!"; exit;}; | |
123 | while (<TRACER>) { | |
124 | print; | |
125 | } | |
126 | close TRACER; | |
127 | exit; | |
128 | } | |
129 | ||
130 | ||
131 | ||
132 | ||
133 | my %points; | |
134 | ||
135 | unless ($tstfile) { | |
136 | #CASE 1 - main index | |
137 | if (!-e "html/index.html") { | |
138 | createIndex(); | |
139 | } else { | |
140 | print STDERR "Cached!\n"; | |
141 | } | |
142 | ||
143 | if ($bycat) { | |
144 | printbycategory(); | |
145 | exit; | |
146 | } | |
147 | ||
148 | if ($unexpected) { | |
149 | printunexpected(); | |
150 | exit; | |
151 | } | |
152 | ||
153 | if ($slow) { | |
154 | printslow(); | |
155 | exit; | |
156 | } | |
157 | ||
158 | if ($special) { | |
159 | printspecial(); | |
160 | exit; | |
161 | } | |
162 | ||
163 | if (-z "html/index.html") { | |
164 | print "Yikes - index missing - please reset!"; | |
165 | exit; | |
166 | } | |
167 | ||
168 | open (TESTFILE, "html/index.html") or do {print "$! ".__LINE__; confess "$!"}; | |
169 | while (<TESTFILE>) { | |
170 | print; | |
171 | } | |
172 | close TESTFILE; | |
173 | exit; | |
174 | } | |
175 | ||
176 | ||
177 | my %fullHash; | |
178 | #use Data::Dumper; | |
179 | ||
180 | sub insinglequote { | |
181 | my $s = shift; | |
182 | $s =~ s@\\@\\\\@g; | |
183 | $s =~ s@'@\\'@g; | |
184 | return "'$s'"; | |
185 | } | |
186 | ||
187 | sub FastDump { | |
188 | my ($h) = @_; | |
189 | ||
190 | open (FILE, ">html/one.perldata.new") or confess "can't open"; | |
191 | print FILE "\$VAR1 = [\n {\n"; | |
192 | ||
193 | ||
194 | ||
195 | #print FILE Dumper([\%h]) or confess "couldn't print"; | |
196 | ||
197 | foreach my $k1 (sort keys %{$h}) { | |
198 | print FILE " '$k1' =>\n {\n"; | |
199 | foreach my $k2 (sort keys %{%{$h}->{$k1}}) { | |
200 | print FILE " '$k2' => " . insinglequote(%{$h}->{$k1}->{$k2}) . ",\n"; | |
201 | } | |
202 | print FILE " },\n"; | |
203 | } | |
204 | ||
205 | print FILE " }\n ];"; | |
206 | ||
207 | close FILE or confess "can't close"; | |
208 | } | |
209 | ||
210 | sub createIndex { | |
211 | my %h; | |
212 | foreach my $file (glob("html/*.tst/*.xml")) { | |
213 | my ($tst, $prob) = $file =~ m@html.(.*).tst.(.*).xml@; | |
214 | open (FILE, "$file"); | |
215 | local $/; undef($/); | |
216 | my $content = <FILE>; | |
217 | close FILE; | |
218 | $h{"$tst:$prob"} = game_parse($content, 0); | |
219 | delete $h{"$tst:$prob"}->{gtp_all}; | |
220 | } | |
221 | ||
222 | FastDump(\%h); | |
223 | ||
224 | #print "DONE!\n"; | |
225 | #return; | |
226 | ||
227 | #our $VAR1; | |
228 | #do "html/one.perldata" or confess "can't do perldata"; | |
229 | #my %h = %{$VAR1->[0]}; | |
230 | ||
231 | ||
232 | open I, ">html/index.html"; | |
233 | ||
234 | print I qq@<HTML> | |
235 | <HEAD> | |
236 | <TITLE>Regression test summary - </TITLE> | |
237 | <META NAME="ROBOTS" CONTENT="NOFOLLOW"> | |
238 | </HEAD> | |
239 | <BODY> | |
240 | <H3> Regression test summary - </H3> | |
241 | Program: _CMDLINE_TBD_ <BR> | |
242 | <A href="$name?bycat=1">View by category</A><BR> | |
243 | <A href="$name?unexpected=1">View unexpected results</A><BR> | |
244 | <TABLE border=1> | |
245 | <TR><TD>file</TD><TD>passed</TD><TD>PASSED</TD><TD>failed</TD><TD>FAILED</TD> | |
246 | </TR>@; | |
247 | ||
248 | my @pflist = ("passed", "PASSED", "failed", "FAILED"); | |
249 | my %totHash; | |
250 | @totHash{@pflist} = (0,0,0,0); | |
251 | ||
252 | sub byfilebynum { | |
253 | my ($fileA,$numA) = $a =~ /(.*):(.*)/; | |
254 | my ($fileB,$numB) = $b =~ /(.*):(.*)/; | |
255 | $fileA cmp $fileB or $numA <=> $numB; | |
256 | } | |
257 | ||
258 | my $curfile = ""; | |
259 | my %subTotHash; | |
260 | foreach my $k1 (sort byfilebynum keys %h) { #$k1 = filename | |
261 | if ($k1 !~ /^$curfile:/) { | |
262 | if ($curfile ne "") { | |
263 | #New file = print old totals | |
264 | print I qq@<TR>\n <TD><A href="$name?tstfile=$curfile&sortby=result">$curfile</A></TD>\n@; | |
265 | foreach my $k2 (@pflist) { | |
266 | my $c = @{$subTotHash{$k2}}; #i.e. length of array. | |
267 | $totHash{$k2} += $c; | |
268 | if ($k2 !~ /passed/ and $c) { | |
269 | print I " <TD>$c:<BR>\n"; | |
270 | foreach (sort {$a<=>$b} @{$subTotHash{$k2}}) { | |
271 | print I qq@ <A href="$name?$curfile:$_">$_</A>\n@; | |
272 | } | |
273 | print I " </TD>\n"; | |
274 | } else { | |
275 | print I " <TD>$c</TD>\n"; | |
276 | } | |
277 | } | |
278 | print I qq@</TR>@; | |
279 | } | |
280 | #prepare for next file. | |
281 | ($curfile) = $k1 =~ /(.*):/; | |
282 | @subTotHash{@pflist} = ([],[],[],[]); | |
283 | } | |
284 | push @{$subTotHash{$h{$k1}{status}}}, $h{$k1}{num}; | |
285 | } | |
286 | ||
287 | #direct copy from above - don't miss last time through - HACK! | |
288 | if ($curfile ne "") { | |
289 | #New file = print old totals | |
290 | print I qq@<TR>\n <TD><A href="$name?tstfile=$curfile&sortby=result">$curfile</A></TD>\n@; | |
291 | foreach my $k2 (@pflist) { | |
292 | my $c = @{$subTotHash{$k2}}; #i.e. length of array. | |
293 | $totHash{$k2} += $c; | |
294 | if ($k2 !~ /passed/ and $c) { | |
295 | print I " <TD>$c:<BR>\n"; | |
296 | foreach (sort {$a<=>$b} @{$subTotHash{$k2}}) { | |
297 | print I qq@ <A href="$name?$curfile:$_">$_</A>\n@; | |
298 | } | |
299 | print I " </TD>\n"; | |
300 | } else { | |
301 | print I " <TD>$c</TD>\n"; | |
302 | } | |
303 | } | |
304 | print I qq@</TR>@; | |
305 | } | |
306 | ||
307 | ||
308 | print I "<TR>\n <TD><B>Total</B></TD>\n"; | |
309 | foreach (@pflist) { | |
310 | print I " <TD>$totHash{$_}</TD>\n"; | |
311 | } | |
312 | print I "</TR>\n"; | |
313 | print I " </TABLE></BODY></HTML>\n"; | |
314 | close I; | |
315 | } | |
316 | ||
317 | sub bypPfF { | |
318 | pPfFtonum($a) <=> pPfFtonum($b); | |
319 | } | |
320 | ||
321 | sub pPfFtonum { | |
322 | $_ = shift; | |
323 | s/FAILED/4/; s/failed/3/; s/PASSED/2/; s/passed/1/; | |
324 | $_; | |
325 | } | |
326 | ||
327 | sub fptonum { | |
328 | $_ = shift; | |
329 | s/FAILED/1/; s/failed/3/; s/PASSED/2/; s/passed/4/; s/<B>//; s@</B>@@; | |
330 | $_; | |
331 | } | |
332 | ||
333 | my @counters = qw/connection_node owl_node reading_node trymove/; | |
334 | ||
335 | if ($move) { | |
336 | #CASE 2a - move detail - extract interesting info from trace file. | |
337 | if (!$num) { | |
338 | print "Must provide num if providing move.<BR>"; | |
339 | exit; | |
340 | } | |
341 | ||
342 | print qq@<HTML> | |
343 | <HEAD> | |
344 | <TITLE>$tstfile:$num move $move</TITLE> | |
345 | <META NAME="ROBOTS" CONTENT="NOINDEX, NOFOLLOW"> | |
346 | </HEAD><BODY>\n@; | |
347 | ||
348 | open (FILE, "html/$tstfile.tst/$num.trace") or die "couldn't open trace file $tstfile, $num: $!."; | |
349 | #local $/; undef($/); | |
350 | #my $content = <FILE>; | |
351 | #close FILE; | |
352 | ||
353 | my $blank=1; | |
354 | my $inpattern=0; | |
355 | $move = uc($move); | |
356 | print "<PRE>\n"; | |
357 | while (<FILE>) { | |
358 | if (/^$move[^0-9]/ || | |
359 | /[^A-Za-z0-9]$move[^0-9]/ || | |
360 | $inpattern && /^\.\.\./) { | |
361 | print encode_entities($_); | |
362 | $blank=0; | |
363 | $inpattern ||= /^pattern.*at $move/; | |
364 | } else { | |
365 | print "\n" unless $blank; | |
366 | $blank++; | |
367 | $inpattern=0; | |
368 | } | |
369 | } | |
370 | print "</PRE></BODY></HTML>\n"; | |
371 | exit; | |
372 | } | |
373 | ||
374 | ||
375 | if ($num) { | |
376 | #CASE 2 - problem detail. | |
377 | ||
378 | if ($sgf && -e "html/$tstfile.tst/$num.sgf") { | |
379 | open (SGFFILE, "html/$tstfile.tst/$num.sgf") or confess "couldn't open file"; | |
380 | while (<SGFFILE>) { | |
381 | print; | |
382 | } | |
383 | close SGFFILE; | |
384 | exit; | |
385 | } | |
386 | ||
387 | open (FILE, "html/$tstfile.tst/$num.xml") or die "couldn't open xml file\n"; | |
388 | local $/; undef($/); | |
389 | my $content = <FILE>; | |
390 | close FILE; | |
391 | my %attribs = %{game_parse($content, 1)}; | |
392 | ||
393 | if ($sgf) { | |
394 | foreach (sort keys %attribs) { | |
395 | # print "$_: $attribs{$_}\n"; | |
396 | } | |
397 | sgfFile(%attribs); | |
398 | exit; | |
399 | } | |
400 | ||
401 | print qq@<HTML><HEAD> | |
402 | <TITLE>$tstfile:$num details.</TITLE> | |
403 | <META NAME="ROBOTS" CONTENT="NOINDEX, NOFOLLOW"> | |
404 | </HEAD>\n@; | |
405 | print qq@<BODY><TABLE border=1>\n@; | |
406 | print qq@ | |
407 | <TR> | |
408 | <TD>number:</TD><TD>$attribs{"num"}</TD><TD> </TD> | |
409 | <TD>cputime:</TD><TD>$attribs{"cputime"}</TD> | |
410 | </TR><TR> | |
411 | <TD>status:</TD><TD>$attribs{"status"}</TD><TD> </TD> | |
412 | <TD>$counters[0]:</TD><TD>$attribs{"$counters[0]_counter"}</TD> | |
413 | <TR> | |
414 | <TD>correct:</TD><TD>$attribs{"correct"}</TD><TD> </TD> | |
415 | <TD>$counters[1]:</TD><TD>$attribs{"$counters[1]_counter"}</TD> | |
416 | <TR> | |
417 | <TD>answer:</TD><TD>$attribs{"answer"}</TD><TD> </TD> | |
418 | <TD>$counters[2]:</TD><TD>$attribs{"$counters[2]_counter"}</TD> | |
419 | <TR> | |
420 | <TD>gtp:</TD><TD>$attribs{"gtp_command"}</TD><TD> </TD> | |
421 | <TD>$counters[3]:</TD><TD>$attribs{"$counters[3]_counter"}</TD> | |
422 | </TR><TR><TD>category:</TD><TD>$attribs{"category"}</TD> | |
423 | </TR><TR><TD>severity:</TD><TD>$attribs{"severity"}</TD> | |
424 | </TR><TR><TD>description:</TD><TD>$attribs{"description"}</TD> | |
425 | </TR> | |
426 | </TABLE>\n\n@; | |
427 | print qq@<HR>\n\n@; | |
428 | print qq@ | |
429 | <TABLE border=0> | |
430 | <TR><TD><A href="$name?tstfile=$tstfile&num=$num&sgf=1">SGF File</A> | |
431 | </TD><TD> <A href="$name?tstfile=$tstfile&num=$num&trace=1" target=tracefile>Trace File</A> | |
432 | </TD></TR></TABLE> | |
433 | @; | |
434 | ||
435 | print qq@<TABLE><TR><TD> dragon_status | owl_status\n@; | |
436 | ||
437 | my $boardsize = $attribs{"boardsize"}; #need to add to export. | |
438 | ||
439 | my $colorboard; | |
440 | ||
441 | $colorboard .= "<TABLE border=0 cellpadding=0 cellspacing=0>\n" | |
442 | . colorboard_letter_row($boardsize). "\n"; | |
443 | ||
444 | for (my $j = $boardsize; $j > 0; $j--) { | |
445 | my $jA = $j; | |
446 | $jA .= " " if ($j <= 9); | |
447 | $colorboard .= " <TR>\n <TD align=center valign=center> $j </TD>\n"; | |
448 | for (my $i = 1; $i <= $boardsize; $i++) { | |
449 | my $iA = ord('A') + $i - 1; | |
450 | if ($iA >= ord('I')) { $iA++; } | |
451 | $iA = chr($iA); | |
452 | my $coord = $iA.$j; | |
453 | my $bw = pval($coord, "stone"); | |
454 | my $img_pix_size = 25; | |
455 | my $dragonletter = pval($coord, "dragon_letter"); | |
456 | my $dragoncolor = $colors{pval($coord, "dragon_status")}; | |
457 | my $owlcolor = $colors{pval($coord, "owl_status")}; | |
458 | my $owlletter = $dragonletter; | |
459 | my $alt = ""; | |
460 | ||
461 | my ($markcolor, $known, $try) = ("", pval($coord, "known"), pval($coord, "try")); | |
462 | $markcolor = "magenta" if ($known and $known eq "wrong"); | |
463 | $markcolor = "green" if ($known and $known eq "right"); | |
464 | $markcolor = "cyan" if ($try and $try eq "right"); | |
465 | $markcolor = "red" if ($try and $try eq "wrong"); | |
466 | ||
467 | my $question = pval($coord, "question"); | |
468 | if ($question) { | |
469 | $dragonletter .= "*"; | |
470 | $owlletter = ""; | |
471 | $dragoncolor = "blue" unless $dragoncolor; | |
472 | } | |
473 | ||
474 | my $score = pval($coord, "move_value"); | |
475 | if ($score) { | |
476 | # FIXME: Should round this, not truncate it. | |
477 | # Also, should remove trailing "." if not necessary. | |
478 | $dragonletter = substr($score, 0,3); | |
479 | $dragoncolor = "blue"; | |
480 | $owlletter=""; | |
481 | $alt = "whack"; | |
482 | } | |
483 | ||
484 | my $colorboard_imgsrc = createPngFile($bw, $img_pix_size, "", $dragonletter, $dragoncolor, $owlletter, $owlcolor, $markcolor); | |
485 | $colorboard .= qq@ <TD><A href="$name?tstfile=$tstfile&num=$num&move=$coord" target=movewin>@ . | |
486 | qq@<IMG border=0 HEIGHT=$img_pix_size WIDTH=$img_pix_size @ . | |
487 | qq@SRC="html/images/$colorboard_imgsrc"></A></TD>\n@; | |
488 | } | |
489 | $colorboard .= " <TD align=center valign=center> $j </TD>\n </TR>\n"; | |
490 | } | |
491 | $colorboard .= colorboard_letter_row($boardsize); | |
492 | $colorboard .= "\n</TABLE>\n"; | |
493 | ||
494 | print $colorboard; | |
495 | ||
496 | print qq@</TD><TD valign=top> | |
497 | <PRE>\n\n\n\n | |
498 | <FONT color=green>green=alive</FONT> | |
499 | <FONT color=cyan>cyan=dead</FONT> | |
500 | <FONT color=red>red=critical</FONT> | |
501 | <FONT color=yellow>yellow=unknown</FONT> | |
502 | <FONT color=magenta>magenta=unchecked</FONT> | |
503 | </PRE> | |
504 | </TD></TR> | |
505 | </TABLE>@; | |
506 | ||
507 | my $gtpall = $attribs{gtp_all}; | |
508 | $gtpall =~ s/<BR>//mg; | |
509 | $gtpall =~ s/\s+$//mg; | |
510 | $gtpall =~ m@loadsgf\s+ ((?:\w|[-+.\\/])+) [ \t]* (\d*) @x | |
511 | or $gtpall =~m/(.*?)/; #Problems!!!! | |
512 | ||
513 | my $cmdline = "gq -l $1 " . ($2 ? "-L $2 " : ""); | |
514 | if ($gtpall =~ m@ .* (owl_attack|owl_defend|dragon_status) \s* ([A-Z]\d{1,2}) \s* $ @x) { | |
515 | $cmdline .= "--decide-dragon $2 -o x.sgf" ; | |
516 | } elsif ($gtpall =~ m@ .* (reg_genmove\s+[whiteblack]*) \s* $@x) { | |
517 | $cmdline .= "-t -w -d0x101800"; | |
518 | } elsif ($gtpall =~ m@ .* (attack|defend) \s* ([A-Z]\d{1,2}) \s* $ @x) { | |
519 | $cmdline .= "--decide-string $2 -o x.sgf"; | |
520 | } else { | |
521 | $cmdline .= " <BR> (directive unrecognized)"; | |
522 | } | |
523 | print qq@<HR>\n\n@; | |
524 | print qq@<TABLE border=1>\n@; | |
525 | print qq@ <TR><TD>CMD Line Hint:</TD><TD>$cmdline</TD></TR>\n@; | |
526 | print qq@ <TR><TD>Full GTP:</TD><TD>$attribs{gtp_all}</TD></TR>\n</TABLE>\n@; | |
527 | ||
528 | print "\n\n</HTML>"; | |
529 | # print %attribs; | |
530 | ||
531 | } else { | |
532 | ||
533 | if ($small) { | |
534 | summaryDiagrams(); | |
535 | } | |
536 | #CASE 3 - test file summary. | |
537 | # if (!-e "html/$tstfile.tst/index.html") { | |
538 | summarizeTestFile(); | |
539 | # } else { | |
540 | # print "Cached:<HR>"; | |
541 | # } | |
542 | # open (TESTFILE, "html/$tstfile.tst/index.html") or (print "$! ".__LINE__, die); | |
543 | # while (<TESTFILE>) { | |
544 | # print; | |
545 | # } | |
546 | # close TESTFILE; | |
547 | } | |
548 | ||
549 | ||
550 | sub summaryDiagrams { | |
551 | my $content; | |
552 | foreach my $curfile (glob("html/$tstfile.tst/*.xml")) | |
553 | { | |
554 | %points = {}; | |
555 | $curfile =~ s/html.$tstfile.tst.(.*xml)/$1/; | |
556 | local $/; | |
557 | undef($/); | |
558 | open(FILE, "html/$tstfile.tst/$curfile"); | |
559 | $content = <FILE>; | |
560 | close FILE; | |
561 | ||
562 | my %attribs = %{game_parse($content, 1)}; | |
563 | ||
564 | print qq@<HR><A href="$name?$tstfile:$attribs{num}">$tstfile:$attribs{num}</A>\n@; | |
565 | ||
566 | my $boardsize = $attribs{"boardsize"}; #need to add to export. | |
567 | my $colorboard; | |
568 | $colorboard .= "<TABLE border=0 cellpadding=0 cellspacing=0>\n" | |
569 | . "\n"; | |
570 | ||
571 | my $img_pix_size = 9; | |
572 | ||
573 | for (my $j = $boardsize; $j > 0; $j--) { | |
574 | my $jA = $j; | |
575 | $jA .= " " if ($j <= 9); | |
576 | $colorboard .= "<TR>\n"; | |
577 | for (my $i = 1; $i <= $boardsize; $i++) { | |
578 | my $iA = ord('A') + $i - 1; | |
579 | if ($iA >= ord('I')) { $iA++; } | |
580 | $iA = chr($iA); | |
581 | my $coord = $iA.$j; | |
582 | my $bw = pval($coord, "stone"); | |
583 | my $alt = ""; | |
584 | ||
585 | my $colorboard_imgsrc = createPngFile($bw, $img_pix_size, "", "","","","", ""); | |
586 | $colorboard .= qq@ <TD>@ . | |
587 | qq@<IMG border=0 HEIGHT=$img_pix_size WIDTH=$img_pix_size @ . | |
588 | qq@SRC="html/images/$colorboard_imgsrc"></A></TD>\n@; | |
589 | } | |
590 | $colorboard .= "</TR>\n"; | |
591 | } | |
592 | #$colorboard .= colorboard_letter_row($boardsize); | |
593 | $colorboard .= "\n</TABLE>\n"; | |
594 | ||
595 | print $colorboard; | |
596 | } | |
597 | ||
598 | exit; | |
599 | } | |
600 | ||
601 | ||
602 | ||
603 | my %files; | |
604 | sub summarizeTestFile { | |
605 | ||
606 | unless ($sortby) { $sortby = "filepos"; } | |
607 | ||
608 | # open (TF, "> html/$tstfile.tst/index.html") | |
609 | # or print "couldn't open for output; $!\n", die; | |
610 | *TF = *STDOUT; | |
611 | ||
612 | print TF qq@<HTML><HEAD> | |
613 | <TITLE>$tstfile regression results - _VERSION_</TITLE> | |
614 | <META NAME="ROBOTS" CONTENT="NOINDEX, NOFOLLOW"> | |
615 | </HEAD>\n@; | |
616 | print TF "<BODY>\n"; | |
617 | print TF "<H3>$tstfile regression results - _VERSION_</H3>\n"; | |
618 | print TF qq@<TABLE border=1> | |
619 | <tr> | |
620 | <TH><A href="$name?tstfile=$tstfile&sortby=filepos">line</A></TH> | |
621 | <TH><A href="$name?tstfile=$tstfile&sortby=num">number</A></TH> | |
622 | <TH><A href="$name?tstfile=$tstfile&sortby=result">result</A></TH> | |
623 | <TH>expected </TH> | |
624 | <TH>got</TH> | |
625 | <TH>gtp</TH> | |
626 | <TH><A href="$name?tstfile=$tstfile&sortby=cputime">cputime</A></TH> | |
627 | <TH><A href="$name?tstfile=$tstfile&sortby=owl_node">owl_node</A></TH> | |
628 | <TH><A href="$name?tstfile=$tstfile&sortby=reading_node">reading_node</A></TH> | |
629 | <TH><A href="$name?tstfile=$tstfile&sortby=msperowl">1000*time/owl_node</A></TH> | |
630 | </TR>\n@; | |
631 | ||
632 | my @files = glob("html/$tstfile.tst/*.xml"); | |
633 | foreach my $curfile (@files) { | |
634 | $curfile =~ s/html.$tstfile.tst.(.*xml)/$1/; | |
635 | local $/; | |
636 | undef($/); | |
637 | open(FILE, "html/$tstfile.tst/$curfile"); | |
638 | my $content = <FILE>; | |
639 | close FILE; | |
640 | my $gtp_all = $1 | |
641 | if $content =~ m@<GTP_ALL>(.*?)</GTP_ALL>@s; | |
642 | my $gtp = escapeHTML($1) | |
643 | if $content =~ m@<GTP_COMMAND>(.*?)</GTP_COMMAND>@s; | |
644 | my $result = $1 | |
645 | if $content =~ m@<GOPROB.*?status="(.*?)"@s; | |
646 | my $num = $1 | |
647 | if $content =~ m@<GOPROB.*?number=(\d*)@s; | |
648 | my $filepos = $1 | |
649 | if $content =~ m@<GOPROB.*?filepos=(\d*)@s; | |
650 | my $expected = $1 | |
651 | if $content =~ m@<CORRECT>(.*?)</CORRECT>@s; | |
652 | my $got = $1 | |
653 | if $content =~ m@<ANSWER>(.*?)</ANSWER>@s; | |
654 | my $cputime = $1 | |
655 | if $content =~ m@<TIME.*?CPU=((\d|\.)*)@s; | |
656 | my $owl_node = $1 | |
657 | if $content =~ m@<COUNTER[^>]*owl_node="?(\d+)@s; | |
658 | my $reading_node = $1 | |
659 | if $content =~ m@<COUNTER[^>]*reading_node="?(\d+)@s; | |
660 | $cputime =~ s/0*$//; | |
661 | $files{$curfile} = { | |
662 | gtp_all => $gtp_all, | |
663 | gtp => $gtp, | |
664 | filepos => $filepos, | |
665 | num => $num, | |
666 | expected => $expected, | |
667 | got => $got, | |
668 | result => $result, | |
669 | cputime => $cputime, | |
670 | owl_node => $owl_node, | |
671 | reading_node => $reading_node, | |
672 | msperowl => ($owl_node ? 1000*$cputime/ $owl_node : 0), | |
673 | } | |
674 | } | |
675 | ||
676 | sub byfilepos { $files{$a}{"filepos"} <=> $files{$b}{"filepos"}; } | |
677 | sub bynum { $files{$a}{"num"} <=> $files{$b}{"num"}; } | |
678 | sub byresult { | |
679 | fptonum($files{$a}{"result"}) <=> fptonum($files{$b}{"result"}) | |
680 | or byfilepos(); | |
681 | } | |
682 | sub bycputime { | |
683 | $files{$b}{cputime} <=> $files{$a}{cputime} | |
684 | or byfilepos(); | |
685 | } | |
686 | sub byowl_node { | |
687 | $files{$b}{owl_node} <=> $files{$a}{owl_node} | |
688 | or byfilepos(); | |
689 | } | |
690 | ||
691 | sub byreading_node { | |
692 | $files{$b}{reading_node} <=> $files{$a}{reading_node} | |
693 | or byfilepos(); | |
694 | } | |
695 | sub bymsperowl { | |
696 | $files{$b}{msperowl} <=> $files{$a}{msperowl} | |
697 | or byfilepos(); | |
698 | } | |
699 | ||
700 | sub filesby { | |
701 | $_ = shift; | |
702 | return byfilepos if /filepos/i; | |
703 | return bynum if /num/i; | |
704 | return byresult if /result/i; | |
705 | return bycputime if /cputime/i; | |
706 | return byowl_node if /owl_node/i || /owlnode/i; | |
707 | return bymsperowl if /msperowl/i; | |
708 | return byreading_node if /reading_node/i || /readingnode/i; | |
709 | $files{$a}{$_} <=> $files{$b}{$_}; | |
710 | } | |
711 | ||
712 | my %totals = (cputime=>0, owl_node=>0); | |
713 | ||
714 | foreach my $curfile (sort {filesby($sortby)} keys %files) { | |
715 | my %h = %{$files{$curfile}}; | |
716 | my $numURL = qq@<A href="$name?$tstfile:$h{num}">$h{num}</A>@; | |
717 | my $r = $h{result}; | |
718 | $r =~ s@^([A-Z]*)$@<B>$1</B>@; | |
719 | print TF "<TR><TD>$h{filepos}</TD><TD>$numURL</TD><TD>$r</TD><TD>$h{expected}</TD>" | |
720 | . "<TD>$h{got}</TD><TD>$h{gtp}</TD><TD>$h{cputime}</TD><TD>$h{owl_node}</TD>" | |
721 | . "<TD>$h{reading_node}</TD>" | |
722 | . "<TD>".sprintf("%.2f",$h{msperowl})."</TD></TR>\n"; | |
723 | $totals{cputime} += $h{cputime}; | |
724 | $totals{owl_node} += $h{owl_node}; | |
725 | $totals{reading_node} += $h{reading_node}; | |
726 | } | |
727 | print TF "<TR><TD>Total</TD><TD> </TD><TD> </TD><TD> </TD>" | |
728 | . "<TD> </TD><TD> </TD><TD>$totals{cputime}</TD><TD>$totals{owl_node}</TD>" | |
729 | . "<TD>$totals{reading_node}</TD>" | |
730 | ." <TD>".sprintf("%.2f",1000*$totals{cputime}/($totals{owl_node}+.0001))."</TD></TR>\n"; | |
731 | print TF "</TABLE>"; | |
732 | #close TF; | |
733 | } | |
734 | ||
735 | ||
736 | ||
737 | sub pval { | |
738 | my ($coord, $attrib) = @_; | |
739 | if ($points{$coord}) { | |
740 | # print "$coord $attrib<BR>\n"; | |
741 | if ($points{$coord} =~ m@$attrib="(.*?)"@) { | |
742 | # if ($attrib eq 'stone') { | |
743 | # print "$attrib=$1<BR>\n"; | |
744 | #} | |
745 | return $1; | |
746 | } else { | |
747 | return ""; | |
748 | } | |
749 | } else { | |
750 | return ""; | |
751 | } | |
752 | } | |
753 | ||
754 | ||
755 | ||
756 | sub game_parse { | |
757 | my $content = shift; | |
758 | my $details = shift; | |
759 | my %attribs; | |
760 | $attribs{"num"} = $1 | |
761 | if $content =~ m@<GOPROB.*?number=(\d*)@s; | |
762 | $attribs{"file"} = $1 | |
763 | if $content =~ m@<GOPROB.*?file="(.*?)"@s; | |
764 | $attribs{"status"} = $1 | |
765 | if $content =~ m@<GOPROB.*?status="(.*?)"@s; | |
766 | $attribs{"correct"} = $1 | |
767 | if $content =~ m@<CORRECT>(.*?)</CORRECT>@s; | |
768 | $attribs{"answer"} = $1 | |
769 | if $content =~ m@<ANSWER>(.*?)</ANSWER>@s; | |
770 | $attribs{"gtp_all"} = $1 | |
771 | if $content =~ m@<GTP_ALL>(.*?)</GTP_ALL>@s; | |
772 | $attribs{"description"} = $1 | |
773 | if $content =~ m@<DESCRIPTION>(.*?)</DESCRIPTION>@s; | |
774 | $attribs{"category"} = $1 | |
775 | if $content =~ m@<CATEGORY>(.*?)</CATEGORY>@s; | |
776 | $attribs{"severity"} = $1 | |
777 | if $content =~ m@<SEVERITY>(.*?)</SEVERITY>@s; | |
778 | $attribs{"gtp_command"} = $1 | |
779 | if $content =~ m@<GTP_COMMAND>(.*?)</GTP_COMMAND>@s; | |
780 | $attribs{"cputime"} = $1 | |
781 | if $content =~ m@<TIME.*?CPU=((\d|\.)*)@s; | |
782 | $attribs{"boardsize"} = $1 | |
783 | if $content =~ m@<BOARD[^>]*size=(\d+)@s; | |
784 | foreach (@counters) { | |
785 | $attribs{$_."_counter"} = $1 | |
786 | if $content =~ m@<COUNTER[^>]*$_="?(\d+)@s; | |
787 | } | |
788 | ||
789 | return \%attribs unless $details; | |
790 | ||
791 | $content =~ s@.*?<POINT@<POINT@s; | |
792 | while ($content =~ s@<POINT(.*?)></POINT>@@s) { | |
793 | my $pattr = $1; | |
794 | if ($pattr =~ m@coord="(.*?)"@s) { | |
795 | $points{$1} = $pattr; | |
796 | } else { | |
797 | print "<P>MISSING coord: " . encode($content) . "<P>" . | |
798 | encode($pattr); | |
799 | die; | |
800 | } | |
801 | } | |
802 | ||
803 | return \%attribs; | |
804 | } | |
805 | ||
806 | ||
807 | ||
808 | sub colorboard_letter_row { | |
809 | my $boardsize = shift; | |
810 | my $ret = " <TR>\n <TD> </TD>\n"; | |
811 | for (my $i = 1; $i <= $boardsize; $i++) { | |
812 | my $iA = ord('A') + $i - 1; | |
813 | if ($iA >= ord('I')) { $iA++; } | |
814 | $iA = chr($iA); | |
815 | $ret .= " <TD align=center valign=center>$iA</TD>\n"; | |
816 | } | |
817 | $ret .= " <TD> </TD>\n </TR>"; | |
818 | } | |
819 | ||
820 | ||
821 | sub sgfFile(%) { | |
822 | my %attribs = shift; | |
823 | my $boardsize = $attribs{"boardsize"}; #need to add to export. | |
824 | ||
825 | my $ret=""; | |
826 | $ret .= "(;\nFF[4]GM[1]SZ[$boardsize]\nAP[regress.plx]\n"; | |
827 | ||
828 | for (my $j = $boardsize; $j > 0; $j--) { | |
829 | my $jA = $j; | |
830 | $jA .= " " if ($j <= 9); | |
831 | for (my $i = 1; $i <= $boardsize; $i++) { | |
832 | my $iA = ord('A') + $i - 1; | |
833 | if ($iA >= ord('I')) { $iA++; } | |
834 | $iA = chr($iA); | |
835 | my $coord = $iA.$j; | |
836 | my $bw = pval($coord, "stone"); | |
837 | ||
838 | if ($bw eq "black") { | |
839 | $ret .= "AB\[" . GTPtoSGF($coord, $boardsize) . "]"; | |
840 | } elsif ($bw eq "white") { | |
841 | $ret .= "AW\[" . GTPtoSGF($coord, $boardsize) . "]"; | |
842 | } | |
843 | } | |
844 | } | |
845 | $ret.=")"; | |
846 | ||
847 | $ret =~ s/((A[BW]\[..\]){12})/$1\n/g; | |
848 | ||
849 | print $ret; | |
850 | } | |
851 | ||
852 | ||
853 | sub GTPtoSGF { | |
854 | local $_ = shift; | |
855 | my $boardsize = shift; | |
856 | if (! /([A-Z])([0-9]{1,2})/) { | |
857 | return ; | |
858 | } | |
859 | $_ = ord($1) - ord("A") + 1; | |
860 | if ($_ > (ord("I") - ord("A") + 1)) { $_--; } | |
861 | chr(ord("a") + $_ - 1) . chr(ord("a") + $boardsize - $2); | |
862 | } | |
863 | ||
864 | ||
865 | sub printslow { | |
866 | our $VAR1; | |
867 | do "html/one.perldata.new" or confess "can't do perldata"; | |
868 | my %h = %{$VAR1->[0]}; | |
869 | my $by_cputime = | |
870 | sub { | |
871 | $h{$b}->{cputime} <=> $h{$a}->{cputime} | |
872 | or $a cmp $b; | |
873 | }; | |
874 | ||
875 | ||
876 | print qq@<HTML> | |
877 | <HEAD> | |
878 | <TITLE>Slow results - GNU Go</TITLE> | |
879 | <META NAME="ROBOTS" CONTENT="NOINDEX, NOFOLLOW"> | |
880 | </HEAD>\n@; | |
881 | print "<BODY><H4>Slow results</H4>"; | |
882 | print "<TABLE border=1>"; | |
883 | print "<TR><TD><B>Problem</B></TD><TD><B>Status</B></TD><TD>CPU Time</TD></TR>\n"; | |
884 | ||
885 | my $i = 0; | |
886 | foreach my $k (sort $by_cputime keys %h) { | |
887 | $i++; | |
888 | last if $i > 50; | |
889 | print qq@<TR><TD><A href="$name?$k">$k</TD><TD>$h{$k}->{status}</TD>@; | |
890 | print qq@ <TD>$h{$k}->{cputime}</TD></TR>@; | |
891 | my ($p, $n) = $k =~ /(\w+):(\d+)/; | |
892 | open (F, "html/$p.tst/$n.trace") or do {print "Missing trace file for $k<BR>"; next;}; | |
893 | my $first=1; | |
894 | while (<F>) { | |
895 | my $line = $_; | |
896 | if ($line =~ /^owl_.*\d{6} nodes/) { | |
897 | print qq@<TR><TD> </TD><TD> </TD><TD>@ if $first-- > 0; | |
898 | print qq@$line<BR>@; | |
899 | } | |
900 | } | |
901 | print qq@</TD></TR>@ if $first < 1; | |
902 | close F; | |
903 | } | |
904 | print "</TABLE></BODY></HTML>\n"; | |
905 | } | |
906 | ||
907 | sub printspecial { | |
908 | our $VAR1; | |
909 | do "html/one.perldata.new" or confess "can't do perldata"; | |
910 | my %h = %{$VAR1->[0]}; | |
911 | ||
912 | my (%special); | |
913 | my $sfile = "special"; | |
914 | ||
915 | print qq@<HTML> | |
916 | <HEAD><TITLE>Special results - GNU Go</TITLE> | |
917 | <META NAME="ROBOTS" CONTENT="NOINDEX, NOFOLLOW"> | |
918 | </HEAD>\n@; | |
919 | print "<BODY><H4>Special results</H4>"; | |
920 | ||
921 | print "<TABLE border=1>"; | |
922 | print "<TR><TD><B>Problem</B></TD><TD><B>Status</B></TD><TD>cputime</TD></TR>\n"; | |
923 | ||
924 | if (-e $sfile) { | |
925 | open (BF, $sfile); | |
926 | while (<BF>) { | |
927 | if (/^((\w+):(\d+))/) { | |
928 | print qq@<TR><TD><A href="$name?$1">$1</A></TD><TD>$h{$1}->{status}</TD>@ . | |
929 | qq@<TD>$h{$1}->{cputime}</TD></TR>\n@; | |
930 | } | |
931 | } | |
932 | close(BF); | |
933 | } | |
934 | print qq@</TABLE></BODY></HTML>@; | |
935 | } | |
936 | ||
937 | ||
938 | sub printunexpected{ | |
939 | my (%breakage); | |
940 | if (-e 'BREAKAGE.local') { | |
941 | open (BF, 'BREAKAGE.local'); | |
942 | while (<BF>) { | |
943 | if (my ($bfile, $bpf) = $_ =~ /^(\w+:\d+)\s+(FAILED|PASSED)/i) { | |
944 | $breakage{lc $bfile} = $bpf; | |
945 | } | |
946 | } | |
947 | close(BF); | |
948 | } | |
949 | ||
950 | ||
951 | our $VAR1; | |
952 | do "html/one.perldata.new" or confess "can't do perldata"; | |
953 | my %h = %{$VAR1->[0]}; | |
954 | ||
955 | my @fails; my @ufails; | |
956 | my @passes; my @upasses; | |
957 | ||
958 | ||
959 | print qq@<HTML><HEAD> | |
960 | <TITLE>Unexpected results - GNU Go</TITLE> | |
961 | <META NAME="ROBOTS" CONTENT="NOINDEX, NOFOLLOW"> | |
962 | </HEAD>\n@; | |
963 | print "<BODY><H4>Unexpected results</H4>"; | |
964 | ||
965 | sub bynamenumber { | |
966 | my ($aname, $anumber) = $a =~ /(.*):(.*)/; | |
967 | my ($bname, $bnumber) = $b =~ /(.*):(.*)/; | |
968 | $aname cmp $bname or | |
969 | $anumber <=> $bnumber or | |
970 | $a cmp $b; | |
971 | } | |
972 | ||
973 | foreach my $k (sort bynamenumber keys %h) { | |
974 | my $status = %{$h{$k}}->{status}; | |
975 | defined $status or do { warn "missing status for $k"; next;}; | |
976 | if ($status eq 'FAILED') { | |
977 | unless (defined ($breakage{lc $k}) and $breakage{lc $k}eq 'FAILED') { | |
978 | push @ufails, $k; | |
979 | } | |
980 | } elsif ($status eq 'PASSED') { | |
981 | unless (defined ($breakage{lc $k}) and $breakage{lc $k} eq 'PASSED') { | |
982 | push @upasses, $k; | |
983 | } | |
984 | } elsif ($status eq 'passed') { | |
985 | if (defined ($breakage{lc $k})) { | |
986 | push @passes, $k; | |
987 | } | |
988 | } elsif ($status eq 'failed') { | |
989 | if (defined ($breakage{lc $k})) { | |
990 | push @fails, $k; | |
991 | } | |
992 | } | |
993 | } | |
994 | ||
995 | print "<TABLE border=1>\n"; | |
996 | print qq@<TR><TD>FAILS</TD><TD>@.scalar(@ufails).qq@</TD></TR>\n@; | |
997 | print qq@<TR><TD>fails</TD><TD>@.scalar(@fails).qq@</TD></TR>\n@; | |
998 | print qq@<TR><TD>PASSES</TD><TD>@.scalar(@upasses).qq@</TD></TR>\n@; | |
999 | print qq@<TR><TD>passes</TD><TD>@.scalar(@passes).qq@</TD></TR>\n@; | |
1000 | print qq@<TR><TD>pass : fail</TD><TD>@. | |
1001 | sprintf("%.2f : 1", ((@upasses + @passes) / (@ufails + @fails + .001))). | |
1002 | qq@</TD></TR>\n@; | |
1003 | print "</TABLE><BR>\n"; | |
1004 | ||
1005 | print "<TABLE border=1>"; | |
1006 | print "<TR><TD><B>Problem</B></TD><TD><B>Status</B></TD></TR>\n"; | |
1007 | foreach (@ufails) { | |
1008 | print qq@<TR><TD><A href="$name?$_">$_</A></TD><TD>FAILED</TD></TR>\n@; | |
1009 | } | |
1010 | foreach (@fails) { | |
1011 | print qq@<TR><TD><A href="$name?$_">$_</A></TD><TD>failed</TD></TR>\n@; | |
1012 | } | |
1013 | foreach (@upasses) { | |
1014 | print qq@<TR><TD><A href="$name?$_">$_</A></TD><TD>PASSED</TD></TR>\n@; | |
1015 | } | |
1016 | foreach (@passes) { | |
1017 | print qq@<TR><TD><A href="$name?$_">$_</A></TD><TD>passed</TD></TR>\n@; | |
1018 | } | |
1019 | print "</TABLE>\n"; | |
1020 | print "</body></html>\n"; | |
1021 | ||
1022 | ||
1023 | } | |
1024 | ||
1025 | ||
1026 | ||
1027 | sub printbycategory { | |
1028 | ||
1029 | our $VAR1; | |
1030 | do "html/one.perldata.new" or confess "can't do perldata"; | |
1031 | my %hash = %{$VAR1->[0]}; | |
1032 | ||
1033 | my %fails; | |
1034 | ||
1035 | foreach my $k (keys %hash) { | |
1036 | my $status = $hash{$k}{status}; | |
1037 | $fails{$k} = $hash{$k} if $status =~ /failed/i; | |
1038 | } | |
1039 | ||
1040 | my $by_cat = | |
1041 | sub { | |
1042 | defined $fails{$a}{file} | |
1043 | or do { | |
1044 | print '$a:'."$a\n"; | |
1045 | confess "missing file"; | |
1046 | }; | |
1047 | ||
1048 | my $ca = $fails{$a}{category}; | |
1049 | my $cb = $fails{$b}{category}; | |
1050 | defined $ca or $ca = 0; | |
1051 | defined $cb or $cb = 0; | |
1052 | ||
1053 | if ($ca ne "" and $cb eq "") { return -1; } | |
1054 | if ($ca eq "" and $cb ne "") { return 1; } | |
1055 | ||
1056 | $ca ne "" or $ca = $fails{$a}{file}; | |
1057 | $cb ne "" or $cb = $fails{$b}{file}; | |
1058 | ||
1059 | uc ($ca) cmp uc($cb) | |
1060 | or | |
1061 | do { | |
1062 | my $sa = $fails{$a}{severity}; | |
1063 | my $sb = $fails{$b}{severity}; | |
1064 | #print '$sa <=> $sb :' . "$sa <=> $sb ($ca, $cb)" , "\n" | |
1065 | # if defined $sa and defined $sb and ($sa ne "") and ($sb ne ""); | |
1066 | defined $sa or $sa = 5; | |
1067 | defined $sb or $sb = 5; | |
1068 | if ($sa eq "") {$sa = 5}; | |
1069 | if ($sb eq "") {$sb = 5}; | |
1070 | -($sa <=> $sb); | |
1071 | } | |
1072 | or | |
1073 | do { | |
1074 | my $fa = $fails{$a}{file}; | |
1075 | my $fb = $fails{$b}{file}; | |
1076 | $fa cmp $fb; | |
1077 | } | |
1078 | or | |
1079 | do { | |
1080 | my $na = $fails{$a}{num}; | |
1081 | my $nb = $fails{$b}{num}; | |
1082 | $na <=> $nb; | |
1083 | } | |
1084 | }; | |
1085 | ||
1086 | sub getcat(%) { | |
1087 | my %h = %{shift()}; | |
1088 | $h{category} or $h{file}; | |
1089 | } | |
1090 | sub getsev(%) { | |
1091 | my %h = %{shift()}; | |
1092 | my $s = $h{severity}; | |
1093 | defined $s or do {return 5}; | |
1094 | $s ne "" or do {return 5}; | |
1095 | no warnings qw/numeric/; | |
1096 | $s+0; | |
1097 | } | |
1098 | ||
1099 | print qq@<HTML><HEAD> | |
1100 | <TITLE>Failures by category - GNU Go</TITLE> | |
1101 | <META NAME="ROBOTS" CONTENT="NOINDEX, NOFOLLOW"> | |
1102 | </HEAD>\n@; | |
1103 | print "<BODY><H4>Failures by category</H4>"; | |
1104 | print qq@<A href="$name?">main index</A>@; | |
1105 | ||
1106 | ||
1107 | print "<TABLE border=1>"; | |
1108 | print "<TR><TD><B>Category</B></TD><TD><B>Severity</B></TD><TD><B>Problem</B></TD>\n"; | |
1109 | my $cat = ""; | |
1110 | my $sev = ""; | |
1111 | foreach my $k (sort $by_cat keys %fails) { | |
1112 | if (uc(getcat($fails{$k})) ne $cat) { | |
1113 | $cat = uc(getcat($fails{$k})); | |
1114 | print "</TD></TR>\n"; | |
1115 | print "<TR><TD>$cat</TD>\n"; | |
1116 | $sev = ""; | |
1117 | } | |
1118 | if (($sev eq "") or $sev != getsev($fails{$k})) { | |
1119 | print "</TD></TR>\n<TR><TD> </TD>" if ($sev ne ""); | |
1120 | $sev = getsev($fails{$k}); | |
1121 | print "<TD>$sev</TD><TD>\n"; | |
1122 | } | |
1123 | print qq@<A href="$name?$k">$k</A>  </A>\n@; | |
1124 | } | |
1125 | print "</TABLE>\n"; | |
1126 | print "</body></html>\n"; | |
1127 | ||
1128 | } |