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::Rptocol host => ..., port => ...

=cut

sub new {
   my $class = shift;
   my $self = bless { @_ }, $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) {
         if (2 <= length $buf) {
            my $len = unpack "n", $buf;
            if ($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 63x63 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 };

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

   $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;
      $y = ($coord >>  4) & 63;

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

      $cell->[3] = $coord & 8
                 ? unpack "C", substr $data, 0, 1, ""
                 : 255;

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

      @$cell = ()
         unless $coord & 15;

      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 ($dy < 0) {
      unshift @$_, ([]) x -$dy for @$map;
   } elsif ($dy > 0) {
      splice @$_, 0, $dy, () for @$map;
   }

   if ($dx < 0) {
      unshift @$map, ([]) x -$dx;
   } elsif ($dx > 0) {
      splice @$map, 0, $dx, ();
   }

   $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) = @_;

   print "SEND<$data>\n";#d#

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