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 44use strict; 45use warnings; 46 47use CGI qw/:standard/; 48use CGI::Carp 'fatalsToBrowser'; 49 50use FindBin; 51use lib "$FindBin::Bin/../interface"; 52 53use GoImage::Stone; 54 55use 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 62my $name = "regress.plx"; 63 64my $debug=2; 65 66my %colors = ("ALIVE", "green", 67 "DEAD", "cyan", 68 "CRITICAL", "red", 69 "UNKNOWN", "yellow", 70 "UNCHECKED", "magenta"); 71 72my $query = new CGI; 73my ($tstfile, $num, $sortby, $sgf, $reset, $trace, $bycat, 74 $unexpected, $slow, $special, $move, $small); 75 76($tstfile, $num) = ($query->query_string() =~ /keywords=(.*)%3A(.*)/); 77 78if (!$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 93sub sgfFile(%); 94 95 96#print "HTTP/1.0 200 OK\r\n"; 97print "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 105if ($tstfile) { 106 $tstfile = $1 if $tstfile =~ /(.*)\.tst$/; 107} 108if ($tstfile && !($tstfile =~ /^[a-zA-Z0-9_]+$/)) { 109 print "bad test file: $tstfile\n"; 110 exit; 111} 112 113if ($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 120if ($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 133my %points; 134 135unless ($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 177my %fullHash; 178#use Data::Dumper; 179 180sub insinglequote { 181 my $s = shift; 182 $s =~ s@\\@\\\\@g; 183 $s =~ s@'@\\'@g; 184 return "'$s'"; 185} 186 187sub 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 210sub 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 317sub bypPfF { 318 pPfFtonum($a) <=> pPfFtonum($b); 319} 320 321sub pPfFtonum { 322 $_ = shift; 323 s/FAILED/4/; s/failed/3/; s/PASSED/2/; s/passed/1/; 324 $_; 325} 326 327sub fptonum { 328 $_ = shift; 329 s/FAILED/1/; s/failed/3/; s/PASSED/2/; s/passed/4/; s/<B>//; s@</B>@@; 330 $_; 331} 332 333my @counters = qw/connection_node owl_node reading_node trymove/; 334 335if ($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 375if ($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 550sub 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 603my %files; 604sub 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 737sub 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 756sub 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 808sub 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 821sub 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 853sub 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 865sub 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 907sub 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 938sub 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 1027sub 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} 1129