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->{setup_req} = {
      sound             => 1,
      exp64             => 1,
      map1acmd          => 1,
      itemcmd           => 2,
      darkness          => 1,
      facecache         => 1,
      newmapcmd         => 1,
      extendedTextInfos => 1,
   };

   $self->send ("version 1023 1027 perlclient");
   $self->send_setup;

   $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;
   } else {
      $self->send ("addme");
   }

   $self->feed_newmap;
}

sub feed_addme_success {
   my ($self, $data) = @_;
}

sub feed_addme_failure {
   my ($self, $data) = @_;
   # maybe should notify user
}

=item $conn->play_sound ($x, $y, $soundnum, $type) [OVERWRITE]

=cut

sub sound_play { }

sub feed_sound {
   my ($self, $data) = @_;

   $self->sound_play (unpack "CCnC", $data);
}

=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,
   });
}

=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} ||= [];
   
   my ($mx, $my, $mw, $mh) = @$self{qw(mapx mapy mapw maph)};

   # TODO: optimise this a lot, or maybe just do it on c-level
   # set flag to -1 for spaces we scroll out
   {
      my @darkness;

      if ($dx > 0) {
         push @darkness, [$mx, $my, $dx - 1, $mh];
      } elsif ($dx < 0) {
         push @darkness, [$mx + $mw + $dx + 1, $my, 1 - $dx, $mh];
      }

      if ($dy > 0) {
         push @darkness, [$mx, $my, $mw, $dy - 1];
      } elsif ($dy < 0) {
         push @darkness, [$mx, $my + $mh + $dy + 1, $mw, 1 - $dy];
      }

      for (@darkness) {
         my ($x0, $y0, $w, $h) = @$_;
         for my $x ($x0 .. $x0 + $w) {
            for my $y ($y0 .. $y0 + $h) {

               my $cell = $map->[$x][$y]
                  or next;

               $cell->[0] = -1; $cell->[2] = 0; $cell->[3] = 0;
            }
         }
      }
   }

   # now scroll

   $self->{mapx} += $dx;
   $self->{mapy} += $dy;

   # shift in new space if moving to "negative indices"
   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;
}

sub send_setup {
   my ($self) = @_;

   my $setup = join " ", setup => %{$self->{setup_req}},
                  mapsize => "$self->{mapw}x$self->{maph}";
   warn "SET<$setup>\n";#d#
   $self->send ($setup);
}

=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.13
Committed:	Sat Apr 8 22:08:26 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.12:	+0 -1 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	root	1.11	$self->{setup_req} = {
61			sound => 1,
62			exp64 => 1,
63			map1acmd => 1,
64			itemcmd => 2,
65			darkness => 1,
66			facecache => 1,
67			newmapcmd => 1,
68			extendedTextInfos => 1,
69			};
70
71	root	1.1	$self->send ("version 1023 1027 perlclient");
72	root	1.11	$self->send_setup;
73	root	1.1
74			$self
75			}
76
77			sub feed {
78			my ($self, $data) = @_;
79
80	root	1.11	$data =~ s/^(\S+)(?:\s\|$)//
81	root	1.1	or return;
82
83			my $command = "feed_$1";
84
85			$self->$command ($data);
86			}
87
88			sub feed_version {
89			my ($self, $version) = @_;
90			}
91
92			sub feed_setup {
93			my ($self, $data) = @_;
94
95			$data =~ s/^ +//;
96
97			$self->{setup} = { split / +/, $data };
98
99	root	1.10	my ($mapw, $maph) = split /x/, $self->{setup}{mapsize};
100
101			if ($mapw != $self->{mapw} \|\| $maph != $self->{maph}) {
102			($self->{mapw}, $self->{maph}) = ($mapw, $maph);
103	root	1.11	$self->send_setup;
104			} else {
105			$self->send ("addme");
106	root	1.10	}
107	root	1.1
108			$self->feed_newmap;
109			}
110
111	root	1.11	sub feed_addme_success {
112			my ($self, $data) = @_;
113			}
114
115			sub feed_addme_failure {
116			my ($self, $data) = @_;
117			# maybe should notify user
118			}
119
120			=item $conn->play_sound ($x, $y, $soundnum, $type) [OVERWRITE]
121
122			=cut
123
124			sub sound_play { }
125
126			sub feed_sound {
127			my ($self, $data) = @_;
128
129			$self->sound_play (unpack "CCnC", $data);
130			}
131
132	root	1.6	=item $conn->query ($flags, $prompt) [OVERWRITE]
133
134			=cut
135
136			sub query { die "query is abstract" }
137
138	root	1.1	sub feed_query {
139			my ($self, $data) = @_;
140	root	1.6
141			my ($flags, $prompt) = split /\s+/, $data, 2;
142
143			if ($flags == 0 && $prompt =~ /^What is your name\?\s+:$/ && length $self->{user}) {
144			$self->send ("reply $self->{user}");
145			} elsif ($flags == 4 && $prompt =~ /^What is your password\?\s+:$/ && length $self->{pass}) {
146			$self->send ("reply $self->{pass}");
147			} elsif ($flags == 4 && $prompt =~ /^Please type your password again\.\s+:$/ && length $self->{pass}) {
148			$self->send ("reply $self->{pass}");
149			} else {
150			$self->query ($flags, $prompt);
151			}
152	root	1.1	}
153
154	root	1.6	=item $conn->player_update ($player) [OVERWRITE]
155
156			tag, weight, face, name
157
158			=cut
159
160			sub player_update { }
161
162			sub feed_player {
163			my ($self, $data) = @_;
164
165			my ($tag, $weight, $face, $name) = unpack "NNN C/a", $data;
166
167			$self->player_update ($self->{player} = {
168			tag => $tag,
169			weight => $weight,
170			face => $face,
171			name => $name,
172			});
173			}
174
175			=item $conn->stats_update ($stats) [OVERWRITE]
176
177			=cut
178
179			sub stats_update { }
180
181	root	1.1	sub feed_stats {
182			my ($self, $data) = @_;
183	root	1.6
184			while (length $data) {
185			my $stat = unpack "C", substr $data, 0, 1, "";
186			my $value;
187
188			if ($stat == 26 \|\| $stat == 29 \|\| $stat == 30 \|\| $stat == 31 \|\| $stat == 11) {
189			$value = unpack "N", substr $data, 0, 4, "";
190			} elsif ($stat == 17 \|\| $stat == 19) {
191			$value = (1 / 100000) * unpack "N", substr $data, 0, 4, "";
192			} elsif ($stat == 20 \|\| $stat == 21) {
193			my $len = unpack "C", substr $data, 0, 1, "";
194			$value = substr $data, 0, $len, "";
195			} elsif ($stat == 28) {
196			my ($lo, $hi) = unpack "NN", substr $data, 0, 8, "";
197			$value = $hi * 2**32 + $lo;
198			} elsif ($stat >= 118 && $stat <= 129) {
199			my ($level, $lo, $hi) = unpack "CNN", substr $data, 0, 9, "";
200			$value = [$level, $hi * 2**32 + $lo];
201			} else {
202			$value = unpack "n", substr $data, 0, 2, "";
203			}
204
205			$self->{stat}{$stat} = $value;
206			}
207
208			$self->stats_update ($self->{stat});
209	root	1.1	}
210
211			sub feed_face1 {
212			my ($self, $data) = @_;
213
214			my ($num, $chksum, $name) = unpack "nNa*", $data;
215
216	root	1.5	my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };
217	root	1.3
218	root	1.5	if (my $data = $self->face_find ($face)) {
219			$face->{image} = $data;
220			$self->face_update ($face);
221	root	1.3	} else {
222			$self->send ("askface $num");
223			}
224	root	1.1	}
225
226	root	1.6	=item $conn->anim_update ($num) [OVERWRITE]
227
228			=cut
229
230			sub anim_update { }
231
232			sub feed_anim {
233			my ($self, $data) = @_;
234
235			my ($num, @faces) = unpack "n*", $data;
236
237			$self->{anim}[$num] = \@faces;
238
239			$self->anim_update ($num);
240			}
241
242	root	1.1	sub feed_drawinfo {
243			my ($self, $data) = @_;
244			# warn "<$data>\n";
245			}
246
247			sub feed_delinv {
248			my ($self, $data) = @_;
249			}
250
251			sub feed_item2 {
252			my ($self, $data) = @_;
253			}
254
255			sub feed_map1a {
256			my ($self, $data) = @_;
257
258			my $map = $self->{map} \|\|= [];
259
260			my @dirty;
261			my ($coord, $x, $y, $darkness, $fa, $fb, $fc, $cell);
262
263			while (length $data) {
264			$coord = unpack "n", substr $data, 0, 2, "";
265
266	root	1.10	$x = (($coord >> 10) & 63) + $self->{mapx};
267			$y = (($coord >> 4) & 63) + $self->{mapy};
268	root	1.1
269			$cell = $map->[$x][$y] \|\|= [];
270
271	root	1.10	if ($coord & 15) {
272			$cell->[0] = $coord & 8
273			? unpack "C", substr $data, 0, 1, ""
274			: 255;
275
276			$cell->[1] = unpack "n", substr $data, 0, 2, ""
277			if $coord & 4;
278			$cell->[2] = unpack "n", substr $data, 0, 2, ""
279			if $coord & 2;
280			$cell->[3] = unpack "n", substr $data, 0, 2, ""
281			if $coord & 1;
282			} else {
283			$cell->[0] = -1;
284			$cell->[2] = undef;
285			$cell->[3] = undef;
286			}
287	root	1.1
288			push @dirty, [$x, $y];
289			}
290
291			$self->map_update (\@dirty);
292			}
293
294			sub feed_map_scroll {
295			my ($self, $data) = @_;
296
297			my ($dx, $dy) = split / /, $data;
298
299			my $map = $self->{map} \|\|= [];
300	root	1.11
301			my ($mx, $my, $mw, $mh) = @$self{qw(mapx mapy mapw maph)};
302
303			# TODO: optimise this a lot, or maybe just do it on c-level
304			# set flag to -1 for spaces we scroll out
305			{
306			my @darkness;
307
308			if ($dx > 0) {
309			push @darkness, [$mx, $my, $dx - 1, $mh];
310			} elsif ($dx < 0) {
311			push @darkness, [$mx + $mw + $dx + 1, $my, 1 - $dx, $mh];
312			}
313
314			if ($dy > 0) {
315			push @darkness, [$mx, $my, $mw, $dy - 1];
316			} elsif ($dy < 0) {
317			push @darkness, [$mx, $my + $mh + $dy + 1, $mw, 1 - $dy];
318			}
319
320			for (@darkness) {
321			my ($x0, $y0, $w, $h) = @$_;
322			for my $x ($x0 .. $x0 + $w) {
323			for my $y ($y0 .. $y0 + $h) {
324
325			my $cell = $map->[$x][$y]
326			or next;
327
328			$cell->[0] = -1; $cell->[2] = 0; $cell->[3] = 0;
329			}
330			}
331			}
332			}
333
334			# now scroll
335	root	1.1
336			$self->{mapx} += $dx;
337			$self->{mapy} += $dy;
338
339	root	1.11	# shift in new space if moving to "negative indices"
340	root	1.10	if ($self->{mapy} < 0) {
341			unshift @$_, ([]) x -$self->{mapy} for @$map;
342			$self->{mapy} = 0;
343	root	1.1	}
344
345	root	1.10	if ($self->{mapx} < 0) {
346			unshift @$map, ([]) x -$self->{mapx};
347			$self->{mapx} = 0;
348	root	1.1	}
349
350			$self->map_scroll ($dx, $dy);
351			}
352
353			sub feed_newmap {
354			my ($self) = @_;
355
356			$self->{map} = [];
357			$self->{mapx} = 0;
358			$self->{mapy} = 0;
359
360			$self->map_clear;
361			}
362
363			sub feed_image {
364			my ($self, $data) = @_;
365
366	root	1.3	my ($num, $len, $data) = unpack "NNa*", $data;
367	root	1.1
368	root	1.3	$self->{face}[$num]{image} = $data;
369	root	1.5	$self->face_update ($self->{face}[$num]);
370	root	1.1
371	root	1.3	my @dirty;
372	root	1.2
373			for my $x (0..$self->{mapw} - 1) {
374			for my $y (0..$self->{maph} - 1) {
375			push @dirty, [$x, $y]
376			if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
377			}
378			}
379	root	1.6
380	root	1.2	$self->map_update (\@dirty);
381	root	1.1	}
382
383			=item $conn->map_clear [OVERWRITE]
384
385			Called whenever the map is to be erased completely.
386
387			=cut
388
389			sub map_clear { }
390
391			=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
392
393			Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
394			have been updated and need refreshing.
395
396			=cut
397
398			sub map_update { }
399
400			=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
401
402			Called whenever the map has been scrolled.
403
404			=cut
405
406			sub map_scroll { }
407
408	root	1.5	=item $conn->face_update ($face) [OVERWRITE]
409	root	1.1
410			Called with the face number of face structure whenever a face image has
411			changed.
412
413			=cut
414
415			sub face_update { }
416
417	root	1.5	=item $conn->face_find ($face) [OVERWRITE]
418	root	1.3
419			Find and return the png image for the given face, or the empty list if no
420			face could be found, in which case it will be requested from the server.
421
422			=cut
423
424			sub face_find { }
425
426	root	1.1	=item $conn->send ($data)
427
428			Send a single packet/line to the server.
429
430			=cut
431
432			sub send {
433			my ($self, $data) = @_;
434
435			$data = pack "na*", length $data, $data;
436
437			syswrite $self->{fh}, $data;
438			}
439
440	root	1.11	sub send_setup {
441			my ($self) = @_;
442
443			my $setup = join " ", setup => %{$self->{setup_req}},
444			mapsize => "$self->{mapw}x$self->{maph}";
445			warn "SET<$setup>\n";#d#
446			$self->send ($setup);
447			}
448
449	root	1.1	=back
450
451			=head1 AUTHOR
452
453			Marc Lehmann <schmorp@schmorp.de>
454			http://home.schmorp.de/
455
456			Robin Redeker <elmex@ta-sa.org>
457			http://www.ta-sa.org/
458
459			=cut
460
461			1