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