[ViewVC] Annotation of: cvs/kgsueme/bin/gtp-controller

#!/opt/bin/perl

# lots of things have been hardcoded. search for #d# to find the places

require 5.008;

use KGS::Protocol;
use KGS::Listener::Debug;

use IO::Socket::INET;
use Event;

use Getopt::Long;
use Carp;

our $VERSION = '0.0'; # be more confident....

$SIG{QUIT} = sub { Carp::confess "SIGQUIT" };

my $kgs;
my $gtp;

my $verbose = 1;
my $user = "gtpguest";
my $pass = undef;

$Event::DIED = sub {
   Event::verbose_exception_handler (@_);
   Event::unloop_all;
};

sub format_user($) {
   my $format =
      sprintf "%s|%s|%s",
         $_[0]{name},
         $_[0]->flags_string,
         $_[0]->rank_string;

   $format =~ y/ //d;
   $format;
}

sub coord($$) {
   qw(A B C D E F G H J K L M N O P Q R S T U V W X Y Z)[$_[0]] . $_[1];
}

#############################################################################

package kgs;

use base KGS::Listener;

my $conn = new KGS::Protocol;

sub new {
   my $class = shift;
   my $self = bless { @_ }, $class;

   print STDERR "$0 version $VERSION connecting...\n" if $verbose;

   my $sock = new IO::Socket::INET PeerHost => $ENV{KGSHOST} || "kgs.kiseido.com", PeerPort => "2379"
      or die "connect: $!";

   $sock->blocking (1);
   $conn->handshake ($sock);

   $self->listen ($conn, "any");

   # Listener for kgs data
   $self->{w} = Event->io (fd => $sock, poll => 'r', cb => sub {
      my $len = sysread $sock, my $buf, 16384;
      if ($len) {
         $conn->feed_data ($buf);
      } elsif (defined $len || (!$!{EINTR} and !$!{EAGAIN})) {
         print STDERR "disconnected\n" if $verbose;
         Event::unloop;
      }
   });

   $conn->login ("gtp-controller $VERSION", $self->{user}, delete $self->{password});

   $self;
}

sub inject_login {
   my ($self, $msg) = @_;

   print STDERR "login: $msg->{message}\n" if $verbose >= 2;

   $gtp->send ("kgs-login $msg->{message}");
}

sub inject_msg_room {
   my ($self, $msg) = @_;

   $gtp->send ("kgs-room-chat $msg->{channel} $msg->{message}");
}

sub inject_any {
   my ($self, $msg) = @_;
   if ($verbose >= 2) {
      print STDERR "DEBUG: $msg->{type}#$msg->{channel}";
      for (sort keys %$msg) {
         print  STDERR"   $_<$msg->{$_}>";
      }
      print STDERR "\n";
   }
}

sub inject_upd_rooms {
   my ($self, $msg) = @_;

   for (@{$msg->{rooms}}) {
      $gtp->send ("kgs-room-update $_->{channel} $_->{name}");
   }
}

sub inject_msg_chat {
   my ($self, $msg) = @_;

   return unless (lc $self->{conn}{name}) eq (lc $msg->{name2});

   $gtp->send ("kgs-user-chat $msg->{name} $msg->{message}");
}

#############################################################################

package room;

use base KGS::Listener::Room;

sub new {
   my $class = shift;
   my $self = $class->SUPER::new (@_);

   $self->listen ($self->{conn});
   $self->join;

   $self;
}

sub event_join {
   my $self = shift;

   $self->SUPER::join (@_);

   $self->{timer} = Event->timer (after => 0, interval => 60, cb => sub {
      $self->req_games;
   });
}

sub event_update_games {
   my ($self, $add, $upd, $del) = @_;

   for (@$add, @$upd) {
      $gtp->send (sprintf "kgs-game-update %d %d %s %s %s %s %d %d %f %d %d %d %d %s",
                  $self->{channel}, $_->{channel},
                  $_->type_char,
                  ::format_user $_->{user1},
                  ::format_user $_->{user2},
                  ::format_user $_->{user3},
                  $_->size,
                  $_->{handicap},
                  $_->{komi},
                  $_->moves,
                  $_->{flags},
                  $_->{observers},
                  $_->{saved},
                  $_->{notes},
      );
   }

   for (@$del) {
      $gtp->send ("kgs-game-delete $self->{channel} $_->{channel}");
   }
}

sub event_update_users {
   my ($self, $add, $upd, $del) = @_;

   for (@$add, @$upd) {
      $gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
   }

   for (@$del) {
      $gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
   }
}

sub DESTROY {
   my $self = shift;

   $self->{timer}->cancel if $self->{timer};

   $self->SUPER::DESTROY;
}

#############################################################################

package game;

use Gtk2::GoBoard::Constants;

use base KGS::Listener::Game;

sub new {
   my $class = shift;
   my $self = $class->SUPER::new (@_);

   $self->listen ($self->{conn});
   $self->join;

   $self;
}

sub event_update_users {
   return;

   my ($self, $add, $upd, $del) = @_;

   for (@$add, @$upd) {
      $gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
   }

   for (@$del) {
      $gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
   }
}

sub inject_resign_game {
   my ($self, $msg) = @_;

   $gtp->set_gid ($self->{channel});
   $gtp->send ("play " . (qw(b w))[$msg->{player}] . " resign");
}

sub inject_final_result {
   my ($self, $msg) = @_;

   $gtp->send (sprintf "kgs-game-score %f %f %f %f %f %f",
               $_->{whitescore}{territory}, $_->{whitescore}{captures}, $_->{whitescore}{komi},
               $_->{blackscore}{territory}, $_->{blackscore}{captures}, $_->{blackscore}{komi});
}

sub inject_set_teacher {
   my ($self, $msg) = @_;
}

sub event_update_game {
   my ($self) = @_;

   $gtp->set_gid ($self->{channel});

   # timesettings etc.
}

sub event_update_tree {
   my ($self) = @_;

   $gtp->set_gid ($self->{channel});

   my $path = $self->get_path;
   my $prev = $self->{prevpath};

   $self->{prevpath} = [ @$path ];

   if (@$prev > 1
       and @$path > @$prev
       and (join ":", @$prev) eq (join ":", @$path[0 .. $#$prev])) {

      splice @$path, @prev, $#path, ();

   } else {
      $gtp->send ("boardsize $path->[0]{rules}{size}");
      $gtp->send ("komi $path->[0]{rules}{komi}");
      $gtp->send ("clear_board");

      my $setup = shift @$path;
      my $handi;

      while (my ($k, $v) = each %$setup) {
         if ($k =~ /^(\d+),(\d+)$/) {
            $handi .= " " . ::coord $1, $2;
         }
      }

      $gtp->send ("set_free_handicap$handi");
   }

   for (@$path) {
      while (my ($k, $v) = each %$_) {
         if ($k =~ /^(\d+),(\d+)$/) {
            if ($v->[0] & MARK_MOVE) {
               if ($v->[0] & MARK_B) {
                  $gtp->send ("play b ". ::coord $1, $2);
               } else {
                  $gtp->send ("play w ". ::coord $1, $2);
               }
            }
         }
      }
   }
}

sub DESTROY {
   my $self = shift;

   $self->SUPER::DESTROY;
}

#############################################################################

package gtp;

use Fcntl;

sub new {
   my $class = shift;
   bless { @_ }, $class;
}

sub set_fh {
   my ($self, $rfh, $wfh) = @_;

   $self->{r} = $rfh;
   $self->{w} = $wfh;

   fcntl $rfh, F_SETFL, O_NONBLOCK;

   my $buf;

   Event->io (fd => $rfh, poll => 'r', cb => sub {
      my $r = sysread $rfh, $buf, 16384, length $buf;

      if (defined $r and !$r) {
         die "gtp engine sent EOF, I'm simply dying now, sorry\n";
      } else {
         $buf =~ y/\010\015/ /d;
         $buf =~ s/#[^\012](?=\012)//g; # idiotic part of gtp spec
         while () {
            if ($buf =~ s/^([=?])(?:(\d+)\s+)?(.*?)\012\012//s) { # response
               print STDERR "got response ($1|$2|$3)\n" if $verbose >= 2;

               if (my $cb = delete $self->{waitq}{$2}) {
                  $cb->($1, $3);
               } else {
                  warn "WARNING: got response if '$1 $2' without outstanding request\n";
               }
            } elsif ($buf =~ s/^(?:(\d+)\s+)?([^=?].*?)\012//s) { # command
               $self->parse_command ($1, $2);
            } elsif ($buf =~ s/^\s*\012//) {
               # ignore, idiotic part of gtp spec
            } else {
               last;
            }
         }
      }
   });

   # generate login commands
   $self->send ("protocol_version", sub { $self->{pversion} = $_[1] });
   $self->send ("name", sub { $self->{name} = $_[1] });#d#
   $self->send ("version", sub { $self->{version} = $_[1] });
}

sub run_engine {
   my ($self, @argv) = @_;

   require IPC::Open2;

   my ($r, $w);

   IPC::Open2::open2 ($r, $w, @argv)
      or die "unable to start @argv: $!";

   $self->set_fh ($r, $w);
}

sub send {
   my ($self, $cmd, $cb) = @_;

   # first check for known_command

   my $id = ++$self->{id};

   $cmd =~ y/\015//d;
   $cmd =~ s/\012/\\n/g;

   $self->{waitq}{$id} = $cb || sub { };
   print { $self->{w} } "$id $cmd\012";
}

sub reply {
   my ($self, $id, $response) = @_;

   print { $self->{w} } "=$id $response\012";
}

sub reply_err {
   my ($self, $id, $response) = @_;

   print { $self->{w} } "?$id $response\012";
}

sub parse_command {
   my ($self, $id, $cmd) = @_;

   print STDERR "got command $cmd\n" if $verbose >= 2;

   $cmd =~ s/\s+$//;

   if ($cmd eq "kgs-room-list") {
      # no args, just request all rooms
      $kgs->send (list_rooms => group => $_) for 0..5;
      $self->reply ($id, "");

   } elsif ($cmd =~ /^kgs-room-join\s+(\d+)$/) {
      $kgs->{room}{$1} = new room conn => $kgs->{conn}, channel => $1;
      $self->reply ($id, "");
   } elsif ($cmd =~ /^kgs-room-chat\s+(\d+)\s(.*)$/) {
      $kgs->{room}{$1}->say ($2);
      $self->reply ($id, "");
   } elsif ($cmd =~ /^kgs-room-part\s+(\d+)$/) {
      (delete $kgs->{room}{$1})->part ($2);
      $self->reply ($id, "");

   } elsif ($cmd =~ /^kgs-game-join\s+(\d+)$/) {
      $kgs->{game}{$1} = new game conn => $kgs->{conn}, channel => $1;
      $self->reply ($id, "");
   } elsif ($cmd =~ /^kgs-game-chat\s+(\d+)\s(.*)$/) {
      $kgs->{game}{$1}->say ($2);
      $self->reply ($id, "");
   } elsif ($cmd =~ /^kgs-game-part\s+(\d+)$/) {
      (delete $kgs->{game}{$1})->part ($2);
      $self->reply ($id, "");

   } elsif ($cmd =~ /^kgs-user-chat\s+(\S+)\s+(.*)$/) {
      $kgs->send (msg_chat =>
                  name => $kgs->{user},
                  name2 => $1,
                  message => $2);
      $self->reply ($id, "");

   } else {
      $self->reply_err ($id, "illegal command");
   }
}

sub set_gid {
   my ($self, $gid) = @_;

   if ($gid != $self->{gid}) {
      $self->send ("kgs-game-id $gid");
      $self->{gid} = $gid;
   }
}

package main;

sub usage {
   print STDERR <<EOF;
Usage: $0 [options] -- engine engine-args...
           -u username    usernmae to connect
           -p password    optional password to connect (none => guest)
           -v             increase verbosity
           -q             decrease verbosity

$0 connects to the kiseido go server, starts the named engine
and communicates with it using GTP protocol using it's stdin and stdout.

If no engine is given, uses stdin/stdout itself for communications.

The engine can optionally act as controller, too, as long as it isn't
confused by responses on it's command input stream.

Command extension used by the controller:

kgs-login message
kgs-room-update <rid> <name>          # update room info
kgs-room-chat <rid> <user> <message>  # somebody says sth.
kgs-game-update <rid> <gid> <type> <user1> <user2> \
                <user3> <size> <handicap> <komi> <moves> \
                <flags> <observers> <saved> <notes>
kgs-game-delete <rid> <gid>           # game removed
kgs-user-update <rid> <user>          # user added/updated   
kgs-user-delete <rid> <user>          # user removed

kgs-game-resign <gid> <color>
kgs-game-score <gid> <w-territory> <w-captures> <w-komi> <b-territory> <b-captures> <b-komi>
kgs-game-id <gid>                     # set id for following gid-less commands

kgs-user-chat <user> <message>        # got private message from user
...

Commands usable by the client:

kgs-room-list                         # ask for roomlist update
kgs-room-join <rid>                   # join given room
kgs-room-chat <rid> <message>         # say sth. in room
kgs-room-part <rid>                   # leave gives room

kgs-game-join <gid>                   # join the given game
kgs-game-part <gid>                   # leave the given game
kgs-game-chat <gid> <message>         # say sth.

kgs-user-chat <user> <message>        # send private msg to user
...

EOF
   exit shift;
}

GetOptions (
      "u=s" => \$user,
      "v"   => sub { $verbose++ },
      "q"   => sub { $verbose-- },
      "h"   => sub { usage(0) },
) or die usage(1);

$gtp = new gtp;

if (@ARGV) {
   $gtp->run_engine (@ARGV);
} else {
   $gtp->set_fh (\*STDIN, \*STDOUT);
}

$kgs = new kgs user => $user, password => $pass;

Event::loop;

1;


Revision:	1.2
Committed:	Sat May 15 23:30:33 2004 UTC (20 years ago) by pcg
Branch:	MAIN
Changes since 1.1:	+440 -67 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	pcg	1.1	#!/opt/bin/perl
2
3			# lots of things have been hardcoded. search for #d# to find the places
4
5	pcg	1.2	require 5.008;
6
7	pcg	1.1	use KGS::Protocol;
8			use KGS::Listener::Debug;
9
10			use IO::Socket::INET;
11			use Event;
12
13	pcg	1.2	use Getopt::Long;
14	pcg	1.1	use Carp;
15
16	pcg	1.2	our $VERSION = '0.0'; # be more confident....
17	pcg	1.1
18			$SIG{QUIT} = sub { Carp::confess "SIGQUIT" };
19
20			my $kgs;
21	pcg	1.2	my $gtp;
22
23	pcg	1.1	my $verbose = 1;
24	pcg	1.2	my $user = "gtpguest";
25	pcg	1.1	my $pass = undef;
26
27	pcg	1.2	$Event::DIED = sub {
28			Event::verbose_exception_handler (@_);
29			Event::unloop_all;
30			};
31
32			sub format_user($) {
33			my $format =
34			sprintf "%s\|%s\|%s",
35			$_[0]{name},
36			$_[0]->flags_string,
37			$_[0]->rank_string;
38	pcg	1.1
39	pcg	1.2	$format =~ y/ //d;
40			$format;
41			}
42	pcg	1.1
43	pcg	1.2	sub coord($$) {
44			qw(A B C D E F G H J K L M N O P Q R S T U V W X Y Z)[$_[0]] . $_[1];
45	pcg	1.1	}
46
47	pcg	1.2	#############################################################################
48	pcg	1.1
49			package kgs;
50
51			use base KGS::Listener;
52
53			my $conn = new KGS::Protocol;
54
55			sub new {
56			my $class = shift;
57			my $self = bless { @_ }, $class;
58
59			print STDERR "$0 version $VERSION connecting...\n" if $verbose;
60
61			my $sock = new IO::Socket::INET PeerHost => $ENV{KGSHOST} \|\| "kgs.kiseido.com", PeerPort => "2379"
62			or die "connect: $!";
63
64			$sock->blocking (1);
65			$conn->handshake ($sock);
66
67			$self->listen ($conn, "any");
68
69			# Listener for kgs data
70			$self->{w} = Event->io (fd => $sock, poll => 'r', cb => sub {
71			my $len = sysread $sock, my $buf, 16384;
72			if ($len) {
73	pcg	1.2	$conn->feed_data ($buf);
74	pcg	1.1	} elsif (defined $len \|\| (!$!{EINTR} and !$!{EAGAIN})) {
75			print STDERR "disconnected\n" if $verbose;
76			Event::unloop;
77			}
78			});
79
80	pcg	1.2	$conn->login ("gtp-controller $VERSION", $self->{user}, delete $self->{password});
81	pcg	1.1
82			$self;
83			}
84
85			sub inject_login {
86			my ($self, $msg) = @_;
87
88	pcg	1.2	print STDERR "login: $msg->{message}\n" if $verbose >= 2;
89
90			$gtp->send ("kgs-login $msg->{message}");
91	pcg	1.1	}
92
93			sub inject_msg_room {
94			my ($self, $msg) = @_;
95	pcg	1.2
96			$gtp->send ("kgs-room-chat $msg->{channel} $msg->{message}");
97	pcg	1.1	}
98
99			sub inject_any {
100			my ($self, $msg) = @_;
101	pcg	1.2	if ($verbose >= 2) {
102			print STDERR "DEBUG: $msg->{type}#$msg->{channel}";
103			for (sort keys %$msg) {
104			print STDERR" $_<$msg->{$_}>";
105			}
106			print STDERR "\n";
107			}
108			}
109
110			sub inject_upd_rooms {
111			my ($self, $msg) = @_;
112
113			for (@{$msg->{rooms}}) {
114			$gtp->send ("kgs-room-update $_->{channel} $_->{name}");
115			}
116			}
117
118			sub inject_msg_chat {
119			my ($self, $msg) = @_;
120
121			return unless (lc $self->{conn}{name}) eq (lc $msg->{name2});
122
123			$gtp->send ("kgs-user-chat $msg->{name} $msg->{message}");
124			}
125
126			#############################################################################
127
128			package room;
129
130			use base KGS::Listener::Room;
131
132			sub new {
133			my $class = shift;
134			my $self = $class->SUPER::new (@_);
135
136			$self->listen ($self->{conn});
137			$self->join;
138
139			$self;
140			}
141
142			sub event_join {
143			my $self = shift;
144
145			$self->SUPER::join (@_);
146
147			$self->{timer} = Event->timer (after => 0, interval => 60, cb => sub {
148			$self->req_games;
149			});
150			}
151
152			sub event_update_games {
153			my ($self, $add, $upd, $del) = @_;
154
155			for (@$add, @$upd) {
156			$gtp->send (sprintf "kgs-game-update %d %d %s %s %s %s %d %d %f %d %d %d %d %s",
157			$self->{channel}, $_->{channel},
158			$_->type_char,
159			::format_user $_->{user1},
160			::format_user $_->{user2},
161			::format_user $_->{user3},
162			$_->size,
163			$_->{handicap},
164			$_->{komi},
165			$_->moves,
166			$_->{flags},
167			$_->{observers},
168			$_->{saved},
169			$_->{notes},
170			);
171			}
172
173			for (@$del) {
174			$gtp->send ("kgs-game-delete $self->{channel} $_->{channel}");
175			}
176			}
177
178			sub event_update_users {
179			my ($self, $add, $upd, $del) = @_;
180
181			for (@$add, @$upd) {
182			$gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
183			}
184
185			for (@$del) {
186			$gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
187			}
188			}
189
190			sub DESTROY {
191			my $self = shift;
192
193			$self->{timer}->cancel if $self->{timer};
194
195			$self->SUPER::DESTROY;
196			}
197
198			#############################################################################
199
200			package game;
201
202			use Gtk2::GoBoard::Constants;
203
204			use base KGS::Listener::Game;
205
206			sub new {
207			my $class = shift;
208			my $self = $class->SUPER::new (@_);
209
210			$self->listen ($self->{conn});
211			$self->join;
212
213			$self;
214			}
215
216			sub event_update_users {
217			return;
218
219			my ($self, $add, $upd, $del) = @_;
220
221			for (@$add, @$upd) {
222			$gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
223			}
224
225			for (@$del) {
226			$gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
227			}
228			}
229
230			sub inject_resign_game {
231			my ($self, $msg) = @_;
232
233			$gtp->set_gid ($self->{channel});
234			$gtp->send ("play " . (qw(b w))[$msg->{player}] . " resign");
235			}
236
237			sub inject_final_result {
238			my ($self, $msg) = @_;
239
240			$gtp->send (sprintf "kgs-game-score %f %f %f %f %f %f",
241			$_->{whitescore}{territory}, $_->{whitescore}{captures}, $_->{whitescore}{komi},
242			$_->{blackscore}{territory}, $_->{blackscore}{captures}, $_->{blackscore}{komi});
243			}
244
245			sub inject_set_teacher {
246			my ($self, $msg) = @_;
247			}
248
249			sub event_update_game {
250			my ($self) = @_;
251
252			$gtp->set_gid ($self->{channel});
253
254			# timesettings etc.
255			}
256
257			sub event_update_tree {
258			my ($self) = @_;
259
260			$gtp->set_gid ($self->{channel});
261
262			my $path = $self->get_path;
263			my $prev = $self->{prevpath};
264
265			$self->{prevpath} = [ @$path ];
266
267			if (@$prev > 1
268			and @$path > @$prev
269			and (join ":", @$prev) eq (join ":", @$path[0 .. $#$prev])) {
270
271			splice @$path, @prev, $#path, ();
272
273			} else {
274			$gtp->send ("boardsize $path->[0]{rules}{size}");
275			$gtp->send ("komi $path->[0]{rules}{komi}");
276			$gtp->send ("clear_board");
277
278			my $setup = shift @$path;
279			my $handi;
280
281			while (my ($k, $v) = each %$setup) {
282			if ($k =~ /^(\d+),(\d+)$/) {
283			$handi .= " " . ::coord $1, $2;
284			}
285			}
286
287			$gtp->send ("set_free_handicap$handi");
288			}
289
290			for (@$path) {
291			while (my ($k, $v) = each %$_) {
292			if ($k =~ /^(\d+),(\d+)$/) {
293			if ($v->[0] & MARK_MOVE) {
294			if ($v->[0] & MARK_B) {
295			$gtp->send ("play b ". ::coord $1, $2);
296			} else {
297			$gtp->send ("play w ". ::coord $1, $2);
298			}
299			}
300			}
301			}
302			}
303	pcg	1.1	}
304
305	pcg	1.2	sub DESTROY {
306			my $self = shift;
307
308			$self->SUPER::DESTROY;
309			}
310
311			#############################################################################
312
313	pcg	1.1	package gtp;
314
315	pcg	1.2	use Fcntl;
316
317	pcg	1.1	sub new {
318			my $class = shift;
319			bless { @_ }, $class;
320			}
321
322			sub set_fh {
323	pcg	1.2	my ($self, $rfh, $wfh) = @_;
324
325			$self->{r} = $rfh;
326			$self->{w} = $wfh;
327
328			fcntl $rfh, F_SETFL, O_NONBLOCK;
329	pcg	1.1
330	pcg	1.2	my $buf;
331	pcg	1.1
332	pcg	1.2	Event->io (fd => $rfh, poll => 'r', cb => sub {
333			my $r = sysread $rfh, $buf, 16384, length $buf;
334
335			if (defined $r and !$r) {
336			die "gtp engine sent EOF, I'm simply dying now, sorry\n";
337			} else {
338			$buf =~ y/\010\015/ /d;
339			$buf =~ s/#[^\012](?=\012)//g; # idiotic part of gtp spec
340			while () {
341			if ($buf =~ s/^([=?])(?:(\d+)\s+)?(.*?)\012\012//s) { # response
342			print STDERR "got response ($1\|$2\|$3)\n" if $verbose >= 2;
343
344			if (my $cb = delete $self->{waitq}{$2}) {
345			$cb->($1, $3);
346			} else {
347			warn "WARNING: got response if '$1 $2' without outstanding request\n";
348			}
349			} elsif ($buf =~ s/^(?:(\d+)\s+)?([^=?].*?)\012//s) { # command
350			$self->parse_command ($1, $2);
351			} elsif ($buf =~ s/^\s*\012//) {
352			# ignore, idiotic part of gtp spec
353			} else {
354			last;
355			}
356			}
357			}
358			});
359
360			# generate login commands
361			$self->send ("protocol_version", sub { $self->{pversion} = $_[1] });
362			$self->send ("name", sub { $self->{name} = $_[1] });#d#
363			$self->send ("version", sub { $self->{version} = $_[1] });
364	pcg	1.1	}
365
366			sub run_engine {
367	pcg	1.2	my ($self, @argv) = @_;
368
369			require IPC::Open2;
370
371			my ($r, $w);
372
373			IPC::Open2::open2 ($r, $w, @argv)
374			or die "unable to start @argv: $!";
375
376			$self->set_fh ($r, $w);
377			}
378
379			sub send {
380			my ($self, $cmd, $cb) = @_;
381
382			# first check for known_command
383
384			my $id = ++$self->{id};
385
386			$cmd =~ y/\015//d;
387			$cmd =~ s/\012/\\n/g;
388
389			$self->{waitq}{$id} = $cb \|\| sub { };
390			print { $self->{w} } "$id $cmd\012";
391			}
392
393			sub reply {
394			my ($self, $id, $response) = @_;
395
396			print { $self->{w} } "=$id $response\012";
397			}
398
399			sub reply_err {
400			my ($self, $id, $response) = @_;
401
402			print { $self->{w} } "?$id $response\012";
403			}
404
405			sub parse_command {
406			my ($self, $id, $cmd) = @_;
407
408			print STDERR "got command $cmd\n" if $verbose >= 2;
409
410			$cmd =~ s/\s+$//;
411
412			if ($cmd eq "kgs-room-list") {
413			# no args, just request all rooms
414			$kgs->send (list_rooms => group => $_) for 0..5;
415			$self->reply ($id, "");
416
417			} elsif ($cmd =~ /^kgs-room-join\s+(\d+)$/) {
418			$kgs->{room}{$1} = new room conn => $kgs->{conn}, channel => $1;
419			$self->reply ($id, "");
420			} elsif ($cmd =~ /^kgs-room-chat\s+(\d+)\s(.*)$/) {
421			$kgs->{room}{$1}->say ($2);
422			$self->reply ($id, "");
423			} elsif ($cmd =~ /^kgs-room-part\s+(\d+)$/) {
424			(delete $kgs->{room}{$1})->part ($2);
425			$self->reply ($id, "");
426
427			} elsif ($cmd =~ /^kgs-game-join\s+(\d+)$/) {
428			$kgs->{game}{$1} = new game conn => $kgs->{conn}, channel => $1;
429			$self->reply ($id, "");
430			} elsif ($cmd =~ /^kgs-game-chat\s+(\d+)\s(.*)$/) {
431			$kgs->{game}{$1}->say ($2);
432			$self->reply ($id, "");
433			} elsif ($cmd =~ /^kgs-game-part\s+(\d+)$/) {
434			(delete $kgs->{game}{$1})->part ($2);
435			$self->reply ($id, "");
436
437			} elsif ($cmd =~ /^kgs-user-chat\s+(\S+)\s+(.*)$/) {
438			$kgs->send (msg_chat =>
439			name => $kgs->{user},
440			name2 => $1,
441			message => $2);
442			$self->reply ($id, "");
443
444			} else {
445			$self->reply_err ($id, "illegal command");
446			}
447			}
448
449			sub set_gid {
450			my ($self, $gid) = @_;
451
452			if ($gid != $self->{gid}) {
453			$self->send ("kgs-game-id $gid");
454			$self->{gid} = $gid;
455			}
456	pcg	1.1	}
457
458			package main;
459
460	pcg	1.2	sub usage {
461			print STDERR <<EOF;
462			Usage: $0 [options] -- engine engine-args...
463			-u username usernmae to connect
464			-p password optional password to connect (none => guest)
465			-v increase verbosity
466			-q decrease verbosity
467
468			$0 connects to the kiseido go server, starts the named engine
469			and communicates with it using GTP protocol using it's stdin and stdout.
470
471			If no engine is given, uses stdin/stdout itself for communications.
472
473			The engine can optionally act as controller, too, as long as it isn't
474			confused by responses on it's command input stream.
475
476			Command extension used by the controller:
477
478			kgs-login message
479			kgs-room-update <rid> <name> # update room info
480			kgs-room-chat <rid> <user> <message> # somebody says sth.
481			kgs-game-update <rid> <gid> <type> <user1> <user2> \
482			<user3> <size> <handicap> <komi> <moves> \
483			<flags> <observers> <saved> <notes>
484			kgs-game-delete <rid> <gid> # game removed
485			kgs-user-update <rid> <user> # user added/updated
486			kgs-user-delete <rid> <user> # user removed
487
488			kgs-game-resign <gid> <color>
489			kgs-game-score <gid> <w-territory> <w-captures> <w-komi> <b-territory> <b-captures> <b-komi>
490			kgs-game-id <gid> # set id for following gid-less commands
491
492			kgs-user-chat <user> <message> # got private message from user
493			...
494
495			Commands usable by the client:
496
497			kgs-room-list # ask for roomlist update
498			kgs-room-join <rid> # join given room
499			kgs-room-chat <rid> <message> # say sth. in room
500			kgs-room-part <rid> # leave gives room
501
502			kgs-game-join <gid> # join the given game
503			kgs-game-part <gid> # leave the given game
504			kgs-game-chat <gid> <message> # say sth.
505
506			kgs-user-chat <user> <message> # send private msg to user
507			...
508
509			EOF
510			exit shift;
511			}
512
513			GetOptions (
514			"u=s" => \$user,
515			"v" => sub { $verbose++ },
516			"q" => sub { $verbose-- },
517			"h" => sub { usage(0) },
518			) or die usage(1);
519
520			$gtp = new gtp;
521
522			if (@ARGV) {
523			$gtp->run_engine (@ARGV);
524			} else {
525			$gtp->set_fh (\STDIN, \STDOUT);
526			}
527
528			$kgs = new kgs user => $user, password => $pass;
529	pcg	1.1
530			Event::loop;
531
532			1;
533
534