1 |
package IGS::Protocol; |
2 |
use strict; |
3 |
|
4 |
my %buildin_events = ( |
5 |
'auto_update' => [ sub { |
6 |
my $self = shift; |
7 |
my $upd = shift; |
8 |
|
9 |
if ($upd =~ m/^Match (\d+):/) { |
10 |
$self->feed_event ('game_begin', $1); |
11 |
} elsif ($upd =~ m/^Game (\d+):\s*(\S+)\s+vs\s+(\S+)\s*:\s*(.+?)\s*$/) { |
12 |
$self->feed_event ('game_over', $1, $2); |
13 |
} elsif ($upd =~ m/^(\S+) has disconnected/) { |
14 |
$self->feed_event ('player_disconnected', $1); |
15 |
} elsif ($upd =~ m/^(\S+) has connected/) { |
16 |
$self->feed_event ('player_connected', $1); |
17 |
} |
18 |
} ], |
19 |
'req_games' => [sub { $_[0]->sendline ('games') }], |
20 |
'req_players' => [sub { $_[0]->sendline ('who') }], |
21 |
'req_moves' => [sub { $_[0]->sendline ("moves $_[1]") }], |
22 |
'req_observe' => [sub { $_[0]->sendline ("observe $_[1]") }], |
23 |
'req_unobserve' => [sub { $_[0]->sendline ("unobserve $_[1]") }], |
24 |
); |
25 |
|
26 |
sub new { |
27 |
my $class = shift; |
28 |
bless { @_, events => { %buildin_events } }, $class; |
29 |
} |
30 |
|
31 |
sub init { |
32 |
my ($self, $user, $pass) = @_; |
33 |
|
34 |
$self->{login_name} = $user; |
35 |
$self->{login_pass} = $pass; |
36 |
$self->{login} = 1; |
37 |
$self->{free_pos} = []; |
38 |
} |
39 |
|
40 |
sub set_writer { |
41 |
my ($self, $cb) = @_; |
42 |
$self->{write} = $cb; |
43 |
} |
44 |
|
45 |
sub set_ev_cb { |
46 |
my ($self, $event, $cb) = @_; |
47 |
|
48 |
if (@{$self->{free_pos}}) { |
49 |
my $idx = pop @{$self->{free_pos}}; |
50 |
$self->{events}->{$event}->[$idx] = $cb; |
51 |
return $idx; |
52 |
|
53 |
} else { |
54 |
push @{$self->{events}->{$event}}, $cb; |
55 |
return ((scalar @{$self->{events}->{$event}}) - 1); |
56 |
} |
57 |
} |
58 |
|
59 |
sub unset_ev_cb { |
60 |
my ($self, $event, $idx) = @_; |
61 |
|
62 |
if ($self->{events}->{$event}->[$idx]) { print "REMOVED $idx\n" } |
63 |
$self->{events}->{$event}->[$idx] = undef; |
64 |
push @{$self->{free_pos}}, $idx; |
65 |
} |
66 |
|
67 |
sub feed_event { |
68 |
my ($self, $event, @args) = @_; |
69 |
|
70 |
return if not $self->{events}->{$event}; |
71 |
|
72 |
for (@{$self->{events}->{$event}}) { |
73 |
$_->($self, @args) if $_; |
74 |
} |
75 |
} |
76 |
|
77 |
sub send_queue { |
78 |
my $self = shift; |
79 |
my $str = pop @{$self->{cmd_queue}};; |
80 |
|
81 |
$str or return; |
82 |
|
83 |
$self->{write}->($str . "\015\012"); |
84 |
print "< $str\n"; |
85 |
} |
86 |
|
87 |
sub sendline { |
88 |
my ($self, $str) = @_; |
89 |
push @{$self->{cmd_queue}}, $str; |
90 |
} |
91 |
|
92 |
sub feed_data { |
93 |
my ($self, $buffer) = @_; |
94 |
|
95 |
my @lines; |
96 |
|
97 |
while ($$buffer =~ s/^([^\r\n]*)\r?\n//) { |
98 |
push @lines, $1; |
99 |
} |
100 |
|
101 |
$self->handle_line ($_) for @lines; |
102 |
|
103 |
if ($self->{login}) { |
104 |
if ($$buffer =~ s/^Login: //) { |
105 |
$self->sendline ($self->{login_name}); |
106 |
$self->{login} = 0; |
107 |
$self->send_queue (); |
108 |
} |
109 |
} |
110 |
|
111 |
} |
112 |
|
113 |
sub handle_line { |
114 |
my ($self, $line) = @_; |
115 |
|
116 |
if ($line =~ m/^1 1/) { |
117 |
$self->sendline ($self->{login_pass}); |
118 |
$self->send_queue (); |
119 |
|
120 |
} elsif ($line =~ m/^5 Invalid password/i) { |
121 |
print "wrong password"; |
122 |
exit (1); |
123 |
|
124 |
} elsif ($line =~ m/[89] File/) { |
125 |
|
126 |
if ($self->{status} eq 'file') { |
127 |
$self->{status} = undef; |
128 |
$self->feed_event ('recv_file', $self->{files}->{$self->{cur_file}}); |
129 |
|
130 |
} else { |
131 |
$self->{status} = 'file'; |
132 |
$self->{cur_file}++; |
133 |
} |
134 |
|
135 |
} elsif ($self->{status} eq 'file') { |
136 |
$self->{files}->{$self->{cur_file}} .= $line . "\n"; |
137 |
|
138 |
} elsif ($line =~ m/^21 \{([^}]+)\}/) { |
139 |
$self->feed_event ('auto_update', $1); |
140 |
|
141 |
} elsif ($line =~ m/^1 [58]/) { |
142 |
$self->send_queue (); |
143 |
|
144 |
} elsif ($line =~ m/^39 IGS entry on/ || $line =~ m/^IGS entry on/) { |
145 |
$self->sendline ("toggle client true"); |
146 |
$self->sendline ("toggle quiet false"); |
147 |
$self->feed_event ('logged_on'); |
148 |
|
149 |
#7 [##] white name [ rk ] black name [ rk ] (Move size H Komi BY FR) (###) |
150 |
#7 [126] goholic [ 1d*] vs. tjam [ 1d*] (270 19 0 0.5 13 I) ( 0) |
151 |
# "7 [%2d] %11s [%4s] vs. %11s [%4s] (%3d %4d %2d %4.1f %2d %s%s) (%3d)", |
152 |
} elsif ($line =~ m/^7 \[##\]/) { # ignore |
153 |
|
154 |
} elsif ($line =~ m/^7[ ] |
155 |
\[\s*(\d+)\s*\] |
156 |
\s+ (\S+) \s+ \[\s*(\S+)\s*\] \s+ vs\. |
157 |
\s+ (\S+) \s+ \[\s*(\S+)\s*\] \s+ |
158 |
\(\s* (\d+) \s+ (\d+) \s+ (\d+) \s+ (-?\d+\.?\d*) \s+ (\d+) [ ] (.)(.) \s*\) |
159 |
\s+\(\s*(\d+)\s*\)/x) { |
160 |
my $game = { number => $1, |
161 |
white => $2, white_rank => $3, |
162 |
black => $4, black_rank => $5, |
163 |
move => $6, size => $7, handicap => $8, komi => $9, byo => $10, Fflag => $11, Rflag => $12 |
164 |
}; |
165 |
$self->feed_event ('game_list', $game); |
166 |
|
167 |
# 27 Info Name Idle Rank | Info Name Idle Rank |
168 |
# 27 X -- -- ctian 2m 1k* | X 11 -- fastt 4m NR |
169 |
} elsif ($line =~ m/^27[ ]\s*([QRSX! ]+?) \s* ((?:--)|\d+) \s+ ((?:--)|\d+) \s+ (\S+) \s+ (\S+) \s+ (\S+)\s+ |
170 |
\| \s+([QRSX! ]+?) \s* ((?:--)|\d+) \s+ ((?:--)|\d+) \s+ (\S+) \s+ (\S+) \s+ (\S+)\s*/x) { |
171 |
my $player = { flags => $1, obs => $2, playing => $3, name => $4, idle => $5, rank => $6 }; |
172 |
my $player2 = { flags => $7, obs => $8, playing => $9, name => $10, idle => $11, rank => $12 }; |
173 |
|
174 |
$self->feed_event ('player_list', $player); |
175 |
$self->feed_event ('player_list', $player2); |
176 |
|
177 |
} elsif ($line =~ m/^27[ ]\s*([QRSX! ]+?) \s* ((?:--)|\d+) \s+ ((?:--)|\d+) \s+ (\S+) \s+ (\S+) \s+ (\S+)\s*/x) { |
178 |
my $player = { flags => $1, obs => $2, playing => $3, name => $4, idle => $5, rank => $6 }; |
179 |
|
180 |
$self->feed_event ('player_list', $player); |
181 |
|
182 |
} elsif ($line =~ m/^27[ ] [^|]* \| \s+([QRSX! ]+?) \s* ((?:--)|\d+) \s+ ((?:--)|\d+) \s+ (\S+) \s+ (\S+) \s+ (\S+)\s*/x) { |
183 |
my $player = { flags => $1, obs => $2, playing => $3, name => $4, idle => $5, rank => $6 }; |
184 |
|
185 |
$self->feed_event ('player_list', $player); |
186 |
|
187 |
} elsif ($line =~ m/^15\s+Game\s+(\d+)\s+\S:\s+ |
188 |
(\S+) \s+ \( \s*(-?\d+) \s+(-?\d+) \s+(-?\d+) \)\s+vs\s+ |
189 |
(\S+) \s+ \( \s*(-?\d+) \s+(-?\d+) \s+(-?\d+) \)/x) { |
190 |
|
191 |
print "GAMLI: $line\n"; |
192 |
$self->{games}->{$1} = { white => $2, white_time => $4, white_stones => $5, white_captures => $4, |
193 |
black => $5, black_time => $8, black_stones => $9, black_captures => $7 }; |
194 |
$self->{cur_game} = $1; |
195 |
|
196 |
} elsif ($line =~ m/^15 \s*(\d+)\((.)\): (\S+)/) { |
197 |
print "LIL: ($self->{cur_game}) $line\n"; |
198 |
my $move = { %{$self->{games}->{$self->{cur_game}}} }; |
199 |
|
200 |
if ($move) { |
201 |
$move->{number} = $1; |
202 |
$move->{color} = $2 eq 'W' ? 'white' : 'black'; |
203 |
$move->{coords} = $3; |
204 |
$self->feed_event ('game_move', $self->{cur_game}, $move); |
205 |
} |
206 |
} elsif ($line =~ m/^9 Game is titled:\s*(.+?)\s*$/) { |
207 |
$self->{games}->{$self->{cur_game}}->{title} = $1; |
208 |
|
209 |
$self->feed_event ('game_title', $self->{cur_game}, $1); |
210 |
|
211 |
} elsif ($line =~ m/^2 /) { |
212 |
# ignore |
213 |
|
214 |
} elsif ($line !~ m/^\s*$/) { |
215 |
print ">>>" . $line . "<\n"; |
216 |
|
217 |
} |
218 |
} |
219 |
|
220 |
1; |