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>&nbsp;</TD>
409   <TD>cputime:</TD><TD>$attribs{"cputime"}</TD>
410 </TR><TR>
411   <TD>status:</TD><TD>$attribs{"status"}</TD><TD>&nbsp;</TD>
412   <TD>$counters[0]:</TD><TD>$attribs{"$counters[0]_counter"}</TD>
413 <TR>
414   <TD>correct:</TD><TD>$attribs{"correct"}</TD><TD>&nbsp;</TD>
415   <TD>$counters[1]:</TD><TD>$attribs{"$counters[1]_counter"}</TD>
416 <TR>
417   <TD>answer:</TD><TD>$attribs{"answer"}</TD><TD>&nbsp;</TD>
418    <TD>$counters[2]:</TD><TD>$attribs{"$counters[2]_counter"}</TD>
419 <TR>
420   <TD>gtp:</TD><TD>$attribs{"gtp_command"}</TD><TD>&nbsp;</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>&nbsp;&nbsp;&nbsp;<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>&nbsp;$j&nbsp;</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>&nbsp;$j&nbsp;</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>&nbsp;</TD><TD>&nbsp;</TD><TD>&nbsp;</TD>"
728    . "<TD>&nbsp;</TD><TD>&nbsp;</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>&nbsp;</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>&nbsp;</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>&nbsp;</TD><TD>&nbsp;</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>&nbsp;</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>&nbsp&nbsp</A>\n@;
1124    }
1125    print "</TABLE>\n";
1126    print "</body></html>\n";
1127
1128}
1129