lib/KGS/Protocol.pm

use utf8;

package KGS::Protocol;

use Carp;
use Compress::Zlib;
use Time::HiRes;
use Scalar::Util;

use KGS::Messages;

my $KGSHOST = "goserver.gokgs.com";
my $KGSPORT = 2379;
my $SGFHOST = "216.93.172.124";

our $NOW; # the time the last packet was received

our $VERSION = '0.99';

sub MSG_CHANNEL() { 0x4000 }

sub KGSHOST() { $ENV{KGSHOST} || $KGSHOST }
sub KGSPORT() { $ENV{KGSPORT} || $KGSPORT }
sub SGFHOST() { $ENV{SGFHOST} || $SGFHOST }

=item new arg => value,...

=cut

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

sub encode_msg {
   my ($type, %arg) = @_;

   my $msg = $KGS::Messages::enc_client{$type}
      or die "FATAL: tried to send unknown message type '$type'";

   $msg = $msg->(\%arg);
   #print "MSG $type => ", (join " ", %arg), "\n";#d#
   #print "HEX ", (unpack "H*", $msg), "\n";#d#
   #print "ok (y/n)?"; die unless <> =~ /^y/;#d#dd# let's be paranoid.. "don't crash the server, uh-oh"
   
   pack "va*", 2 + length $msg, $msg;
}

# encode/decode functions
sub decode_msg($) {
   my ($type, $data) = unpack "v a*", $_[0];

   my $msg = $KGS::Messages::dec_server{$type};

   if ($msg) {
      $msg->($data);
   } else {
      {
         type => (sprintf "unknown_%04x", $type),
         DATA => $data,
      };
   }
}

my $CLIENTVERSION = 4; # 4 == 3 + server zlib compressed
my $SERVERVERSION = 3; # since quite some time now

=item send

Format a message and send it to the server.

=cut

sub send($@) {
   my $self = shift;

   #use PApp::Util; print PApp::Util::dumpval [@_];#d#

   my $msg = $self->{generator}->enc_client (encode_msg @_);

   if ($self->{sock}) {
      syswrite $self->{sock}, $msg
         or croak "msg: $!";
   } else {
      warn "KGS::Protocol::send() called without a socket connection\n";
   }
}

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

   $self->{generator} = new KGS::Protocol::Generator;
   $self->{zstream} = inflateInit;
}

=item handshake $fh

Do the initial handshaking with the server on the given socket and make it
the current one. This will initialize the communications stack and set the
socket to be used to sending messages.

=cut

sub handshake {
   my ($self, $fh) = @_;

   $self->init;
   $self->{sock} = $fh;
   
#   syswrite $fh, chr $CLIENTVERSION
#      or croak "initial server handshake send: $!";
# 
#   sysread $fh, my $buf, 1
#      or croak "initial server handshake recv: $!\n";
# 
#   $buf eq chr $SERVERVERSION
#      or croak "initial server handshake: server version ".(ord $buf)." unsupported";
}

=item login $clientversion, $name, $pass[, $locale]

Login to the server. C<$clientversion> should be a descriptive string that
uniquely identifies the client and the client version.

=cut

sub login {
   my ($self, $clientver, $name, $pass, $locale) = @_;

   $self->{generator}->set_server_seed ($name);

   $self->{name} = $name;
   $self->send (login =>
      name      => $name,
      password  => $pass,
      locale    => $locale,
      guest     => $pass eq "",
      clientver => $clientver,
   );
}

=item disconnect

Close the socket, generate a quit message and unregisters listeners.

=cut

sub disconnect {
   my $self = shift;

   close delete $self->{sock}
      if $self->{sock};

   $self->inject ({ type => "quit" });

   delete $self->{cb};
}

=item feed_data $data

Feed new data from the server into this object. This might or might not
result in messages being dispatched.

=cut

sub feed_data {
   my $self = $_[0];

   $NOW = Time::HiRes::time;

   my ($data, $status) = $self->{zstream}->inflate ($_[1]);
   $status == Z_OK or croak "inflate: status is $status";

   $self->{rbuf} .= $data;

   while (($self->{rlen} || 2) <= length $self->{rbuf}) {
      my $data = substr $self->{rbuf}, 0, $self->{rlen} || 2, "";
      if (delete $self->{rlen}) {
         #open XTYPE, "|xtype"; printf XTYPE "%16x", length($data); print XTYPE $data; close XTYPE;#d#

         $self->inject (decode_msg $self->{generator}->dec_server ($data));
      } else {
         $self->{rlen} = (unpack "v", $data) - 2;
      }
   }
}

sub register {
   my ($self, $obj, @types) = @_;

   for (@types) {
      $self->{cb}{$_}{$obj} = $obj;
      Scalar::Util::weaken $self->{cb}{$_}{$obj};
   }
}

sub unregister {
   my ($self, $obj, @types) = @_;

   delete $self->{cb}{$_}{$obj} for @types;
}

sub inject {
   my ($self, $msg) = @_;
   
   $msg->{NOW} = $NOW; # timestamps heissen bei mir "NOW"
   #use PApp::Util; warn PApp::Util::dumpval $msg;#d#

   for my $type ("any", $msg->{type}, "$msg->{type}:$msg->{channel}") {
      for my $obj (values %{$self->{cb}{$type} || {}}) {
         $obj->inject($msg) if $obj;
      }
   }
}

=item alloc_clientid

Create and return a new channel id, used e.g. for game creation. We start
at one, but cgoban2 seems to start at zero.

=cut

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

   ++$self->{clientid};
}

package KGS::User;

sub is_admin     { $_[0]{flags} & 0x00004 }
sub is_active    { $_[0]{flags} & 0x00008 } # logged in(?)
sub is_gone      { $_[0]{flags} & 0x00010 }
sub is_idle      { $_[0]{flags} & 0x00020 }
sub has_url      { $_[0]{flags} & 0x00040 } # wild guess
sub is_playing   { $_[0]{flags} & 0x00080 }
sub is_reliable  { $_[0]{flags} & 0x00100 } # reliable ranking?
sub is_ranked    { $_[0]{flags} & 0x00200 }
#                                0x00400 # no idea
sub is_ranked2   { $_[0]{flags} & 0x00800 } # very reliably ranked? *g*
sub has_pic      { $_[0]{flags} & 0x01000 }
sub email_priv   { $_[0]{flags} & 0x02000 }

sub is_bot       { $_[0]{flags} & 0x10000 }
sub is_guest     { $_[0]{flags} & 0x20000 }

sub usertype     { $_[0]{flags} & 3 }
# 0 == normal
# 1 == ranked robot (gtp-client)
# 2 == teacher
# 3 == assistant

sub is_valid    { length $_[0]{name} }

sub rank_number {
   $_[0]{flags} >> 24;
}

sub rank {
   my $rank = $_[0]->rank_number;
   $rank <= 0
      ? ""
      : $rank <= 30
         ? (31-$rank) . "k"
         : $rank <= 39
              ? ($rank - 30) . "d"
              : ($rank - 39) . "p";
}

sub rank_string {
   $_[0]->is_ranked
      ? $_[0]->rank . ($_[0]->is_reliable ? "" : "?")
      : "-";
}

sub flags_string {
   my $r;

   $r .= "+" if &is_active;
   $r .= ":" if &is_ranked2;

   $r .= " (admin)" if &is_admin;

   $r .= " (child)" if &usertype == 1;
   $r .= " (teacher)" if &usertype == 2;
   $r .= " (ass)" if &usertype == 3;

   $r .= " (guest)" if &is_guest;
   $r .= " (bot)" if &is_bot;

   $r .= " (gone)" if &is_gone;
   $r .= " (idle)" if &is_idle;
   $r .= " (playing)" if &is_playing;

   $r .= " (has pic)" if &has_pic;
   $r .= " (has url)" if &has_url;

   $r .= sprintf "%04x", $_[0]{flags} & 0xfcc000
       if $_[0]{flags} & 0xfcc000;

   $r;
}

sub as_string {
   sprintf "%s\xa0[%s]", $_[0]{name}, $_[0]->rank_string;
}

package KGS::Game;

use KGS::Constants;

sub is_saved      { $_[0]{saved} } # hmm... not a flag...
sub is_scored     { $_[0]{flags} & 0x1 }
sub is_adjourned  { $_[0]{flags} & 0x2 }
# there is more going on, one bit 0x4 and above(?)

sub is_inprogress { $_[0]{handicap} >= 0 } # maybe rename to "complete"? "started"? "has_board"? ;)

sub is_private    { $_[0]{type} & GAMETYPE_PRIVATE }

sub is_active {
   &is_inprogress and !&is_scored;
}

sub player_colour {
   $_[0]{black}{name} eq $_[1] ? COLOUR_BLACK
   : $_[0]{white}{name} eq $_[1] ? COLOUR_WHITE
   : COLOUR_NONE;
}

sub score {
   # due to the peculiar way score values are encoded, we keep special
   # values in the /4 format, while normal scores are represented "as is".
   # this makes it compatible to the /4 format used in trees.
   &is_scored
      ? 8000 > abs $_[0]{moves} ? $_[0]{moves} * (1 / 2) : $_[0]{moves} / 4
      : SCORE_UNKNOWN;
}

sub moves {
   &is_scored
      ? -1
      : $_[0]{moves};
}

sub type {
   $_[0]{type} & 15;
}

sub type_char {
   (uc substr ($gametype{&type}, 0, 1))
   . (&is_private ? "P" : "");
}

sub owner {
   length $_[0]{owner}{name}
      ? $_[0]{owner}
      : $_[0]{white};
}

sub opponent_string {
   $_[0]{owner}{name} ?
      $_[0]{black}{name} eq $_[0]{white}{name}
         ? "" : "(".$_[0]{white}->as_string." - ".$_[0]{black}->as_string.")"
      : "vs. ".$_[0]{black}->as_string;
}

sub size {
   $_[0]{size};
}

sub size_string {
   "$_[0]{size}×$_[0]{size}";
}

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

   my $res;

   if ($self->is_scored) {
      $score = $self->score;
      if ($score < 0) {
         $res = "W+";
         $score *= -1;
      } else  {
         $res = "B+";
      }
      $res .= $special_score{$score * 4} || $score;
   } else {
      $res = "(unfinished)";
   }

   $res;
}

# convinience

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

   my $rules = $self->size_string;

   $rules .= " H$_[0]{handicap}"
          . ($_[0]{komi} < 0 ? $_[0]{komi} : "+$_[0]{komi}")
      if $self->{handicap} >= 0;

   $rules .= " " . $self->score_string
      if $self->is_scored;

   $rules;
}

package KGS::GameRecord;

use KGS::Constants;

sub score {
   $_[0]{score};
}

sub revision {
   $_[0]{revision};
}

sub is_scored {
   ! ($_[0]{size} & 0x80);
}

sub gametype {
   $_[0]{gametype};
}

sub size {
   $_[0]{size} & 0x3f;
}

sub komi {
   $_[0]{komi} & 0x0800
      ? 0.5 * ($_[0]{komi} & 0x7ff) - 0x400
      : 0.5 * ($_[0]{komi} & 0x7ff);
}

sub handicap {
   $_[0]{handicap};
}

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

   my $res;

   if ($self->is_scored) {
      $score = $self->score;
      if ($score < 0) {
         $res = "W+";
         $score *= -1;
      } else  {
         $res = "B+";
      }
      $res .= $special_score{$score * 2} || $score;
   } else {
      $res = "(unfinished)";
   }

   $res;
}

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

   return if $self->is_inplay;
   return if $self->{score} == SCORE_ADJOURNED;
   return if $self->{gametype} & GAMETYPE_PRIVATE;

   $revision = $self->revision;

   my $p1 = $self->{black}{name};
   my $p2 = $self->{white}{name};
   my $p3 = $self->{owner}{name};

   my ($year, $month, $day) = (gmtime $self->{timestamp})[5,4,3];

   my $revisionstring = $revision ? "-" . ($revision+1) : "";
   my $playerstring =
         $p3 && $self->gametype == GAMETYPE_DEMONSTRATION
            ? $p3
            : $p2 eq $p1 
              ? $p2
              : "$p2-$p1";

   sprintf "/games/%d/%d/%d/%s%s.sgf",
           $year + 1900, $month + 1, $day,
           $playerstring, $revisionstring;
}

sub url {
   my $uri = &uri;
   $uri && "http://kgs.kiseido.com$uri";
}

package KGS::Room;

sub is_admin   { $_[0]{flags} & 0x01 } # maybe only admins (?) hidden (?)
sub is_default { $_[0]{flags} & 0x04 } # auto-join(?)
sub is_private { $_[0]{flags} & 0x10 }

package KGS::Rules;

sub new {
   my $class = shift;
   my $self = bless { 
      gametype => 0,
      ruleset  => RULESET_JAPANESE,
      size     => 19,
      handicap => 0,
      komi     => 6.5,
      timesys  => TIMESYS_BYO_YOMI,
      time     => 20*60,
      interval => 60,
      count    => 10,
   }, $class;
}

package KGS::Challenge;

package KGS::Score;

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

   my $score = sprintf "%d territory + %d captures", $self->{territory}, $self->{captures};
   $score .= sprintf " + %g komi", $self->{komi} if $self->{komi};
   $score .= sprintf " = %g", $self->{territory} + $self->{captures} + $self->{komi};

   $score;
}

package KGS::Stats;

package KGS::Protocol::Generator;

# generate the numbers used for enc/de"crypt"ion

sub new {
   bless { server_state => 0, client_state => 0, server_seed => " " }, shift;
}

sub set_server_seed {
   my ($self, $seed) = @_;

   $self->{server_seed} = $seed;
}

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

   use integer;

   $msg ^= pack "C", $self->{client_state} >> 24;

   $self->{client_state} = $self->{client_state} * 0x4C2AF9B + 0xFFFFFFFB + length $msg;

   #printf "XXX %lx ($self->{client_state})\n", $self->{client_state};
   #printf "XXY %x (%x)\n", $len, 2 + length $msg;

   $msg;
}

*dec_client = \&enc_client;

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

   use integer;

   my $type = unpack "v", $msg;

   #printf "<LEN(%d) type %04x server_state %lx\n", length $msg, $type, $self->{server_state};#d#

   if (42 < length $msg) {
      $type = ($type + $self->{server_state}) & 0xffff;
      (substr $msg, 0, 2) = pack "v", $type;
   }

   $self->{server_state} = $self->{server_state} * ($type - 0x6cdd)
                  + ord substr $self->{server_seed}, $type % length $self->{server_seed};

   #printf ">LEN(%d) type %04x server_state %lx\n", length $msg, (unpack "v", $msg), $self->{server_state};#d#

   $msg;
}

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

   Carp::croak "NYI";
}

1;


Revision:	1.88
Committed:	Fri Jun 20 12:47:01 2008 UTC (15 years, 11 months ago) by root
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.87:	+9 -9 lines
Log Message:	lib/Net/IGS.pm
#	Content
1	use utf8;
2
3	package KGS::Protocol;
4
5	use Carp;
6	use Compress::Zlib;
7	use Time::HiRes;
8	use Scalar::Util;
9
10	use KGS::Messages;
11
12	my $KGSHOST = "goserver.gokgs.com";
13	my $KGSPORT = 2379;
14	my $SGFHOST = "216.93.172.124";
15
16	our $NOW; # the time the last packet was received
17
18	our $VERSION = '0.99';
19
20	sub MSG_CHANNEL() { 0x4000 }
21
22	sub KGSHOST() { $ENV{KGSHOST} \|\| $KGSHOST }
23	sub KGSPORT() { $ENV{KGSPORT} \|\| $KGSPORT }
24	sub SGFHOST() { $ENV{SGFHOST} \|\| $SGFHOST }
25
26	=item new arg => value,...
27
28	=cut
29
30	sub new {
31	my $class = shift;
32	my $self = bless {
33	@_,
34	}, $class;
35	$self;
36	}
37
38	sub encode_msg {
39	my ($type, %arg) = @_;
40
41	my $msg = $KGS::Messages::enc_client{$type}
42	or die "FATAL: tried to send unknown message type '$type'";
43
44	$msg = $msg->(\%arg);
45	#print "MSG $type => ", (join " ", %arg), "\n";#d#
46	#print "HEX ", (unpack "H*", $msg), "\n";#d#
47	#print "ok (y/n)?"; die unless <> =~ /^y/;#d#dd# let's be paranoid.. "don't crash the server, uh-oh"
48
49	pack "va*", 2 + length $msg, $msg;
50	}
51
52	# encode/decode functions
53	sub decode_msg($) {
54	my ($type, $data) = unpack "v a*", $_[0];
55
56	my $msg = $KGS::Messages::dec_server{$type};
57
58	if ($msg) {
59	$msg->($data);
60	} else {
61	{
62	type => (sprintf "unknown_%04x", $type),
63	DATA => $data,
64	};
65	}
66	}
67
68	my $CLIENTVERSION = 4; # 4 == 3 + server zlib compressed
69	my $SERVERVERSION = 3; # since quite some time now
70
71	=item send
72
73	Format a message and send it to the server.
74
75	=cut
76
77	sub send($@) {
78	my $self = shift;
79
80	#use PApp::Util; print PApp::Util::dumpval [@_];#d#
81
82	my $msg = $self->{generator}->enc_client (encode_msg @_);
83
84	if ($self->{sock}) {
85	syswrite $self->{sock}, $msg
86	or croak "msg: $!";
87	} else {
88	warn "KGS::Protocol::send() called without a socket connection\n";
89	}
90	}
91
92	sub init {
93	my ($self) = @_;
94
95	$self->{generator} = new KGS::Protocol::Generator;
96	$self->{zstream} = inflateInit;
97	}
98
99	=item handshake $fh
100
101	Do the initial handshaking with the server on the given socket and make it
102	the current one. This will initialize the communications stack and set the
103	socket to be used to sending messages.
104
105	=cut
106
107	sub handshake {
108	my ($self, $fh) = @_;
109
110	$self->init;
111	$self->{sock} = $fh;
112
113	# syswrite $fh, chr $CLIENTVERSION
114	# or croak "initial server handshake send: $!";
115	#
116	# sysread $fh, my $buf, 1
117	# or croak "initial server handshake recv: $!\n";
118	#
119	# $buf eq chr $SERVERVERSION
120	# or croak "initial server handshake: server version ".(ord $buf)." unsupported";
121	}
122
123	=item login $clientversion, $name, $pass[, $locale]
124
125	Login to the server. C<$clientversion> should be a descriptive string that
126	uniquely identifies the client and the client version.
127
128	=cut
129
130	sub login {
131	my ($self, $clientver, $name, $pass, $locale) = @_;
132
133	$self->{generator}->set_server_seed ($name);
134
135	$self->{name} = $name;
136	$self->send (login =>
137	name => $name,
138	password => $pass,
139	locale => $locale,
140	guest => $pass eq "",
141	clientver => $clientver,
142	);
143	}
144
145	=item disconnect
146
147	Close the socket, generate a quit message and unregisters listeners.
148
149	=cut
150
151	sub disconnect {
152	my $self = shift;
153
154	close delete $self->{sock}
155	if $self->{sock};
156
157	$self->inject ({ type => "quit" });
158
159	delete $self->{cb};
160	}
161
162	=item feed_data $data
163
164	Feed new data from the server into this object. This might or might not
165	result in messages being dispatched.
166
167	=cut
168
169	sub feed_data {
170	my $self = $_[0];
171
172	$NOW = Time::HiRes::time;
173
174	my ($data, $status) = $self->{zstream}->inflate ($_[1]);
175	$status == Z_OK or croak "inflate: status is $status";
176
177	$self->{rbuf} .= $data;
178
179	while (($self->{rlen} \|\| 2) <= length $self->{rbuf}) {
180	my $data = substr $self->{rbuf}, 0, $self->{rlen} \|\| 2, "";
181	if (delete $self->{rlen}) {
182	#open XTYPE, "\|xtype"; printf XTYPE "%16x", length($data); print XTYPE $data; close XTYPE;#d#
183
184	$self->inject (decode_msg $self->{generator}->dec_server ($data));
185	} else {
186	$self->{rlen} = (unpack "v", $data) - 2;
187	}
188	}
189	}
190
191	sub register {
192	my ($self, $obj, @types) = @_;
193
194	for (@types) {
195	$self->{cb}{$_}{$obj} = $obj;
196	Scalar::Util::weaken $self->{cb}{$_}{$obj};
197	}
198	}
199
200	sub unregister {
201	my ($self, $obj, @types) = @_;
202
203	delete $self->{cb}{$_}{$obj} for @types;
204	}
205
206	sub inject {
207	my ($self, $msg) = @_;
208
209	$msg->{NOW} = $NOW; # timestamps heissen bei mir "NOW"
210	#use PApp::Util; warn PApp::Util::dumpval $msg;#d#
211
212	for my $type ("any", $msg->{type}, "$msg->{type}:$msg->{channel}") {
213	for my $obj (values %{$self->{cb}{$type} \|\| {}}) {
214	$obj->inject($msg) if $obj;
215	}
216	}
217	}
218
219	=item alloc_clientid
220
221	Create and return a new channel id, used e.g. for game creation. We start
222	at one, but cgoban2 seems to start at zero.
223
224	=cut
225
226	sub alloc_clientid() {
227	my ($self) = @_;
228
229	++$self->{clientid};
230	}
231
232	package KGS::User;
233
234	sub is_admin { $_[0]{flags} & 0x00004 }
235	sub is_active { $_[0]{flags} & 0x00008 } # logged in(?)
236	sub is_gone { $_[0]{flags} & 0x00010 }
237	sub is_idle { $_[0]{flags} & 0x00020 }
238	sub has_url { $_[0]{flags} & 0x00040 } # wild guess
239	sub is_playing { $_[0]{flags} & 0x00080 }
240	sub is_reliable { $_[0]{flags} & 0x00100 } # reliable ranking?
241	sub is_ranked { $_[0]{flags} & 0x00200 }
242	# 0x00400 # no idea
243	sub is_ranked2 { $_[0]{flags} & 0x00800 } # very reliably ranked? g
244	sub has_pic { $_[0]{flags} & 0x01000 }
245	sub email_priv { $_[0]{flags} & 0x02000 }
246
247	sub is_bot { $_[0]{flags} & 0x10000 }
248	sub is_guest { $_[0]{flags} & 0x20000 }
249
250	sub usertype { $_[0]{flags} & 3 }
251	# 0 == normal
252	# 1 == ranked robot (gtp-client)
253	# 2 == teacher
254	# 3 == assistant
255
256	sub is_valid { length $_[0]{name} }
257
258	sub rank_number {
259	$_[0]{flags} >> 24;
260	}
261
262	sub rank {
263	my $rank = $_[0]->rank_number;
264	$rank <= 0
265	? ""
266	: $rank <= 30
267	? (31-$rank) . "k"
268	: $rank <= 39
269	? ($rank - 30) . "d"
270	: ($rank - 39) . "p";
271	}
272
273	sub rank_string {
274	$_[0]->is_ranked
275	? $_[0]->rank . ($_[0]->is_reliable ? "" : "?")
276	: "-";
277	}
278
279	sub flags_string {
280	my $r;
281
282	$r .= "+" if &is_active;
283	$r .= ":" if &is_ranked2;
284
285	$r .= " (admin)" if &is_admin;
286
287	$r .= " (child)" if &usertype == 1;
288	$r .= " (teacher)" if &usertype == 2;
289	$r .= " (ass)" if &usertype == 3;
290
291	$r .= " (guest)" if &is_guest;
292	$r .= " (bot)" if &is_bot;
293
294	$r .= " (gone)" if &is_gone;
295	$r .= " (idle)" if &is_idle;
296	$r .= " (playing)" if &is_playing;
297
298	$r .= " (has pic)" if &has_pic;
299	$r .= " (has url)" if &has_url;
300
301	$r .= sprintf "%04x", $_[0]{flags} & 0xfcc000
302	if $_[0]{flags} & 0xfcc000;
303
304	$r;
305	}
306
307	sub as_string {
308	sprintf "%s\xa0[%s]", $_[0]{name}, $_[0]->rank_string;
309	}
310
311	package KGS::Game;
312
313	use KGS::Constants;
314
315	sub is_saved { $_[0]{saved} } # hmm... not a flag...
316	sub is_scored { $_[0]{flags} & 0x1 }
317	sub is_adjourned { $_[0]{flags} & 0x2 }
318	# there is more going on, one bit 0x4 and above(?)
319
320	sub is_inprogress { $_[0]{handicap} >= 0 } # maybe rename to "complete"? "started"? "has_board"? ;)
321
322	sub is_private { $_[0]{type} & GAMETYPE_PRIVATE }
323
324	sub is_active {
325	&is_inprogress and !&is_scored;
326	}
327
328	sub player_colour {
329	$_[0]{black}{name} eq $_[1] ? COLOUR_BLACK
330	: $_[0]{white}{name} eq $_[1] ? COLOUR_WHITE
331	: COLOUR_NONE;
332	}
333
334	sub score {
335	# due to the peculiar way score values are encoded, we keep special
336	# values in the /4 format, while normal scores are represented "as is".
337	# this makes it compatible to the /4 format used in trees.
338	&is_scored
339	? 8000 > abs $_[0]{moves} ? $_[0]{moves} * (1 / 2) : $_[0]{moves} / 4
340	: SCORE_UNKNOWN;
341	}
342
343	sub moves {
344	&is_scored
345	? -1
346	: $_[0]{moves};
347	}
348
349	sub type {
350	$_[0]{type} & 15;
351	}
352
353	sub type_char {
354	(uc substr ($gametype{&type}, 0, 1))
355	. (&is_private ? "P" : "");
356	}
357
358	sub owner {
359	length $_[0]{owner}{name}
360	? $_[0]{owner}
361	: $_[0]{white};
362	}
363
364	sub opponent_string {
365	$_[0]{owner}{name} ?
366	$_[0]{black}{name} eq $_[0]{white}{name}
367	? "" : "(".$_[0]{white}->as_string." - ".$_[0]{black}->as_string.")"
368	: "vs. ".$_[0]{black}->as_string;
369	}
370
371	sub size {
372	$_[0]{size};
373	}
374
375	sub size_string {
376	"$_[0]{size}×$_[0]{size}";
377	}
378
379	sub score_string {
380	my ($self) = @_;
381
382	my $res;
383
384	if ($self->is_scored) {
385	$score = $self->score;
386	if ($score < 0) {
387	$res = "W+";
388	$score *= -1;
389	} else {
390	$res = "B+";
391	}
392	$res .= $special_score{$score * 4} \|\| $score;
393	} else {
394	$res = "(unfinished)";
395	}
396
397	$res;
398	}
399
400	# convinience
401
402	sub rules {
403	my ($self) = @_;
404
405	my $rules = $self->size_string;
406
407	$rules .= " H$_[0]{handicap}"
408	. ($_[0]{komi} < 0 ? $_[0]{komi} : "+$_[0]{komi}")
409	if $self->{handicap} >= 0;
410
411	$rules .= " " . $self->score_string
412	if $self->is_scored;
413
414	$rules;
415	}
416
417	package KGS::GameRecord;
418
419	use KGS::Constants;
420
421	sub score {
422	$_[0]{score};
423	}
424
425	sub revision {
426	$_[0]{revision};
427	}
428
429	sub is_scored {
430	! ($_[0]{size} & 0x80);
431	}
432
433	sub gametype {
434	$_[0]{gametype};
435	}
436
437	sub size {
438	$_[0]{size} & 0x3f;
439	}
440
441	sub komi {
442	$_[0]{komi} & 0x0800
443	? 0.5 * ($_[0]{komi} & 0x7ff) - 0x400
444	: 0.5 * ($_[0]{komi} & 0x7ff);
445	}
446
447	sub handicap {
448	$_[0]{handicap};
449	}
450
451	sub score_string {
452	my ($self) = @_;
453
454	my $res;
455
456	if ($self->is_scored) {
457	$score = $self->score;
458	if ($score < 0) {
459	$res = "W+";
460	$score *= -1;
461	} else {
462	$res = "B+";
463	}
464	$res .= $special_score{$score * 2} \|\| $score;
465	} else {
466	$res = "(unfinished)";
467	}
468
469	$res;
470	}
471
472	sub uri {
473	my ($self) = @_;
474
475	return if $self->is_inplay;
476	return if $self->{score} == SCORE_ADJOURNED;
477	return if $self->{gametype} & GAMETYPE_PRIVATE;
478
479	$revision = $self->revision;
480
481	my $p1 = $self->{black}{name};
482	my $p2 = $self->{white}{name};
483	my $p3 = $self->{owner}{name};
484
485	my ($year, $month, $day) = (gmtime $self->{timestamp})[5,4,3];
486
487	my $revisionstring = $revision ? "-" . ($revision+1) : "";
488	my $playerstring =
489	$p3 && $self->gametype == GAMETYPE_DEMONSTRATION
490	? $p3
491	: $p2 eq $p1
492	? $p2
493	: "$p2-$p1";
494
495	sprintf "/games/%d/%d/%d/%s%s.sgf",
496	$year + 1900, $month + 1, $day,
497	$playerstring, $revisionstring;
498	}
499
500	sub url {
501	my $uri = &uri;
502	$uri && "http://kgs.kiseido.com$uri";
503	}
504
505	package KGS::Room;
506
507	sub is_admin { $_[0]{flags} & 0x01 } # maybe only admins (?) hidden (?)
508	sub is_default { $_[0]{flags} & 0x04 } # auto-join(?)
509	sub is_private { $_[0]{flags} & 0x10 }
510
511	package KGS::Rules;
512
513	sub new {
514	my $class = shift;
515	my $self = bless {
516	gametype => 0,
517	ruleset => RULESET_JAPANESE,
518	size => 19,
519	handicap => 0,
520	komi => 6.5,
521	timesys => TIMESYS_BYO_YOMI,
522	time => 20*60,
523	interval => 60,
524	count => 10,
525	}, $class;
526	}
527
528	package KGS::Challenge;
529
530	package KGS::Score;
531
532	sub as_string {
533	my ($self) = @_;
534
535	my $score = sprintf "%d territory + %d captures", $self->{territory}, $self->{captures};
536	$score .= sprintf " + %g komi", $self->{komi} if $self->{komi};
537	$score .= sprintf " = %g", $self->{territory} + $self->{captures} + $self->{komi};
538
539	$score;
540	}
541
542	package KGS::Stats;
543
544	package KGS::Protocol::Generator;
545
546	# generate the numbers used for enc/de"crypt"ion
547
548	sub new {
549	bless { server_state => 0, client_state => 0, server_seed => " " }, shift;
550	}
551
552	sub set_server_seed {
553	my ($self, $seed) = @_;
554
555	$self->{server_seed} = $seed;
556	}
557
558	sub enc_client {
559	my ($self, $msg) = @_;
560
561	use integer;
562
563	$msg ^= pack "C", $self->{client_state} >> 24;
564
565	$self->{client_state} = $self->{client_state} * 0x4C2AF9B + 0xFFFFFFFB + length $msg;
566
567	#printf "XXX %lx ($self->{client_state})\n", $self->{client_state};
568	#printf "XXY %x (%x)\n", $len, 2 + length $msg;
569
570	$msg;
571	}
572
573	*dec_client = \&enc_client;
574
575	sub dec_server {
576	my ($self, $msg) = @_;
577
578	use integer;
579
580	my $type = unpack "v", $msg;
581
582	#printf "<LEN(%d) type %04x server_state %lx\n", length $msg, $type, $self->{server_state};#d#
583
584	if (42 < length $msg) {
585	$type = ($type + $self->{server_state}) & 0xffff;
586	(substr $msg, 0, 2) = pack "v", $type;
587	}
588
589	$self->{server_state} = $self->{server_state} * ($type - 0x6cdd)
590	+ ord substr $self->{server_seed}, $type % length $self->{server_seed};
591
592	#printf ">LEN(%d) type %04x server_state %lx\n", length $msg, (unpack "v", $msg), $self->{server_state};#d#
593
594	$msg;
595	}
596
597	sub enc_server {
598	my ($self, $msg) = @_;
599
600	Carp::croak "NYI";
601	}
602
603	1;
604
605
606