Deliantra/Deliantra/Protocol.pm

=head1 NAME

Crossfire::Protocol - client protocol module

=head1 SYNOPSIS

   use base Crossfire::Protocol; # you have to subclass

=head1 DESCRIPTION

Base class to implement a corssfire client.

=over 4

=cut

package Crossfire::Protocol;

our $VERSION = '0.1';

use strict;

use AnyEvent;
use IO::Socket::INET;

=item new Crossfire::Protocol host => ..., port => ...

=cut

sub new {
   my $class = shift;
   my $self = bless {
      mapw => 13,
      maph => 13,
      @_
   }, $class;

   $self->{fh} = new IO::Socket::INET PeerHost => $self->{host}, PeerPort => $self->{port}
      or die "$self->{host}:$self->{port}: $!";
   $self->{fh}->blocking (0); # stupid nonblock default

   my $buf;

   $self->{w} = AnyEvent->io (fh => $self->{fh}, poll => 'r', cb => sub {
      if (sysread $self->{fh}, $buf, 16384, length $buf) {
         for (;;) {
            last unless 2 <= length $buf;
            my $len = unpack "n", $buf;
            last unless $len + 2 <= length $buf;

            substr $buf, 0, 2, "";
            $self->feed (substr $buf, 0, $len, "");
         }
      } else {
         delete $self->{w};
         close $self->{fh};
      }
   });

   $self->send ("version 1023 1027 perlclient");
   $self->send ("setup sound 1 exp 1 map1acmd 1 itemcmd 2 darkness 1 mapsize $self->{mapw}x$self->{maph} "
              . "newmapcmd 1 facecache 1 extendedMapInfos 1 extendedTextInfos 1");
   $self->send ("addme");

   $self
}

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

   $data =~ s/^(\S+)\s//
      or return;

   my $command = "feed_$1";

   $self->$command ($data);
}

sub feed_version {
   my ($self, $version) = @_;
}

sub feed_setup {
   my ($self, $data) = @_;

   $data =~ s/^ +//;

   $self->{setup} = { split / +/, $data };

   my ($mapw, $maph) = split /x/, $self->{setup}{mapsize};

   if ($mapw != $self->{mapw} || $maph != $self->{maph}) {
      ($self->{mapw}, $self->{maph}) = ($mapw, $maph);
      $self->send ("setup mapsize ${mapw}x${maph}");
   }

   $self->feed_newmap;
}

=item $conn->query ($flags, $prompt) [OVERWRITE]

=cut

sub query { die "query is abstract" }

sub feed_query {
   my ($self, $data) = @_;

   my ($flags, $prompt) = split /\s+/, $data, 2;

   if ($flags == 0 && $prompt =~ /^What is your name\?\s+:$/ && length $self->{user}) {
      $self->send ("reply $self->{user}");
   } elsif ($flags == 4 && $prompt =~ /^What is your password\?\s+:$/ && length $self->{pass}) {
      $self->send ("reply $self->{pass}");
   } elsif ($flags == 4 && $prompt =~ /^Please type your password again\.\s+:$/ && length $self->{pass}) {
      $self->send ("reply $self->{pass}");
   } else {
      $self->query ($flags, $prompt);
   }
}

=item $conn->player_update ($player) [OVERWRITE]

tag, weight, face, name

=cut

sub player_update { }

sub feed_player {
   my ($self, $data) = @_;

   my ($tag, $weight, $face, $name) = unpack "NNN C/a", $data;

   $self->player_update ($self->{player} = {
      tag    => $tag,
      weight => $weight,
      face   => $face,
      name   => $name,
   });

   $self->feed_newmap;#d# why???
}

=item $conn->stats_update ($stats) [OVERWRITE]

=cut

sub stats_update { }

sub feed_stats {
   my ($self, $data) = @_;

   while (length $data) {
      my $stat = unpack "C", substr $data, 0, 1, "";
      my $value;

      if ($stat == 26 || $stat == 29 || $stat == 30 || $stat == 31 || $stat == 11) {
         $value = unpack "N", substr $data, 0, 4, "";
      } elsif ($stat == 17 || $stat == 19) {
         $value = (1 / 100000) * unpack "N", substr $data, 0, 4, "";
      } elsif ($stat == 20 || $stat == 21) {
         my $len = unpack "C", substr $data, 0, 1, "";
         $value = substr $data, 0, $len, "";
      } elsif ($stat == 28) {
         my ($lo, $hi) = unpack "NN", substr $data, 0, 8, "";
         $value = $hi * 2**32 + $lo;
      } elsif ($stat >= 118 && $stat <= 129) {
         my ($level, $lo, $hi) = unpack "CNN", substr $data, 0, 9, "";
         $value = [$level, $hi * 2**32 + $lo];
      } else {
         $value = unpack "n", substr $data, 0, 2, "";
      }

      $self->{stat}{$stat} = $value;
   }

   $self->stats_update ($self->{stat});
}

sub feed_face1 {
   my ($self, $data) = @_;

   my ($num, $chksum, $name) = unpack "nNa*", $data;

   my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };

   if (my $data = $self->face_find ($face)) {
      $face->{image} = $data;
      $self->face_update ($face);
   } else {
      $self->send ("askface $num");
   }
}

=item $conn->anim_update ($num) [OVERWRITE]

=cut

sub anim_update { }

sub feed_anim {
   my ($self, $data) = @_;

   my ($num, @faces) = unpack "n*", $data;

   $self->{anim}[$num] = \@faces;

   $self->anim_update ($num);
}

sub feed_drawinfo {
   my ($self, $data) = @_;
#   warn "<$data>\n";
}

sub feed_delinv {
   my ($self, $data) = @_;
}

sub feed_item2 {
   my ($self, $data) = @_;
}

sub feed_map1a {
   my ($self, $data) = @_;

   my $map = $self->{map} ||= [];

   my @dirty;
   my ($coord, $x, $y, $darkness, $fa, $fb, $fc, $cell);

   while (length $data) {
      $coord = unpack "n", substr $data, 0, 2, "";

      $x = (($coord >> 10) & 63) + $self->{mapx};
      $y = (($coord >>  4) & 63) + $self->{mapy};

      $cell = $map->[$x][$y] ||= [];

      if ($coord & 15) {
         $cell->[0] = $coord & 8
                    ? unpack "C", substr $data, 0, 1, ""
                    : 255;

         $cell->[1] = unpack "n", substr $data, 0, 2, ""
            if $coord & 4;
         $cell->[2] = unpack "n", substr $data, 0, 2, ""
            if $coord & 2;
         $cell->[3] = unpack "n", substr $data, 0, 2, ""
            if $coord & 1;
      } else {
         $cell->[0] = -1;
         $cell->[2] = undef;
         $cell->[3] = undef;
      }

      push @dirty, [$x, $y];
   }

   $self->map_update (\@dirty);
}

sub feed_map_scroll {
   my ($self, $data) = @_;

   my ($dx, $dy) = split / /, $data;

   my $map = $self->{map} ||= [];

   $self->{mapx} += $dx;
   $self->{mapy} += $dy;

   if ($self->{mapy} < 0) {
      unshift @$_, ([]) x -$self->{mapy} for @$map;
      $self->{mapy} = 0;
   }

   if ($self->{mapx} < 0) {
      unshift @$map, ([]) x -$self->{mapx};
      $self->{mapx} = 0;
   }

   $self->map_scroll ($dx, $dy);
}

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

   $self->{map}  = [];
   $self->{mapx} = 0;
   $self->{mapy} = 0;

   $self->map_clear;
}

sub feed_image {
   my ($self, $data) = @_;

   my ($num, $len, $data) = unpack "NNa*", $data;

   $self->{face}[$num]{image} = $data;
   $self->face_update ($self->{face}[$num]);

   my @dirty;

   for my $x (0..$self->{mapw} - 1) {
      for my $y (0..$self->{maph} - 1) {
         push @dirty, [$x, $y]
            if grep $_ == $num, @{$self->{map}[$x][$y] || []};
      }
   }

   $self->map_update (\@dirty);
}

=item $conn->map_clear [OVERWRITE]

Called whenever the map is to be erased completely.

=cut

sub map_clear  { }

=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]

Called with a list of x|y coordinate pairs (as arrayrefs) for cells that
have been updated and need refreshing.

=cut

sub map_update { }

=item $conn->map_scroll ($dx, $dy) [OVERWRITE]

Called whenever the map has been scrolled.

=cut

sub map_scroll { }

=item $conn->face_update ($face) [OVERWRITE]

Called with the face number of face structure whenever a face image has
changed.

=cut

sub face_update { }

=item $conn->face_find ($face) [OVERWRITE]

Find and return the png image for the given face, or the empty list if no
face could be found, in which case it will be requested from the server.

=cut

sub face_find { }

=item $conn->send ($data)

Send a single packet/line to the server.

=cut

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

   $data = pack "na*", length $data, $data;

   syswrite $self->{fh}, $data;
}

=back

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

 Robin Redeker <elmex@ta-sa.org>
 http://www.ta-sa.org/

=cut

1
Revision:	1.10
Committed:	Sat Apr 8 18:15:53 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.9:	+38 -27 lines
Log Message:	* empty log message *
#	Content
1	=head1 NAME
2
3	Crossfire::Protocol - client protocol module
4
5	=head1 SYNOPSIS
6
7	use base Crossfire::Protocol; # you have to subclass
8
9	=head1 DESCRIPTION
10
11	Base class to implement a corssfire client.
12
13	=over 4
14
15	=cut
16
17	package Crossfire::Protocol;
18
19	our $VERSION = '0.1';
20
21	use strict;
22
23	use AnyEvent;
24	use IO::Socket::INET;
25
26	=item new Crossfire::Protocol host => ..., port => ...
27
28	=cut
29
30	sub new {
31	my $class = shift;
32	my $self = bless {
33	mapw => 13,
34	maph => 13,
35	@_
36	}, $class;
37
38	$self->{fh} = new IO::Socket::INET PeerHost => $self->{host}, PeerPort => $self->{port}
39	or die "$self->{host}:$self->{port}: $!";
40	$self->{fh}->blocking (0); # stupid nonblock default
41
42	my $buf;
43
44	$self->{w} = AnyEvent->io (fh => $self->{fh}, poll => 'r', cb => sub {
45	if (sysread $self->{fh}, $buf, 16384, length $buf) {
46	for (;;) {
47	last unless 2 <= length $buf;
48	my $len = unpack "n", $buf;
49	last unless $len + 2 <= length $buf;
50
51	substr $buf, 0, 2, "";
52	$self->feed (substr $buf, 0, $len, "");
53	}
54	} else {
55	delete $self->{w};
56	close $self->{fh};
57	}
58	});
59
60	$self->send ("version 1023 1027 perlclient");
61	$self->send ("setup sound 1 exp 1 map1acmd 1 itemcmd 2 darkness 1 mapsize $self->{mapw}x$self->{maph} "
62	. "newmapcmd 1 facecache 1 extendedMapInfos 1 extendedTextInfos 1");
63	$self->send ("addme");
64
65	$self
66	}
67
68	sub feed {
69	my ($self, $data) = @_;
70
71	$data =~ s/^(\S+)\s//
72	or return;
73
74	my $command = "feed_$1";
75
76	$self->$command ($data);
77	}
78
79	sub feed_version {
80	my ($self, $version) = @_;
81	}
82
83	sub feed_setup {
84	my ($self, $data) = @_;
85
86	$data =~ s/^ +//;
87
88	$self->{setup} = { split / +/, $data };
89
90	my ($mapw, $maph) = split /x/, $self->{setup}{mapsize};
91
92	if ($mapw != $self->{mapw} \|\| $maph != $self->{maph}) {
93	($self->{mapw}, $self->{maph}) = ($mapw, $maph);
94	$self->send ("setup mapsize ${mapw}x${maph}");
95	}
96
97	$self->feed_newmap;
98	}
99
100	=item $conn->query ($flags, $prompt) [OVERWRITE]
101
102	=cut
103
104	sub query { die "query is abstract" }
105
106	sub feed_query {
107	my ($self, $data) = @_;
108
109	my ($flags, $prompt) = split /\s+/, $data, 2;
110
111	if ($flags == 0 && $prompt =~ /^What is your name\?\s+:$/ && length $self->{user}) {
112	$self->send ("reply $self->{user}");
113	} elsif ($flags == 4 && $prompt =~ /^What is your password\?\s+:$/ && length $self->{pass}) {
114	$self->send ("reply $self->{pass}");
115	} elsif ($flags == 4 && $prompt =~ /^Please type your password again\.\s+:$/ && length $self->{pass}) {
116	$self->send ("reply $self->{pass}");
117	} else {
118	$self->query ($flags, $prompt);
119	}
120	}
121
122	=item $conn->player_update ($player) [OVERWRITE]
123
124	tag, weight, face, name
125
126	=cut
127
128	sub player_update { }
129
130	sub feed_player {
131	my ($self, $data) = @_;
132
133	my ($tag, $weight, $face, $name) = unpack "NNN C/a", $data;
134
135	$self->player_update ($self->{player} = {
136	tag => $tag,
137	weight => $weight,
138	face => $face,
139	name => $name,
140	});
141
142	$self->feed_newmap;#d# why???
143	}
144
145	=item $conn->stats_update ($stats) [OVERWRITE]
146
147	=cut
148
149	sub stats_update { }
150
151	sub feed_stats {
152	my ($self, $data) = @_;
153
154	while (length $data) {
155	my $stat = unpack "C", substr $data, 0, 1, "";
156	my $value;
157
158	if ($stat == 26 \|\| $stat == 29 \|\| $stat == 30 \|\| $stat == 31 \|\| $stat == 11) {
159	$value = unpack "N", substr $data, 0, 4, "";
160	} elsif ($stat == 17 \|\| $stat == 19) {
161	$value = (1 / 100000) * unpack "N", substr $data, 0, 4, "";
162	} elsif ($stat == 20 \|\| $stat == 21) {
163	my $len = unpack "C", substr $data, 0, 1, "";
164	$value = substr $data, 0, $len, "";
165	} elsif ($stat == 28) {
166	my ($lo, $hi) = unpack "NN", substr $data, 0, 8, "";
167	$value = $hi * 2**32 + $lo;
168	} elsif ($stat >= 118 && $stat <= 129) {
169	my ($level, $lo, $hi) = unpack "CNN", substr $data, 0, 9, "";
170	$value = [$level, $hi * 2**32 + $lo];
171	} else {
172	$value = unpack "n", substr $data, 0, 2, "";
173	}
174
175	$self->{stat}{$stat} = $value;
176	}
177
178	$self->stats_update ($self->{stat});
179	}
180
181	sub feed_face1 {
182	my ($self, $data) = @_;
183
184	my ($num, $chksum, $name) = unpack "nNa*", $data;
185
186	my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };
187
188	if (my $data = $self->face_find ($face)) {
189	$face->{image} = $data;
190	$self->face_update ($face);
191	} else {
192	$self->send ("askface $num");
193	}
194	}
195
196	=item $conn->anim_update ($num) [OVERWRITE]
197
198	=cut
199
200	sub anim_update { }
201
202	sub feed_anim {
203	my ($self, $data) = @_;
204
205	my ($num, @faces) = unpack "n*", $data;
206
207	$self->{anim}[$num] = \@faces;
208
209	$self->anim_update ($num);
210	}
211
212	sub feed_drawinfo {
213	my ($self, $data) = @_;
214	# warn "<$data>\n";
215	}
216
217	sub feed_delinv {
218	my ($self, $data) = @_;
219	}
220
221	sub feed_item2 {
222	my ($self, $data) = @_;
223	}
224
225	sub feed_map1a {
226	my ($self, $data) = @_;
227
228	my $map = $self->{map} \|\|= [];
229
230	my @dirty;
231	my ($coord, $x, $y, $darkness, $fa, $fb, $fc, $cell);
232
233	while (length $data) {
234	$coord = unpack "n", substr $data, 0, 2, "";
235
236	$x = (($coord >> 10) & 63) + $self->{mapx};
237	$y = (($coord >> 4) & 63) + $self->{mapy};
238
239	$cell = $map->[$x][$y] \|\|= [];
240
241	if ($coord & 15) {
242	$cell->[0] = $coord & 8
243	? unpack "C", substr $data, 0, 1, ""
244	: 255;
245
246	$cell->[1] = unpack "n", substr $data, 0, 2, ""
247	if $coord & 4;
248	$cell->[2] = unpack "n", substr $data, 0, 2, ""
249	if $coord & 2;
250	$cell->[3] = unpack "n", substr $data, 0, 2, ""
251	if $coord & 1;
252	} else {
253	$cell->[0] = -1;
254	$cell->[2] = undef;
255	$cell->[3] = undef;
256	}
257
258	push @dirty, [$x, $y];
259	}
260
261	$self->map_update (\@dirty);
262	}
263
264	sub feed_map_scroll {
265	my ($self, $data) = @_;
266
267	my ($dx, $dy) = split / /, $data;
268
269	my $map = $self->{map} \|\|= [];
270
271	$self->{mapx} += $dx;
272	$self->{mapy} += $dy;
273
274	if ($self->{mapy} < 0) {
275	unshift @$_, ([]) x -$self->{mapy} for @$map;
276	$self->{mapy} = 0;
277	}
278
279	if ($self->{mapx} < 0) {
280	unshift @$map, ([]) x -$self->{mapx};
281	$self->{mapx} = 0;
282	}
283
284	$self->map_scroll ($dx, $dy);
285	}
286
287	sub feed_newmap {
288	my ($self) = @_;
289
290	$self->{map} = [];
291	$self->{mapx} = 0;
292	$self->{mapy} = 0;
293
294	$self->map_clear;
295	}
296
297	sub feed_image {
298	my ($self, $data) = @_;
299
300	my ($num, $len, $data) = unpack "NNa*", $data;
301
302	$self->{face}[$num]{image} = $data;
303	$self->face_update ($self->{face}[$num]);
304
305	my @dirty;
306
307	for my $x (0..$self->{mapw} - 1) {
308	for my $y (0..$self->{maph} - 1) {
309	push @dirty, [$x, $y]
310	if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
311	}
312	}
313
314	$self->map_update (\@dirty);
315	}
316
317	=item $conn->map_clear [OVERWRITE]
318
319	Called whenever the map is to be erased completely.
320
321	=cut
322
323	sub map_clear { }
324
325	=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
326
327	Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
328	have been updated and need refreshing.
329
330	=cut
331
332	sub map_update { }
333
334	=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
335
336	Called whenever the map has been scrolled.
337
338	=cut
339
340	sub map_scroll { }
341
342	=item $conn->face_update ($face) [OVERWRITE]
343
344	Called with the face number of face structure whenever a face image has
345	changed.
346
347	=cut
348
349	sub face_update { }
350
351	=item $conn->face_find ($face) [OVERWRITE]
352
353	Find and return the png image for the given face, or the empty list if no
354	face could be found, in which case it will be requested from the server.
355
356	=cut
357
358	sub face_find { }
359
360	=item $conn->send ($data)
361
362	Send a single packet/line to the server.
363
364	=cut
365
366	sub send {
367	my ($self, $data) = @_;
368
369	$data = pack "na*", length $data, $data;
370
371	syswrite $self->{fh}, $data;
372	}
373
374	=back
375
376	=head1 AUTHOR
377
378	Marc Lehmann <schmorp@schmorp.de>
379	http://home.schmorp.de/
380
381	Robin Redeker <elmex@ta-sa.org>
382	http://www.ta-sa.org/
383
384	=cut
385
386	1