[ViewVC] Annotation of: cvs/kgsueme/bin/kgs-igs

#!/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 $conn = new KGS::Protocol;
my $kgs;
my $igs;

my $verbose = 1;
my $user;
my $pass;

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

sub rank($) {
   return "NR " if !$_[0]->is_ranked || !$_[0]->rank;
   return $_[0]->rank
          . ($_[0]->is_reliable ? "*" : " ");
}

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;

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 => KGS::Protocol::KGSHOST, PeerPort => KGS::Protocol::KGSPORT
      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 ("kgs-igs $VERSION", $self->{user}, delete $self->{password});

   $self;
}

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

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

   if ($msg->{success}) {
      $igs->login_ok ($msg->{message});
   } else {
      $igs->login_failed ($msg->{message});
   }
}

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

   #use PApp::Util; warn PApp::Util::dumpval $msg;#d#
   $igs->send ("21 !$msg->{name}!: $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}");
}

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

   $::lastnew = $msg->{channel};#d#
#   $gtp->send ("kgs-game-new $msg->{id} $msg->{channel}");
}

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

package room;

use base KGS::Listener::Room;

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

   $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 $_->{black},
#                  ::format_user $_->{white},
#                  ::format_user $_->{owner},
#                  $_->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 (conn => $conn, @_);

   $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 igs;

use Gtk2::GoBoard::Constants;
use KGS::Constants;

use Fcntl;

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

   my $buf;
   $self->{w} = Event->io (fd => $self->{fh}, poll => 'r', cb => sub {
      0 < sysread $self->{fh}, $buf, 4096, length $buf
         or Event::unloop -1;

      #$buf =~ y/\x00-\x09\x0b-\x0c\x0e-\x1f\x80-\xff//d;
      while ($buf =~ s/^([^\015\012]*)\015?\012//) {
         $self->{feed}->($1);
      }
   });

   syswrite $self->{fh}, "##########################################################\r\n" for 1..1;
   sleep 1; # required for amny clients :/
   syswrite $self->{fh}, "Login: ";

   $self->{feed} = sub {
      my $user = $_[0];
      print "login<$user>\n";
      #$self->send ("\377\373\1");
      $self->send ("1 1");
      $self->{feed} = sub {
         warn "pass <$_[0]>\n";#d#
         $kgs = new kgs user => $user, password => $_[0] eq "guest" ? "" : $_[0];

         $self->{feed} = sub { };
      }
   };

   $self;
}

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

   print "SEND<$cmd>\n";#d#
   syswrite $self->{fh}, "$cmd\015\012";
}

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

   (
      [values %{$self->{room}{users} || {}}],
      [values %{$self->{room}{games} || {}}],
   )
}

sub feed {
   my ($self, $line) = @_;

   warn "GOT<$line>\n";#d#

   if ($line =~ /^ga/) { # gamelist
      $self->send ("7 [##]  white name [ rk ]      black name [ rk ] (Move size H Komi BY FR) (###)");
      if ($self->{room}) {
         my (undef, $games) = $self->roominfo;
         for (@$games) {
            next if $_->{size} <= 0 || $_->{moves} <= 0 || $_->{handicap} < 0 || $_->is_scored;

            $self->send (sprintf
                  "7 [%2d] %11s [%4s] vs. %11s [%4s] (%3d %4d %2d %4.1f %2d %s%s) (%3d)",
                  $_->{channel},
                  $_->{white}{name}, ::rank $_->{white},
                  $_->{black}{name}, ::rank $_->{black},
                  $_->{moves},
                  $_->{size},
                  $_->{handicap},
                  $_->{komi},
                  10, "F", "I",
                  $_->{observers});
         }
      }
   } elsif ($line =~ /^chan/) { # channels
      $self->send ("9 #13 Title: English Game Room -- Open");

   } elsif ($line =~ /^(y\S*|;)\s*/g) { # yell
      my $channel = $self->{channel};
      $channel = $1 if $line =~ /\\(\d+)\s*/gc;

      if ($self->{channel} != $channel) {
         $self->{channel} = $channel;
         (delete $self->{room})->part if $self->{room};

         if ($channel > 0) {
            $self->{room} = new room channel => $channel;
            $self->send ("32 Changing into channel $channel.");
            $self->send ("32 Welcome to cyberspace.");#maybe title##d#

         }
      }

      if ($channel > 0) {
         # msg_chat to room
      }
      
   } elsif ($line =~ /^up/) { # uptime
      $self->send ("9 The current time (GMT) is:  Wed May 26 18:21:08 2004");#d#
      $self->send ("9 The current IGS local time is:  Thu May 27 03:21:08 2004");#d#
      $self->send ("9 Local hour when cron and the ratings, are run: 04:00");
      $self->send ("9 The server has been up 117 days 10 hours 13 minutes");#d#
      $self->send ("9 Max moves per game 1000");
      $self->send ("9 Max dead stones per game 750");
      $self->send ("9 Max account name length 11");
      $self->send ("9 Max number of games a player can observe 20");
      $self->send ("9 Number of aliases allowed 20");
      $self->send ("9 Number of moves between saves 10");
      $self->send ("9 Number of allowed connections 50");
      $self->send ("9 Max channel number 99");
      $self->send ("9 Locking:  Off.");
      $self->send ("9 Players:  513, Games:  118");#d#
      $self->send ("9 Max Board Size  19");
      $self->send ("9 How many days games are stored 180");
      $self->send ("9 How many days before an inactive player is removed 180");

   } elsif ($line =~ /^stats\s+(\S+)/) { # stats
      $self->send ("9 Player:      $1");
      $self->send ("9 Game:        go (1)");
      $self->send ("9 Language:    default");
      $self->send ("9 Rating:      13k    0");
      $self->send ("9 Rated Games:      0");
      $self->send ("9 Rank:  13k  16");
      $self->send ("9 Wins:         0");
      $self->send ("9 Losses:       0");
      $self->send ("9 Idle Time:  (On server) 0s");
      $self->send ("9 Address:  igs\@schmorp.de");
      $self->send ("9 Country:  Germany");
      $self->send ("9 Reg date: Mon May 24 08:58:12 2004");
      $self->send ("9 Info:  <None>");
      $self->send ("9 Defaults (help defs):  time 90, size 19, byo-yomi time 10, byo-yomi stones 25");
      $self->send ("9 Verbose  Bell  Quiet  Shout  Automail  Open  Looking  Client  Kibitz  Chatter");
      $self->send ("9     Off   Off     On     On       Off   Off      Off      On      On   On");

   } elsif ($line =~ /^t\S*\s+(\S+)(?:\s+(\S+))/) { # toggle
      my ($setting, $value) = $1;
      if ($2 =~ /^t/i) {
         $self->{toggle}{$setting} = 1;
      } elsif ($2 =~ /^f/i) {
         $self->{toggle}{$setting} = 0;
      } else {
         $self->{toggle}{$setting} = !$self->{toggle}{$setting};
      }

   } elsif ($line =~ /^id\s+(.*)/) { # id
      $self->{id} = $1;

   } elsif ($line =~ /^wh\S*(?:\s+(.*))?/) { # who

      $self->send ("27  Info       Name       Idle   Rank |  Info       Name       Idle   Rank");
      my ($users, $games) = $self->roominfo;
      for (@$users) {
         # 27  SX --   -- guest8814   4s     NR  |     --   -- guest7528   1m     NR 
      }
      $self->send (sprintf "27                 ******** %d Players %d Total Games ********",
                   scalar @$users, scalar @$games);

   } elsif ($line =~ /^us\S*(?:\s+(.*))?/) { # users

      $self->send ("42 Name        Info            Country  Rank Won/Lost Obs  Pl Idle Flags Language");
      my ($users, $games) = $self->roominfo;
      for (@$users) {
         $self->send (sprintf "42  %-11.11s                --      %5s   0/   0  -   -   %3s    SX default",
                      $_->{name},
                      ::rank ($_),
                      "0s",
                      );
      }
      $self->send (sprintf "9                 ******** %d Players %d Total Games ********",
                   scalar @$users, scalar @$games);

   # 21 {Game 28: Robot10 vs catty : W 25.5 B 77.0}
   # 21 {smorim [1k*] has connected.}
   # 21 {daruma21 [5k*] has connected.}
   # 21 {Game 102: boni vs z2004 : Black forfeits on time.}
   # 21 {Game 14: gb vs Mahoba : White resigns.}
   # 21 {brianlee has disconnected}


   } else {
      $self->send ("5 Unknown command.");
   }

   $self->send ("1 5");

}

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

   $self->{feed} = sub { $self->feed ($_[0]) };
   #$self->send ("39 IGS entry on 05 - 26 - 2004");
   #$self->send ("9 File"); # motd

   $self->send ("9 File");
   $self->send (" $msg");
   $self->send ("9 File");
   $self->send ("39 IGS entry on 05 - 27 - 2004");#d#
   $self->send ("1 5");

   $self->{room} = new room channel => 13; # auto-join english room #d#
}

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

   $self->send ("5 $msg");
   Event::unloop -1;
}

package main;

sub usage {
   print STDERR <<EOF;
Usage: $0 [options] port
           -v             increase verbosity
           -q             decrease verbosity

EOF
   exit shift;
}

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

my $port = $ARGV[0] || 6969;

my $socket = new IO::Socket::INET LocalPort => $port, Listen => 1, ReuseAddr => 1,
   or die "cannot create listening socket on port $port: $!";

print "Listening on 127.0.0.1:$port, please connect to it using your igs client.\n";

while (my $fh = $socket->accept) {
   if (fork == 0) {
      $igs = new igs fh => $fh;

      Event::loop;
      exit 0;
   }
}

1;


Revision:	1.4
Committed:	Sun May 30 02:22:01 2004 UTC (20 years ago) by pcg
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.3:	+5 -5 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			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 $conn = new KGS::Protocol;
21			my $kgs;
22			my $igs;
23
24			my $verbose = 1;
25			my $user;
26			my $pass;
27
28			$Event::DIED = sub {
29			Event::verbose_exception_handler (@_);
30			Event::unloop_all;
31			};
32
33			sub rank($) {
34	pcg	1.3	return "NR " if !$_[0]->is_ranked \|\| !$_[0]->rank;
35	pcg	1.1	return $_[0]->rank
36	pcg	1.2	. ($_[0]->is_reliable ? "*" : " ");
37	pcg	1.1	}
38
39			sub format_user($) {
40			my $format =
41			sprintf "%s\|%s\|%s",
42			$_[0]{name},
43			$_[0]->flags_string,
44			$_[0]->rank_string;
45
46			$format =~ y/ //d;
47			$format;
48			}
49
50			sub coord($$) {
51			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];
52			}
53
54			#############################################################################
55
56			package kgs;
57
58			use base KGS::Listener;
59
60			sub new {
61			my $class = shift;
62			my $self = bless { @_ }, $class;
63
64			print STDERR "$0 version $VERSION connecting...\n" if $verbose;
65
66			my $sock = new IO::Socket::INET PeerHost => KGS::Protocol::KGSHOST, PeerPort => KGS::Protocol::KGSPORT
67			or die "connect: $!";
68
69			$sock->blocking (1);
70			$conn->handshake ($sock);
71
72			$self->listen ($conn, "any");
73
74			# Listener for kgs data
75			$self->{w} = Event->io (fd => $sock, poll => 'r', cb => sub {
76			my $len = sysread $sock, my $buf, 16384;
77			if ($len) {
78			$conn->feed_data ($buf);
79			} elsif (defined $len \|\| (!$!{EINTR} and !$!{EAGAIN})) {
80			print STDERR "disconnected\n" if $verbose;
81			Event::unloop;
82			}
83			});
84
85			$conn->login ("kgs-igs $VERSION", $self->{user}, delete $self->{password});
86
87			$self;
88			}
89
90			sub inject_login {
91			my ($self, $msg) = @_;
92
93			print STDERR "login: $msg->{message}\n" if $verbose >= 2;
94
95			if ($msg->{success}) {
96			$igs->login_ok ($msg->{message});
97			} else {
98			$igs->login_failed ($msg->{message});
99			}
100			}
101
102			sub inject_msg_room {
103			my ($self, $msg) = @_;
104
105			#use PApp::Util; warn PApp::Util::dumpval $msg;#d#
106			$igs->send ("21 !$msg->{name}!: $msg->{message}");
107			}
108
109			sub inject_any {
110			my ($self, $msg) = @_;
111			if ($verbose >= 2) {
112			print STDERR "DEBUG: $msg->{type}#$msg->{channel}";
113			for (sort keys %$msg) {
114			print STDERR" $_<$msg->{$_}>";
115			}
116			print STDERR "\n";
117			}
118			}
119
120			sub inject_upd_rooms {
121			my ($self, $msg) = @_;
122
123			for (@{$msg->{rooms}}) {
124			# $gtp->send ("kgs-room-update $_->{channel} $_->{name}");
125			}
126			}
127
128			sub inject_msg_chat {
129			my ($self, $msg) = @_;
130
131			return unless (lc $self->{conn}{name}) eq (lc $msg->{name2});
132
133			# $gtp->send ("kgs-user-chat $msg->{name} $msg->{message}");
134			}
135
136			sub inject_new_game {
137			my ($self, $msg) = @_;
138
139			$::lastnew = $msg->{channel};#d#
140			# $gtp->send ("kgs-game-new $msg->{id} $msg->{channel}");
141			}
142
143			#############################################################################
144
145			package room;
146
147			use base KGS::Listener::Room;
148
149			sub new {
150			my $class = shift;
151			my $self = $class->SUPER::new (conn => $conn, @_);
152
153			$self->listen ($self->{conn});
154			$self->join;
155
156			$self;
157			}
158
159			sub event_join {
160			my $self = shift;
161
162			$self->SUPER::join (@_);
163
164			$self->{timer} = Event->timer (after => 0, interval => 60, cb => sub {
165			$self->req_games;
166			});
167			}
168
169			sub event_update_games {
170			my ($self, $add, $upd, $del) = @_;
171
172			# for (@$add, @$upd) {
173			# $gtp->send (sprintf "kgs-game-update %d %d %s %s %s %s %d %d %f %d %d %d %d %s",
174			# $self->{channel}, $_->{channel},
175			# $_->type_char,
176	pcg	1.4	# ::format_user $_->{black},
177			# ::format_user $_->{white},
178			# ::format_user $_->{owner},
179	pcg	1.1	# $_->size,
180			# $_->{handicap},
181			# $_->{komi},
182			# $_->moves,
183			# $_->{flags},
184			# $_->{observers},
185			# $_->{saved},
186			# $_->{notes},
187			# );
188			# }
189			#
190			# for (@$del) {
191			# $gtp->send ("kgs-game-delete $self->{channel} $_->{channel}");
192			# }
193			}
194
195			sub event_update_users {
196			my ($self, $add, $upd, $del) = @_;
197
198			# for (@$add, @$upd) {
199			# $gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
200			# }
201			#
202			# for (@$del) {
203			# $gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
204			# }
205			}
206
207			sub DESTROY {
208			my $self = shift;
209
210			$self->{timer}->cancel if $self->{timer};
211
212			$self->SUPER::DESTROY;
213			}
214
215			#############################################################################
216
217			package game;
218
219			use Gtk2::GoBoard::Constants;
220
221			use base KGS::Listener::Game;
222
223			sub new {
224			my $class = shift;
225			my $self = $class->SUPER::new (conn => $conn, @_);
226
227			$self->listen ($self->{conn});
228			$self->join;
229
230			$self;
231			}
232
233			sub event_update_users {
234			return;
235
236			my ($self, $add, $upd, $del) = @_;
237
238			for (@$add, @$upd) {
239			$gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
240			}
241
242			for (@$del) {
243			$gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
244			}
245			}
246
247			sub inject_resign_game {
248			my ($self, $msg) = @_;
249
250			$gtp->set_gid ($self->{channel});
251			$gtp->send ("play " . (qw(b w))[$msg->{player}] . " resign");
252			}
253
254			sub inject_final_result {
255			my ($self, $msg) = @_;
256
257			$gtp->send (sprintf "kgs-game-score %f %f %f %f %f %f",
258			$_->{whitescore}{territory}, $_->{whitescore}{captures}, $_->{whitescore}{komi},
259			$_->{blackscore}{territory}, $_->{blackscore}{captures}, $_->{blackscore}{komi});
260			}
261
262			sub inject_set_teacher {
263			my ($self, $msg) = @_;
264			}
265
266			sub event_update_game {
267			my ($self) = @_;
268
269			$gtp->set_gid ($self->{channel});
270
271			# timesettings etc.
272			}
273
274			sub event_update_tree {
275			my ($self) = @_;
276
277			$gtp->set_gid ($self->{channel});
278
279			my $path = $self->get_path;
280			my $prev = $self->{prevpath};
281
282			$self->{prevpath} = [ @$path ];
283
284			if (@$prev > 1
285			and @$path > @$prev
286			and (join ":", @$prev) eq (join ":", @$path[0 .. $#$prev])) {
287
288			splice @$path, @prev, $#path, ();
289
290			} else {
291			$gtp->send ("boardsize $path->[0]{rules}{size}");
292			$gtp->send ("komi $path->[0]{rules}{komi}");
293			$gtp->send ("clear_board");
294
295			my $setup = shift @$path;
296			my $handi;
297
298			while (my ($k, $v) = each %$setup) {
299			if ($k =~ /^(\d+),(\d+)$/) {
300			$handi .= " " . ::coord $1, $2;
301			}
302			}
303
304			$gtp->send ("set_free_handicap$handi");
305			}
306
307			for (@$path) {
308			while (my ($k, $v) = each %$_) {
309			if ($k =~ /^(\d+),(\d+)$/) {
310			if ($v->[0] & MARK_MOVE) {
311			if ($v->[0] & MARK_B) {
312			$gtp->send ("play b ". ::coord $1, $2);
313			} else {
314			$gtp->send ("play w ". ::coord $1, $2);
315			}
316			}
317			}
318			}
319			}
320			}
321
322			sub DESTROY {
323			my $self = shift;
324
325			$self->SUPER::DESTROY;
326			}
327
328			#############################################################################
329
330			package igs;
331
332			use Gtk2::GoBoard::Constants;
333			use KGS::Constants;
334
335			use Fcntl;
336
337			sub new {
338			my $class = shift;
339			my $self = bless { @_ }, $class;
340
341			my $buf;
342			$self->{w} = Event->io (fd => $self->{fh}, poll => 'r', cb => sub {
343			0 < sysread $self->{fh}, $buf, 4096, length $buf
344			or Event::unloop -1;
345
346			#$buf =~ y/\x00-\x09\x0b-\x0c\x0e-\x1f\x80-\xff//d;
347			while ($buf =~ s/^([^\015\012]*)\015?\012//) {
348			$self->{feed}->($1);
349			}
350			});
351
352			syswrite $self->{fh}, "##########################################################\r\n" for 1..1;
353			sleep 1; # required for amny clients :/
354			syswrite $self->{fh}, "Login: ";
355
356			$self->{feed} = sub {
357			my $user = $_[0];
358			print "login<$user>\n";
359			#$self->send ("\377\373\1");
360			$self->send ("1 1");
361			$self->{feed} = sub {
362			warn "pass <$_[0]>\n";#d#
363			$kgs = new kgs user => $user, password => $_[0] eq "guest" ? "" : $_[0];
364
365			$self->{feed} = sub { };
366			}
367			};
368
369			$self;
370			}
371
372			sub send {
373			my ($self, $cmd) = @_;
374
375			print "SEND<$cmd>\n";#d#
376			syswrite $self->{fh}, "$cmd\015\012";
377			}
378
379	pcg	1.3	sub roominfo {
380			my ($self) = @_;
381
382			(
383			[values %{$self->{room}{users} \|\| {}}],
384			[values %{$self->{room}{games} \|\| {}}],
385			)
386			}
387
388	pcg	1.1	sub feed {
389			my ($self, $line) = @_;
390
391			warn "GOT<$line>\n";#d#
392
393			if ($line =~ /^ga/) { # gamelist
394			$self->send ("7 [##] white name [ rk ] black name [ rk ] (Move size H Komi BY FR) (###)");
395			if ($self->{room}) {
396	pcg	1.3	my (undef, $games) = $self->roominfo;
397			for (@$games) {
398	pcg	1.1	next if $_->{size} <= 0 \|\| $_->{moves} <= 0 \|\| $_->{handicap} < 0 \|\| $_->is_scored;
399
400			$self->send (sprintf
401	pcg	1.2	"7 [%2d] %11s [%4s] vs. %11s [%4s] (%3d %4d %2d %4.1f %2d %s%s) (%3d)",
402	pcg	1.1	$_->{channel},
403	pcg	1.4	$_->{white}{name}, ::rank $_->{white},
404			$_->{black}{name}, ::rank $_->{black},
405	pcg	1.1	$_->{moves},
406			$_->{size},
407			$_->{handicap},
408			$_->{komi},
409	pcg	1.2	10, "F", "I",
410	pcg	1.1	$_->{observers});
411			}
412			}
413			} elsif ($line =~ /^chan/) { # channels
414			$self->send ("9 #13 Title: English Game Room -- Open");
415
416			} elsif ($line =~ /^(y\S\|;)\s/g) { # yell
417			my $channel = $self->{channel};
418			$channel = $1 if $line =~ /\\(\d+)\s*/gc;
419
420			if ($self->{channel} != $channel) {
421			$self->{channel} = $channel;
422			(delete $self->{room})->part if $self->{room};
423
424			if ($channel > 0) {
425			$self->{room} = new room channel => $channel;
426			$self->send ("32 Changing into channel $channel.");
427			$self->send ("32 Welcome to cyberspace.");#maybe title##d#
428
429			}
430			}
431
432			if ($channel > 0) {
433			# msg_chat to room
434			}
435	pcg	1.2
436			} elsif ($line =~ /^up/) { # uptime
437			$self->send ("9 The current time (GMT) is: Wed May 26 18:21:08 2004");#d#
438			$self->send ("9 The current IGS local time is: Thu May 27 03:21:08 2004");#d#
439			$self->send ("9 Local hour when cron and the ratings, are run: 04:00");
440			$self->send ("9 The server has been up 117 days 10 hours 13 minutes");#d#
441			$self->send ("9 Max moves per game 1000");
442			$self->send ("9 Max dead stones per game 750");
443			$self->send ("9 Max account name length 11");
444			$self->send ("9 Max number of games a player can observe 20");
445			$self->send ("9 Number of aliases allowed 20");
446			$self->send ("9 Number of moves between saves 10");
447			$self->send ("9 Number of allowed connections 50");
448			$self->send ("9 Max channel number 99");
449			$self->send ("9 Locking: Off.");
450			$self->send ("9 Players: 513, Games: 118");#d#
451			$self->send ("9 Max Board Size 19");
452			$self->send ("9 How many days games are stored 180");
453			$self->send ("9 How many days before an inactive player is removed 180");
454
455			} elsif ($line =~ /^stats\s+(\S+)/) { # stats
456			$self->send ("9 Player: $1");
457			$self->send ("9 Game: go (1)");
458			$self->send ("9 Language: default");
459			$self->send ("9 Rating: 13k 0");
460			$self->send ("9 Rated Games: 0");
461			$self->send ("9 Rank: 13k 16");
462			$self->send ("9 Wins: 0");
463			$self->send ("9 Losses: 0");
464			$self->send ("9 Idle Time: (On server) 0s");
465			$self->send ("9 Address: igs\@schmorp.de");
466			$self->send ("9 Country: Germany");
467			$self->send ("9 Reg date: Mon May 24 08:58:12 2004");
468			$self->send ("9 Info: <None>");
469			$self->send ("9 Defaults (help defs): time 90, size 19, byo-yomi time 10, byo-yomi stones 25");
470			$self->send ("9 Verbose Bell Quiet Shout Automail Open Looking Client Kibitz Chatter");
471			$self->send ("9 Off Off On On Off Off Off On On On");
472
473	pcg	1.3	} elsif ($line =~ /^t\S*\s+(\S+)(?:\s+(\S+))/) { # toggle
474			my ($setting, $value) = $1;
475			if ($2 =~ /^t/i) {
476			$self->{toggle}{$setting} = 1;
477			} elsif ($2 =~ /^f/i) {
478			$self->{toggle}{$setting} = 0;
479			} else {
480			$self->{toggle}{$setting} = !$self->{toggle}{$setting};
481			}
482
483			} elsif ($line =~ /^id\s+(.*)/) { # id
484			$self->{id} = $1;
485
486			} elsif ($line =~ /^wh\S(?:\s+(.))?/) { # who
487
488			$self->send ("27 Info Name Idle Rank \| Info Name Idle Rank");
489			my ($users, $games) = $self->roominfo;
490			for (@$users) {
491			# 27 SX -- -- guest8814 4s NR \| -- -- guest7528 1m NR
492			}
493			$self->send (sprintf "27 ****** %d Players %d Total Games ******",
494			scalar @$users, scalar @$games);
495
496			} elsif ($line =~ /^us\S(?:\s+(.))?/) { # users
497
498			$self->send ("42 Name Info Country Rank Won/Lost Obs Pl Idle Flags Language");
499			my ($users, $games) = $self->roominfo;
500			for (@$users) {
501			$self->send (sprintf "42 %-11.11s -- %5s 0/ 0 - - %3s SX default",
502			$_->{name},
503			::rank ($_),
504			"0s",
505			);
506			}
507			$self->send (sprintf "9 ****** %d Players %d Total Games ******",
508			scalar @$users, scalar @$games);
509
510	pcg	1.2	# 21 {Game 28: Robot10 vs catty : W 25.5 B 77.0}
511			# 21 {smorim [1k*] has connected.}
512			# 21 {daruma21 [5k*] has connected.}
513			# 21 {Game 102: boni vs z2004 : Black forfeits on time.}
514			# 21 {Game 14: gb vs Mahoba : White resigns.}
515			# 21 {brianlee has disconnected}
516
517
518
519	pcg	1.1	} else {
520			$self->send ("5 Unknown command.");
521			}
522
523			$self->send ("1 5");
524
525			}
526
527			sub login_ok {
528			my ($self, $msg) = @_;
529
530			$self->{feed} = sub { $self->feed ($_[0]) };
531			#$self->send ("39 IGS entry on 05 - 26 - 2004");
532			#$self->send ("9 File"); # motd
533
534			$self->send ("9 File");
535			$self->send (" $msg");
536			$self->send ("9 File");
537	pcg	1.3	$self->send ("39 IGS entry on 05 - 27 - 2004");#d#
538	pcg	1.1	$self->send ("1 5");
539
540			$self->{room} = new room channel => 13; # auto-join english room #d#
541			}
542
543			sub login_failed {
544			my ($self, $msg) = @_;
545
546			$self->send ("5 $msg");
547			Event::unloop -1;
548			}
549
550			package main;
551
552			sub usage {
553			print STDERR <<EOF;
554			Usage: $0 [options] port
555			-v increase verbosity
556			-q decrease verbosity
557
558			EOF
559			exit shift;
560			}
561
562			GetOptions (
563			"v" => sub { $verbose++ },
564			"q" => sub { $verbose-- },
565			"h" => sub { usage(0) },
566			) or die usage(1);
567
568			my $port = $ARGV[0] \|\| 6969;
569
570			my $socket = new IO::Socket::INET LocalPort => $port, Listen => 1, ReuseAddr => 1,
571			or die "cannot create listening socket on port $port: $!";
572
573			print "Listening on 127.0.0.1:$port, please connect to it using your igs client.\n";
574
575			while (my $fh = $socket->accept) {
576			if (fork == 0) {
577			$igs = new igs fh => $fh;
578
579			Event::loop;
580			exit 0;
581			}
582			}
583
584			1;
585
586