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, 1 month ago) by root
Branch:	MAIN
Changes since 1.12:	+0 -1 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::Protocol host => ..., port => ...
27
28	=cut
29
30	sub new {
31	my $class = shift;
32	my $self = bless {
33	mapw => 13,
34	maph => 13,
35	@_
36	}, $class;
37
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	for (;;) {
47	last unless 2 <= length $buf;
48	my $len = unpack "n", $buf;
49	last unless $len + 2 <= length $buf;
50
51	substr $buf, 0, 2, "";
52	$self->feed (substr $buf, 0, $len, "");
53	}
54	} else {
55	delete $self->{w};
56	close $self->{fh};
57	}
58	});
59
60	$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	$self->send ("version 1023 1027 perlclient");
72	$self->send_setup;
73
74	$self
75	}
76
77	sub feed {
78	my ($self, $data) = @_;
79
80	$data =~ s/^(\S+)(?:\s\|$)//
81	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	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	$self->send_setup;
104	} else {
105	$self->send ("addme");
106	}
107
108	$self->feed_newmap;
109	}
110
111	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	=item $conn->query ($flags, $prompt) [OVERWRITE]
133
134	=cut
135
136	sub query { die "query is abstract" }
137
138	sub feed_query {
139	my ($self, $data) = @_;
140
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	}
153
154	=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	sub feed_stats {
182	my ($self, $data) = @_;
183
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	}
210
211	sub feed_face1 {
212	my ($self, $data) = @_;
213
214	my ($num, $chksum, $name) = unpack "nNa*", $data;
215
216	my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };
217
218	if (my $data = $self->face_find ($face)) {
219	$face->{image} = $data;
220	$self->face_update ($face);
221	} else {
222	$self->send ("askface $num");
223	}
224	}
225
226	=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	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	$x = (($coord >> 10) & 63) + $self->{mapx};
267	$y = (($coord >> 4) & 63) + $self->{mapy};
268
269	$cell = $map->[$x][$y] \|\|= [];
270
271	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
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
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
336	$self->{mapx} += $dx;
337	$self->{mapy} += $dy;
338
339	# shift in new space if moving to "negative indices"
340	if ($self->{mapy} < 0) {
341	unshift @$_, ([]) x -$self->{mapy} for @$map;
342	$self->{mapy} = 0;
343	}
344
345	if ($self->{mapx} < 0) {
346	unshift @$map, ([]) x -$self->{mapx};
347	$self->{mapx} = 0;
348	}
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	my ($num, $len, $data) = unpack "NNa*", $data;
367
368	$self->{face}[$num]{image} = $data;
369	$self->face_update ($self->{face}[$num]);
370
371	my @dirty;
372
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
380	$self->map_update (\@dirty);
381	}
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	=item $conn->face_update ($face) [OVERWRITE]
409
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	=item $conn->face_find ($face) [OVERWRITE]
418
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	=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	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	=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