| … | |
… | |
| 59 | $i ^= $j; |
59 | $i ^= $j; |
| 60 | |
60 | |
| 61 | ($i & 0xffffff) ^ ($i >> 24); |
61 | ($i & 0xffffff) ^ ($i >> 24); |
| 62 | } |
62 | } |
| 63 | |
63 | |
|
|
64 | my %encode = reverse %$Net::Knuddels::Dictionary; |
|
|
65 | |
|
|
66 | my $RE_enc = join "|", keys %encode; |
|
|
67 | |
|
|
68 | sub encode { |
|
|
69 | my ($msg) = @_; |
|
|
70 | |
|
|
71 | my $data = ""; |
|
|
72 | |
|
|
73 | while () { |
|
|
74 | $data .= $encode{$1} while $msg =~ /\G($RE_enc)/cog; |
|
|
75 | |
|
|
76 | $msg =~ /\G./csog |
|
|
77 | or last; |
|
|
78 | |
|
|
79 | $data .= $encode{"\\\\\\"} . unpack "b*", pack "v", ord $1; |
|
|
80 | } |
|
|
81 | |
|
|
82 | pack "b*", $data |
|
|
83 | } |
|
|
84 | |
| 64 | =head2 CLASS Net::Knuddels::Protocol |
85 | =head2 CLASS Net::Knuddels::Protocol |
| 65 | |
86 | |
| 66 | You B<must> call the C<destroy> method of this class when you no longer |
87 | You B<must> call the C<destroy> method of this class when you no longer |
| 67 | use it, as circular references will keep the object alive otherwise. |
88 | use it, as circular references will keep the object alive otherwise. |
| 68 | |
89 | |
| … | |
… | |
| 144 | my ($self, $msg) = @_; |
165 | my ($self, $msg) = @_; |
| 145 | |
166 | |
| 146 | my $bin = unpack "b*", $msg; |
167 | my $bin = unpack "b*", $msg; |
| 147 | my $res = ""; |
168 | my $res = ""; |
| 148 | |
169 | |
| 149 | while ($bin =~ /\G($RE_dec)/cmog) { |
170 | while ($bin =~ /\G($RE_dec)/cog) { |
| 150 | my $frag = $Net::Knuddels::Dictionary->{$1}; |
171 | my $frag = $Net::Knuddels::Dictionary->{$1}; |
| 151 | $frag = pack "b*", $bin =~ /\G.{16}/cmg && $1 if $frag eq "\\\\\\"; |
172 | $frag = chr unpack "v", pack "b*", $bin =~ /\G.{16}/cg && $1 if $frag eq "\\\\\\"; |
| 152 | $res .= $frag; |
173 | $res .= $frag; |
| 153 | } |
174 | } |
| 154 | $bin =~ /\G(.*[^0].*)$/ and die "Net::Knuddels::Receiver: undecodable message tail '$1'"; |
175 | $bin =~ /\G(.*[^0].*)$/ and die "Net::Knuddels::Receiver: undecodable message tail '$1'"; |
| 155 | |
176 | |
| 156 | $self->feed_event (split /\0/, $res); |
177 | $self->feed_event (split /\0/, $res); |
| … | |
… | |
| 179 | $self->{cb}{$type}{$cb} = $cb; |
200 | $self->{cb}{$type}{$cb} = $cb; |
| 180 | } |
201 | } |
| 181 | |
202 | |
| 182 | =item $protocol->destroy |
203 | =item $protocol->destroy |
| 183 | |
204 | |
| 184 | I<MUST> be called to destroy teh object, otherwise it will leak (no automatic cleanup). |
205 | I<MUST> be called to destroy the object, otherwise it will leak (no automatic cleanup). |
| 185 | |
206 | |
| 186 | =cut |
207 | =cut |
| 187 | |
208 | |
| 188 | sub destroy { |
209 | sub destroy { |
| 189 | my ($self) = @_; |
210 | my ($self) = @_; |
| … | |
… | |
| 193 | |
214 | |
| 194 | =back |
215 | =back |
| 195 | |
216 | |
| 196 | =head2 CLASS Net::Knuddels::Client |
217 | =head2 CLASS Net::Knuddels::Client |
| 197 | |
218 | |
|
|
219 | Implement a Knuddels client connection. |
|
|
220 | |
| 198 | =over 4 |
221 | =over 4 |
| 199 | |
222 | |
| 200 | =cut |
223 | =cut |
| 201 | |
224 | |
| 202 | package Net::Knuddels::Client; |
225 | package Net::Knuddels::Client; |
|
|
226 | |
|
|
227 | =item new Net::Knuddels::Client [IO::Socket::new arguments] |
|
|
228 | |
|
|
229 | Create a new client connection. |
|
|
230 | |
|
|
231 | =cut |
|
|
232 | |
|
|
233 | use IO::Socket::INET; |
|
|
234 | |
|
|
235 | sub new { |
|
|
236 | my ($class, @arg) = @_; |
|
|
237 | |
|
|
238 | my $fh = new IO::Socket::INET @arg |
|
|
239 | or Carp::croak "Net::Knuddels::Client::new: $!"; |
|
|
240 | |
|
|
241 | my $self = bless { |
|
|
242 | fh => $fh, |
|
|
243 | proto => (new Net::Knuddels::Protocol), |
|
|
244 | }, $class; |
|
|
245 | |
|
|
246 | syswrite $fh, "\0"; |
|
|
247 | |
|
|
248 | $self |
|
|
249 | } |
|
|
250 | |
|
|
251 | =item $client->fh |
|
|
252 | |
|
|
253 | Return the fh used for communications. You are responsible for calling C<< |
|
|
254 | $client->fh_ready >> whenever the fh becomes ready for reading. |
|
|
255 | |
|
|
256 | =cut |
|
|
257 | |
|
|
258 | sub fh { |
|
|
259 | $_[0]->{fh} |
|
|
260 | } |
|
|
261 | |
|
|
262 | =item $client->command ($type => @args) |
|
|
263 | |
|
|
264 | Send a message of type C<$type> and the given arguments to the server. |
|
|
265 | |
|
|
266 | =cut |
|
|
267 | |
|
|
268 | sub command { |
|
|
269 | my ($self, $type, @args) = @_; |
|
|
270 | |
|
|
271 | syswrite $self->{fh}, Net::Knuddels::encode join "\0", $type, @args; |
|
|
272 | } |
|
|
273 | |
|
|
274 | =item $client->login ($url, $unknown) |
|
|
275 | |
|
|
276 | Send a 't' message. The default for C<$url> is |
|
|
277 | C<http://www.knuddels.de/applet.html?v=86a&c=0> and C<$unknown> is C<6>. |
|
|
278 | |
|
|
279 | =cut |
|
|
280 | |
|
|
281 | sub login { |
|
|
282 | } |
|
|
283 | |
|
|
284 | =item $client->register ($type => $cb) |
|
|
285 | |
|
|
286 | See L<Net::Knuddels::Protocol::register>. |
|
|
287 | |
|
|
288 | =cut |
|
|
289 | |
|
|
290 | sub register { |
|
|
291 | my ($self, $type, $cb) = @_; |
|
|
292 | |
|
|
293 | $self->{protocol}->register ($type, $cb); |
|
|
294 | } |
| 203 | |
295 | |
| 204 | =back |
296 | =back |
| 205 | |
297 | |
| 206 | =head1 AUTHOR |
298 | =head1 AUTHOR |
| 207 | |
299 | |
