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, 2 months ago) by root
Branch:	MAIN
Changes since 1.6:	+10 -8 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			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	root	1.6	=item $conn->query ($flags, $prompt) [OVERWRITE]
90
91			=cut
92
93			sub query { die "query is abstract" }
94
95	root	1.1	sub feed_query {
96			my ($self, $data) = @_;
97	root	1.6
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	root	1.1	}
110
111	root	1.6	=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	root	1.1	sub feed_stats {
141			my ($self, $data) = @_;
142	root	1.6
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	root	1.1	}
169
170			sub feed_face1 {
171			my ($self, $data) = @_;
172
173			my ($num, $chksum, $name) = unpack "nNa*", $data;
174
175	root	1.5	my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };
176	root	1.3
177	root	1.5	if (my $data = $self->face_find ($face)) {
178			$face->{image} = $data;
179			$self->face_update ($face);
180	root	1.3	} else {
181			$self->send ("askface $num");
182			}
183	root	1.1	}
184
185	root	1.6	=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	root	1.1	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	root	1.4	$cell->[3] = $coord & 8
231			? unpack "C", substr $data, 0, 1, ""
232			: 255;
233
234	root	1.1	$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	root	1.7	if ($dy < 0) {
261			unshift @$_, ([]) x -$dy for @$map;
262			} elsif ($dy > 0) {
263			splice @$_, 0, $dy, () for @$map;
264	root	1.1	}
265
266	root	1.7	if ($dx < 0) {
267			unshift @$map, ([]) x -$dx;
268			} elsif ($dx > 0) {
269			splice @$map, 0, $dx, ();
270	root	1.1	}
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	root	1.3	my ($num, $len, $data) = unpack "NNa*", $data;
289	root	1.1
290	root	1.3	$self->{face}[$num]{image} = $data;
291	root	1.5	$self->face_update ($self->{face}[$num]);
292	root	1.1
293	root	1.3	my @dirty;
294	root	1.2
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	root	1.6
302	root	1.2	$self->map_update (\@dirty);
303	root	1.1	}
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	root	1.5	=item $conn->face_update ($face) [OVERWRITE]
331	root	1.1
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	root	1.5	=item $conn->face_find ($face) [OVERWRITE]
340	root	1.3
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	root	1.1	=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	root	1.7	print "SEND<$data>\n";#d#
358
359	root	1.1	$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