# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# This program is distributed with GNU Go, a Go program. #
# Write gnugo@gnu.org or see http://www.gnu.org/software/gnugo/ #
# for more information. #
# Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 #
# and 2008 by the Free Software Foundation. #
# This program is free software; you can redistribute it and/or #
# modify it under the terms of the GNU General Public License #
# as published by the Free Software Foundation - version 3 #
# or (at your option) any later version. #
# This program is distributed in the hope that it will be #
# useful, but WITHOUT ANY WARRANTY; without even the implied #
# warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR #
# PURPOSE. See the GNU General Public License in file COPYING #
# You should have received a copy of the GNU General Public #
# License along with this program; if not, write to the Free #
# Software Foundation, Inc., 51 Franklin Street, Fifth Floor, #
# Boston, MA 02111, USA. #
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# Here is a perlscript regress.pl. Its purpose is to run
# the regression tests that are currently implemented with
# shells and awk scripts.
regress.pl --goprog \'<path to program> --mode gtp [program options]\' \\
--testfile \'<path to gtp test file>\' \\
--all_batches Ignores --testfile, gets test files from Makefile.in
--numbers \'regexp of test numbers the next test after which won\'t be run\'
--verbose 0 (very quiet) --verbose 1 (to list moves) or --verbose 2 (to draw board)
[FIXME: verbose levels not well defined.]
--html 0 (to not generate html) or --html 1 (default - generate html file w/ results)
"DYNAMIC_CONNECTION", "Dynamic Connection Reading",
my $goprog_in ; # stdin of computer player
my $goprog_out; # stdout of computer player
my $goprog_err; # stderr of computer player
my $boardsize = 19; #current boardsize
my $goprog_name = "unknown";
my $goprog_version = "0";
my $goprog_timestamp = 0;
my @counters = qw
/connection_node owl_node reading_node trymove/;
"goprog|g=s" => \
$goprog,
"verbose|v=i" => \
$verbose,
"numbers|n=s" => \
$numbers,
"all_batches|all-batches|a=i" => \
$all_batches,
"make_images|m=i" => \
$make_images,
"problemset|ps|p=s" => \
$problem_set,
"sgf|sgf|s=i" => \
$generate_sgf,
my $s = (lc ($^O
) eq 'mswin32') ?
'\\' : '/';
$goprog = "..${s}interface${s}gnugo";
$goprog .= " --mode gtp --quiet -t -w -d0x101840 --showtime";
die $helpstring unless defined $goprog;
# if $numbers matches the current test number, then read it to mean:
# "inhibit all gtp commands AFTER the matching number, until the next
# numbered test, then resume."
$numbers = "^($numbers)\$";
$goprog_in = new FileHandle
; # stdin of computer player
$goprog_out = new FileHandle
; # stdout of computer player
$goprog_err = new FileHandle
; # stdout of computer player
print "Go program: $goprog\n" if $verbose > 1;
$pidg = open3
($goprog_in, $goprog_out, $goprog_err, $goprog)
or die "Couldn't launch GNU Go: $!";
print "goprog pid: $pidg\n" if $verbose > 1;
my ($goprog_exe) = split (" ", $goprog);
or ($goprog_exe = "$goprog_exe.exe") && -e
$goprog_exe
or die "Couldn't locate go program: $goprog_exe";
$goprog_timestamp = (stat $goprog_exe)->mtime;
($goprog_name = $1) =~ s/\s*$//;
($goprog_version = $1) =~ s/\s*$//;
print "Name: " . $goprog_name ." ". $goprog_version . "\n" if $verbose > 1;
print "waiting\n" if $verbose > 2;
print "done waiting\n" if $verbose > 2;
open(F
, $problem_set) or confess
"can't open problem set: $problem_set";
next if ($_ =~ /^\s*(#.*)?$/);
last if ($_ =~ /DONE|STOP/);
my ($filename, $probnum) = $_ =~ /^([^:]*):(\d+)/;
if (!defined $filename) {
warn "Unexpected line: $_";
$filename =~ s/(\.tst)$//;
push @
{$filehash{$filename}}, $probnum;
open(F
, $problem_set) or confess
"can't open problem set: $problem_set";
next if ($_ =~ /^\s*(#.*)?$/);
my ($filename, $probnum) = $_ =~ /^(.*):(\d+)/;
last unless defined $filename;
$filename =~ s/(\.tst)$//;
if (exists ($filehash{$filename}) ){
regress_file
("$filename.tst", @
{$filehash{$filename}});
delete $filehash{$filename};
while ($file_count <= $#ARGV) {
$curtstfile = $ARGV[$file_count];
#unlink "html/index.html";
unlink "html/$curtstfile/index.html";
print "regressing file $ARGV[$file_count]\n" if $verbose > 1;
unlink "html/$curtstfile/index.html";
regress_file
($ARGV[$file_count]);
@failed_links = @FAILED_links = ();
print "waiting\n" if $verbose > 1;
print "done waiting\n" if $verbose > 1;
my @problist = sort {$a<=>$b} @_;
print ": ", join (" ", @problist), "\n" if @problist;
($g_curtestfile) = $testfile =~ /(.*)\.tst$/ or confess
"Unparsable test file: $testfile";
-e
"html" or mkdir "html" or die "Couldn't create html";
-e
"html/$testfile" or mkdir "html/$testfile" or die "Couldn't create html/$testfile";
unless ($one_gg_process) {
$goprog_in = new FileHandle
; # stdin of computer player
$goprog_out = new FileHandle
; # stdout of computer player
$goprog_err = new FileHandle
; # stderr of computer player
$pidg = open3
($goprog_in, $goprog_out, $goprog_err, $goprog);
print "goprog pid: $pidg\n" if $verbose > 1;
unless ($childpid = fork) {
open (TRACER
, ">tracer.ttt");
while (defined(my $t = <$goprog_err>)) {
last if $t =~ /^ALL DONE/;
print "ERR: $t" if $verbose > 2;
if ($t =~ /^\s*FINISHED PROBLEM:\s*$/ or
$t =~ /^\s*SKIPPED PROBLEM:\s*$/) {
close TRACER
or die "Couldn't close temp trace file";
print "closed trace file\n" if $verbose > 2;
if ($t =~ /^\s*FINISHED PROBLEM:\s*$/) {
rename "tracer.ttt", "$num.trace"
or die "Couldn't rename tracer: $testfile, $num";
open (TRACER
, ">tracer.ttt");
go_command
("reset_${_}_counter");
$pidt = open ($testfile_out,"<$testfile") or confess
"Can't open $testfile";
print "testfile pid: $pidt\n" if $verbose > 1;
$cputime = <$goprog_out>;
print "cputime: $cputime\n" if $verbose > 1;
($cputime) = ($cputime =~ /((\d|\.)+)/);
while (defined($next_cmd))
$next_cmd = <$testfile_out>;
if (defined($next_cmd)) {
print "NEXT_CMD: '$next_cmd'\n" if ($verbose > 1);
if (($next_cmd =~ /^\s*#\?\s+\[(\!*)(.*)\]\s*(\*)*(\&)*\s*$/)) {
if ($1) { $negate = 1} else {$negate = 0};
if ($3) { $fail = 1} else { $fail = 0};
if ($4) {$ignore = 1} else {$ignore = 0};
$skipping = (@problist &&
eval {foreach my $i (@problist) { return 0 if $i == $num} return 1;} );
go_command
("echo_err SKIPPED PROBLEM:\n");
go_command
("echo_err FINISHED PROBLEM:\n");
go_command
("echo_err $num\n");
print "$g_curtestfile:$num skipped.\n" if $verbose > 1;
tally_result
($num, "skipped", " ", " ");
print "TST:$negate - $correct_re - $fail - $ignore\n" if $verbose>1;
my $match_result = $result =~ /^$correct_re$/ ;
$match_result = ! $match_result;
tally_result
($num,"PASSED","$bang$correct_re","$result");
tally_result
($num,"passed","$bang$correct_re","$result");
tally_result
($num,"FAILED","$bang$correct_re","$result");
tally_result
($num,"failed","$bang$correct_re","$result");
$old_whole_gtp = $html_whole_gtp;
if (!($next_cmd =~ /^\s*$/)) {
$html_whole_gtp .= " " . html_encode
($next_cmd) . "<BR>\n";
$next_cmd =~ s/^\s*$//; $next_cmd =~ s/^#.*$//;
$force_read = $next_cmd eq ""
if (defined($next_cmd)) {
my ($this_number) = $next_cmd =~ /^([0-9]+)/;
$skipping = (defined($this_number) &&
eval {foreach my $i (@problist) {return 0 if $i == $this_number} return 1;} ));
#print "SKIPPING: $next_cmd ($this_number)\n";
#print "NOT SKIPPING: $next_cmd\n";
if ($next_cmd =~ /reg_genmove\s+([blackwhite])+/) {
$next_cmd =~ s/reg_genmove\s+([blackwhite]+)/top_moves_$1/;
if (defined($this_number)
&& $next_cmd =~ /attack|defend/
go_command
("start_sgftrace");
($result, $_) = split(/ /, $top_moves, 2);
print "TopMoves:$top_moves\n" if $verbose > 1;
if (!defined($result)) {$result="";}
print "RES: $result\n" if $verbose > 1;
if (defined($this_number) && $next_cmd =~ /attack|defend/) {
go_command
("finish_sgftrace html$s$testfile$s$this_number.sgf");
unlink "html$s$testfile$s$this_number.sgf";
if (defined $this_number) {$num = $this_number;}
if ($unexpected_pass == 1) {
if ($unexpected_fail == 1) {
$fail_string = "failure";
$fail_string = "failures";
print "Summary: $passes/" . ($passes + $failures) .
" passes. $unexpected_pass unexpected $pass_string, "
. "$unexpected_fail unexpected $fail_string\n";
unless ($one_gg_process) {
go_command
("echo_err ALL DONE");
print "waiting on child\n" if $verbose > 1;
print "done waiting on child\n" if $verbose > 1;
print "waiting\n" if $verbose > 1;
print "done waiting\n" if $verbose > 1;
(my $number, my $status, my $correct, my $incorrect) = @_;
my $showboard = $status ne "skipped";
$passes++ if $status eq "passed";
$unexpected_pass++ if $status eq "PASSED";
$failures++ if $status eq "failed";
$unexpected_fail++ if $status eq "FAILED";
if (($verbose and $status ne "skipped") or
(!$verbose and ($status eq "PASSED" or $status eq "FAILED")) ) {
print "$g_curtestfile:$number: $status: correct: $correct answer: $incorrect\n";
$cur_passed = ($status =~ /pass/i);
mkdir ("html/$testfile");# die quietly - probably already exists.
my $brd = new FileHandle
;
open ($brd, "> html/$testfile/$num.xml") || die "ERROR: couldn't crate xml board: $!\n";
my $brdout = eat_board
();
print $brd "<GOPROB filepos=$filepos number=$num file=\"$testfile\" status=\"$status\">\n";
print $brd qq@
<ENGINE version
="$goprog_version" name
="goprog_name" timestamp
="goprog_timestamp">\n@
;
print $brd "<CORRECT>$correct</CORRECT>\n";
print $brd "<ANSWER>$incorrect</ANSWER>\n";
if ($html_whole_gtp !~ /^\s*loadsgf/m) {
$old_whole_gtp .= $html_whole_gtp;
$html_whole_gtp = $old_whole_gtp;
print $brd "<GTP_ALL>\n$html_whole_gtp\n</GTP_ALL>";
foreach my $listval ("DESCRIPTION", "CATEGORY", "SEVERITY") {
$html_whole_gtp =~ /$listval=(.*?)<BR>/;
if (defined($1)) {$astxt = $1;} else {$astxt = "";};
print $brd "<$listval>$astxt</$listval>\n";
go_command
("get_${_}_counter");
defined($counts) or confess
"Missing count";
defined($counters{$_}) or confess
"Missing counter";
my $countdelta = $counts - $counters{$_};
print $brd qq@
\n $_="$countdelta"@
;
my $new_cputime = <$goprog_out>;
($new_cputime) = ($new_cputime =~ /((\d|\.)+)/);
print "cputime: ".$new_cputime."\n" if $verbose > 1;
print $brd "<TIME wall=0.0 CPU=" . sprintf("%.5f", $new_cputime - $cputime) . ">\n";
print $brd "<GTP_COMMAND>$prev_cmd</GTP_COMMAND>\n";
print $brd "<TRACE_OUTPUT>$trace_output</TRACE_OUTPUT>\n";
print $brd "</GOPROB>\n";
go_command
("query_boardsize");
(undef, $boardsize) = split(' ', $line, 2);
$boardsize = $boardsize + 0;
my $linesleft = $boardsize + 2;
my $cur_matcher_status = 0;
my $white_letter = chr(ord('z')+1);
my $black_letter = chr(ord('A')-1);
if ($prev_cmd =~ /reg_genmove/) {
#FIXME: There may be other commands that won't require dragon_data
#to be regenerated. Better might be to provide a way to query the
#engine whether dragon_data is currently available w/out regenerating.
go_command
("dragon_data\n");
$iline = $_ = <$goprog_out>;
if ($iline =~ /^\?(.*)/) {
$iline = $_ = <$goprog_out>;
if ($iline =~ /^=?\s*([A-Z][0-9][0-9]?):\s*$/ || !$iline) {
if ($cur_color eq "white") {
$_ = $white_letter = chr(ord($white_letter)-1);
} elsif ($cur_color eq "black" || die "invalid color $cur_color") {
$_ = $black_letter = chr(ord($black_letter)+1);
$dragons{$cur_point} = $_ . ";status=" . $cur_dragon_status .
";owl_status=" . $cur_owl_status .
";color_letter=" . $cur_color_letter.
} elsif ($iline =~ /^color:?\s+([blackwhite]*)\s*$/) {
} elsif ($iline =~ /^matcher_status:?\s+(\S*)\s*$/) {
$cur_matcher_status = $1;
} elsif ($iline =~ /^status:?\s+(\S*)\s*$/) {
} elsif ($iline =~ /^owl_status:?\s+(\S*)\s*$/) {
#we ignore lots of dragon data!
foreach $cur_color ("white", "black") {
go_command
("worm_stones $cur_color");
if ($cur_color eq "white") {
} elsif ($cur_color eq "black" || die "invalid color $cur_color") {
$splitline =~ s/^[=]\s*//;
$splitline =~ s/\s*$//mg;
foreach (split (/\s+/,$splitline)) {
$stones{$_} =";color_letter=" . $cur_color_letter.
if ($prev_cmd =~ /^[0-9]*\s*reg_genmove/) {
if (! ($next_cmd =~ /^#\?\s*\[(!)?\(?(.*)\)?\]\*?\s*$/)) {
print "BAD TEST: $next_cmd\n";
#$1 and $2 are just $bang and $correct_re, right?
#print "Genmove test:\n";
foreach (split(/\|/,$2)) {
$stones{$_} .= ";known_wrong;";
$stones{$_} .= ";known_right;";
$stones{$result} .= ";try_right;";
$stones{$result} .= ";try_wrong;";
# Experimental - should work for reg_genmove too!
if (! ($next_cmd =~ /^#\?\s*\[(!)?\(?(.*)\)?\]\*?\s*$/)) {
print "BAD TEST: $next_cmd\n";
} #see commend on this regex above.
#Here, look for something that looks like a move!
while ($known =~ s/([A-Z]\d\d?)//) {
$stones{$1} .= ";known_wrong;";
$stones{$1} .= ";known_right;";
while ($try =~ s/([A-Z]\d\d?)//) {
$stones{$1} .= ";try_right;";
$stones{$1} .= ";try_wrong;";
while ($pc =~ s/([A-Z]\d\d?)//) {
$stones{$1} .= ";question;";
unless ($no_dragon_data) {
#FIXME: This data is available via the strings line from dragon_data.
go_command
("dragon_stones");
$iline = " " . $iline . " ";
foreach (keys(%dragons)) {
my $label = $dragons{$k};
if ($iline =~ (" ".$k." ")) {
foreach (split(/ /,$iline)) {
if ($prev_cmd =~ /.*reg_genmove\s+([whiteblack]+)/) {
go_command
("top_moves");
my $top_moves = <$goprog_out>;
$top_moves =~ s/\s*$//mg;
print "TOP_MOVES:'$top_moves'\n" if $verbose > 1;
if ($top_moves =~ /^\s*(.*)\s*/) { #i.e. always!
%tmarr = split(/\s+/,$t);
foreach my $k (keys(%tmarr)) {
$stones{$k} .= ";move_value=$tmarr{$k};";
for ($j = $boardsize; $j > 0; $j--) {
for ($i = 1; $i <= $boardsize; $i++) {
my $iA = ord('A') + $i - 1;
if ($iA >= ord('I')) { $iA++; }
$point .= qq/ coord="$iA$j"\n/;
my $status = $stones{$iA.$j};
if ($status =~ /(.).*;owl_status=([^;]*);/) {
$point .= qq/ owl_status="$2"\n/;
if ($status =~ /(.).*;status=([^;]*);/) {
$point .= qq/ dragon_letter="$1"\n/;
$point .= qq/ dragon_status="$2"\n/;
if ($status =~ /;color_letter=([^;]*);/) {
$point .= qq/ stone="/ . (($1 eq 'X') ?
'black' : 'white') . qq/"\n/;
if ($status =~ /;move_value=([^;]*);/) {
$point .= qq/ move_value="$1"\n/;
$point .= qq/ known="wrong"\n/ if ($status =~ /;known_wrong;/);
$point .= qq/ known="right"\n/ if ($status =~ /;known_right;/);
$point .= qq/ try="right"\n/ if ($status =~ /;try_right;/);
$point .= qq/ try="wrong"\n/ if ($status =~ /;try_wrong;/);
$point .= qq/ question="1"\n/ if ($status =~/;question;/);
$xboard .= " <POINT\n" . $point . " ></POINT>\n";
return "<BOARD size=$boardsize>\n" . $xboard . "</BOARD>\n";
chop($line = <$goprog_out>) or confess
"No response!";
my ($equals, $move) = split(' ', eat
(), 2);
print $goprog_in "$cmd\n";
print "CMD:$cmd\n" if $verbose > 1;
if ($cmd =~ /reset_${_}_counter/) {
#i.e.: <TD><IMG HEIGHT=25 WIDTH=25 SRC="../images/B25x43_green.png"></TD>
if ($line =~ /SRC=.*images.(.*)\"><.TD>.*/) {
print " found: $1\n" unless ($images{$1});
opendir $CURDIR, $curdir;
while (local $curfile = readdir $CURDIR) {
#print "X:".($curfile=~/^\.+$/)."\n";
if ((-d
) && !($curfile=~/^\.{1,2}$/)) {
print "diving into: $curdir/$curfile\n" if $verbose>2;
extract_image_dir
("$curdir/$curfile");
} elsif (($curfile =~ /\.html$/) && ($curdir =~ /d2/)) {
print "processing: $curdir/$curfile\n" if $verbose;
open IMGFILE
, "<$curdir/$curfile" or die "Couldn't open: $curdir/$curfile" ;
#print "no match: $curdir/$curfile\n" if $verbose;
print "Starting processing\n" if $verbose;
extract_image_dir
(".") ;
print "Processed files, generated ".((scalar keys(%images))/2)
." unique images:\n" if $verbose;
foreach (keys(%images)) {
print "Done.\n" if $verbose;
open (MAKEFILE
, "< Makefile.in");
my $target_reg = "^" . join ("|", @targets) . ":" ;
open (MAKEFILE
, "< Makefile.in");
push @files, $_ =~ /\s+(\w+\.tst)/;
chop if defined($_ = <MAKEFILE
>);