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

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