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, 2 months ago) by root
Branch:	MAIN
Changes since 1.8:	+0 -2 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			=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	root	1.8	for (;;) {
43			last unless 2 <= length $buf;
44	root	1.1	my $len = unpack "n", $buf;
45	root	1.8	last unless $len + 2 <= length $buf;
46
47			substr $buf, 0, 2, "";
48			$self->feed (substr $buf, 0, $len, "");
49	root	1.1	}
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	root	1.6	=item $conn->query ($flags, $prompt) [OVERWRITE]
91
92			=cut
93
94			sub query { die "query is abstract" }
95
96	root	1.1	sub feed_query {
97			my ($self, $data) = @_;
98	root	1.6
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	root	1.1	}
111
112	root	1.6	=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	root	1.1	sub feed_stats {
142			my ($self, $data) = @_;
143	root	1.6
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	root	1.1	}
170
171			sub feed_face1 {
172			my ($self, $data) = @_;
173
174			my ($num, $chksum, $name) = unpack "nNa*", $data;
175
176	root	1.5	my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };
177	root	1.3
178	root	1.5	if (my $data = $self->face_find ($face)) {
179			$face->{image} = $data;
180			$self->face_update ($face);
181	root	1.3	} else {
182			$self->send ("askface $num");
183			}
184	root	1.1	}
185
186	root	1.6	=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	root	1.1	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	root	1.4	$cell->[3] = $coord & 8
232			? unpack "C", substr $data, 0, 1, ""
233			: 255;
234
235	root	1.1	$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	root	1.7	if ($dy < 0) {
262			unshift @$_, ([]) x -$dy for @$map;
263			} elsif ($dy > 0) {
264			splice @$_, 0, $dy, () for @$map;
265	root	1.1	}
266
267	root	1.7	if ($dx < 0) {
268			unshift @$map, ([]) x -$dx;
269			} elsif ($dx > 0) {
270			splice @$map, 0, $dx, ();
271	root	1.1	}
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	root	1.3	my ($num, $len, $data) = unpack "NNa*", $data;
290	root	1.1
291	root	1.3	$self->{face}[$num]{image} = $data;
292	root	1.5	$self->face_update ($self->{face}[$num]);
293	root	1.1
294	root	1.3	my @dirty;
295	root	1.2
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	root	1.6
303	root	1.2	$self->map_update (\@dirty);
304	root	1.1	}
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	root	1.5	=item $conn->face_update ($face) [OVERWRITE]
332	root	1.1
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	root	1.5	=item $conn->face_find ($face) [OVERWRITE]
341	root	1.3
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	root	1.1	=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