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 *
#	User	Rev	Content
1	root	1.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	root	1.10	=item new Crossfire::Protocol host => ..., port => ...
27	root	1.1
28			=cut
29
30			sub new {
31			my $class = shift;
32	root	1.10	my $self = bless {
33			mapw => 13,
34			maph => 13,
35			@_
36			}, $class;
37	root	1.1
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	root	1.8	for (;;) {
47			last unless 2 <= length $buf;
48	root	1.1	my $len = unpack "n", $buf;
49	root	1.8	last unless $len + 2 <= length $buf;
50
51			substr $buf, 0, 2, "";
52			$self->feed (substr $buf, 0, $len, "");
53	root	1.1	}
54			} else {
55			delete $self->{w};
56			close $self->{fh};
57			}
58			});
59
60			$self->send ("version 1023 1027 perlclient");
61	root	1.10	$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	root	1.1	$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	root	1.10	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	root	1.1
97			$self->feed_newmap;
98			}
99
100	root	1.6	=item $conn->query ($flags, $prompt) [OVERWRITE]
101
102			=cut
103
104			sub query { die "query is abstract" }
105
106	root	1.1	sub feed_query {
107			my ($self, $data) = @_;
108	root	1.6
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	root	1.1	}
121
122	root	1.6	=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	root	1.1	sub feed_stats {
152			my ($self, $data) = @_;
153	root	1.6
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	root	1.1	}
180
181			sub feed_face1 {
182			my ($self, $data) = @_;
183
184			my ($num, $chksum, $name) = unpack "nNa*", $data;
185
186	root	1.5	my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };
187	root	1.3
188	root	1.5	if (my $data = $self->face_find ($face)) {
189			$face->{image} = $data;
190			$self->face_update ($face);
191	root	1.3	} else {
192			$self->send ("askface $num");
193			}
194	root	1.1	}
195
196	root	1.6	=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	root	1.1	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	root	1.10	$x = (($coord >> 10) & 63) + $self->{mapx};
237			$y = (($coord >> 4) & 63) + $self->{mapy};
238	root	1.1
239			$cell = $map->[$x][$y] \|\|= [];
240
241	root	1.10	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	root	1.1
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	root	1.10	if ($self->{mapy} < 0) {
275			unshift @$_, ([]) x -$self->{mapy} for @$map;
276			$self->{mapy} = 0;
277	root	1.1	}
278
279	root	1.10	if ($self->{mapx} < 0) {
280			unshift @$map, ([]) x -$self->{mapx};
281			$self->{mapx} = 0;
282	root	1.1	}
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	root	1.3	my ($num, $len, $data) = unpack "NNa*", $data;
301	root	1.1
302	root	1.3	$self->{face}[$num]{image} = $data;
303	root	1.5	$self->face_update ($self->{face}[$num]);
304	root	1.1
305	root	1.3	my @dirty;
306	root	1.2
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	root	1.6
314	root	1.2	$self->map_update (\@dirty);
315	root	1.1	}
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	root	1.5	=item $conn->face_update ($face) [OVERWRITE]
343	root	1.1
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	root	1.5	=item $conn->face_find ($face) [OVERWRITE]
352	root	1.3
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	root	1.1	=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