[ViewVC] Contents 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 *
#	Content
1	#!/opt/bin/perl
2
3	# lots of things have been hardcoded. search for #d# to find the places
4
5	require 5.008;
6
7	use KGS::Protocol;
8	use KGS::Listener::Debug;
9
10	use IO::Socket::INET;
11	use Event;
12
13	use Getopt::Long;
14	use Carp;
15
16	our $VERSION = '0.0'; # be more confident....
17
18	$SIG{QUIT} = sub { Carp::confess "SIGQUIT" };
19
20	my $kgs;
21	my $gtp;
22
23	my $verbose = 1;
24	my $user = "gtpguest";
25	my $pass = undef;
26
27	$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
39	$format =~ y/ //d;
40	$format;
41	}
42
43	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	}
46
47	#############################################################################
48
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	$conn->feed_data ($buf);
74	} elsif (defined $len \|\| (!$!{EINTR} and !$!{EAGAIN})) {
75	print STDERR "disconnected\n" if $verbose;
76	Event::unloop;
77	}
78	});
79
80	$conn->login ("gtp-controller $VERSION", $self->{user}, delete $self->{password});
81
82	$self;
83	}
84
85	sub inject_login {
86	my ($self, $msg) = @_;
87
88	print STDERR "login: $msg->{message}\n" if $verbose >= 2;
89
90	$gtp->send ("kgs-login $msg->{message}");
91	}
92
93	sub inject_msg_room {
94	my ($self, $msg) = @_;
95
96	$gtp->send ("kgs-room-chat $msg->{channel} $msg->{message}");
97	}
98
99	sub inject_any {
100	my ($self, $msg) = @_;
101	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	}
304
305	sub DESTROY {
306	my $self = shift;
307
308	$self->SUPER::DESTROY;
309	}
310
311	#############################################################################
312
313	package gtp;
314
315	use Fcntl;
316
317	sub new {
318	my $class = shift;
319	bless { @_ }, $class;
320	}
321
322	sub set_fh {
323	my ($self, $rfh, $wfh) = @_;
324
325	$self->{r} = $rfh;
326	$self->{w} = $wfh;
327
328	fcntl $rfh, F_SETFL, O_NONBLOCK;
329
330	my $buf;
331
332	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	}
365
366	sub run_engine {
367	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	}
457
458	package main;
459
460	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
530	Event::loop;
531
532	1;
533
534