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) {

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