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) = @$_;
         warn "xxx $x0 $y0 $w $h\n";#d#
         for my $x ($x0 .. $x0 + $w) {
            for my $y ($y0 .. $y0 + $h) {

               warn "cell $x $y\n";#d#
               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.11
Committed:	Sat Apr 8 20:25:32 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.10:	+84 -7 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	warn "xxx $x0 $y0 $w $h\n";#d#
323	for my $x ($x0 .. $x0 + $w) {
324	for my $y ($y0 .. $y0 + $h) {
325
326	warn "cell $x $y\n";#d#
327	my $cell = $map->[$x][$y]
328	or next;
329
330	$cell->[0] = -1; $cell->[2] = 0; $cell->[3] = 0;
331	}
332	}
333	}
334	}
335
336	# now scroll
337
338	$self->{mapx} += $dx;
339	$self->{mapy} += $dy;
340
341	# shift in new space if moving to "negative indices"
342	if ($self->{mapy} < 0) {
343	unshift @$_, ([]) x -$self->{mapy} for @$map;
344	$self->{mapy} = 0;
345	}
346
347	if ($self->{mapx} < 0) {
348	unshift @$map, ([]) x -$self->{mapx};
349	$self->{mapx} = 0;
350	}
351
352	$self->map_scroll ($dx, $dy);
353	}
354
355	sub feed_newmap {
356	my ($self) = @_;
357
358	$self->{map} = [];
359	$self->{mapx} = 0;
360	$self->{mapy} = 0;
361
362	$self->map_clear;
363	}
364
365	sub feed_image {
366	my ($self, $data) = @_;
367
368	my ($num, $len, $data) = unpack "NNa*", $data;
369
370	$self->{face}[$num]{image} = $data;
371	$self->face_update ($self->{face}[$num]);
372
373	my @dirty;
374
375	for my $x (0..$self->{mapw} - 1) {
376	for my $y (0..$self->{maph} - 1) {
377	push @dirty, [$x, $y]
378	if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
379	}
380	}
381
382	$self->map_update (\@dirty);
383	}
384
385	=item $conn->map_clear [OVERWRITE]
386
387	Called whenever the map is to be erased completely.
388
389	=cut
390
391	sub map_clear { }
392
393	=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
394
395	Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
396	have been updated and need refreshing.
397
398	=cut
399
400	sub map_update { }
401
402	=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
403
404	Called whenever the map has been scrolled.
405
406	=cut
407
408	sub map_scroll { }
409
410	=item $conn->face_update ($face) [OVERWRITE]
411
412	Called with the face number of face structure whenever a face image has
413	changed.
414
415	=cut
416
417	sub face_update { }
418
419	=item $conn->face_find ($face) [OVERWRITE]
420
421	Find and return the png image for the given face, or the empty list if no
422	face could be found, in which case it will be requested from the server.
423
424	=cut
425
426	sub face_find { }
427
428	=item $conn->send ($data)
429
430	Send a single packet/line to the server.
431
432	=cut
433
434	sub send {
435	my ($self, $data) = @_;
436
437	$data = pack "na*", length $data, $data;
438
439	syswrite $self->{fh}, $data;
440	}
441
442	sub send_setup {
443	my ($self) = @_;
444
445	my $setup = join " ", setup => %{$self->{setup_req}},
446	mapsize => "$self->{mapw}x$self->{maph}";
447	warn "SET<$setup>\n";#d#
448	$self->send ($setup);
449	}
450
451	=back
452
453	=head1 AUTHOR
454
455	Marc Lehmann <schmorp@schmorp.de>
456	http://home.schmorp.de/
457
458	Robin Redeker <elmex@ta-sa.org>
459	http://www.ta-sa.org/
460
461	=cut
462
463	1