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,
      max_outstanding => 2,
      token           => "a0",
      @_
   }, $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,
      mapinfocmd        => 1,
      plugincmd         => 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
}

=back

=head2 METHODS THAT CAN/MUST BE OVERWRITTEN

=over 4

=cut

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 ($num, $face)) {
      $face->{image} = $data;
      $self->face_update ($num, $face);
   } else {
      $self->send_queue ("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);
}

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

=cut

sub sound_play { }

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

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

=item $conn->query ($flags, $prompt)

=cut

sub query { }

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->drawinfo ($color, $text)

=cut

sub drawinfo { }

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

   $self->drawinfo (split / /, $data, 2);
}

=item $conn->player_update ($player)

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)

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

=item $conn->inventory_clear ($id)

=cut

sub inventory_clear { }

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

   $self->inventory_clear ($data);

   delete $self->{inventory}[$data];
}

=item $conn->items_delete ($tag...)

=cut

sub items_delete { }

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

   $self->items_delete (unpack "n*", $data);
}

=item $conn->inventory_add ($id, [\%item...])

=cut

sub inventory_add {
}

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

   my ($location, @values) = unpack "N (NNNN C/a* nC Nn)*", $data;

   my @items;

   while (@values) {
      my ($tag, $flags, $weight, $face, $names, $anim, $animspeed, $nrof, $type) =
         splice @values, 0, 9, ();

      my ($name, $name_pl) = split /\x000/, $names;

      push @items, {
         tag       => $tag,
         flags     => $flags,
         weight    => $weight,
         face      => $face,
         name      => $name,
         name_pl   => $name_pl,
         anim      => $anim,
         animspeed => $animspeed * 0.120, #???
         nrof      => $nrof,
         type      => $type,
      };
   }

   $self->inventory_add ($location, \@items);
}

=item $conn->item_update ($tag)

=cut

sub item_update { }

sub feed_upditem {
   #todo
}

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

   my $map = $self->{map} ||= [];

   my ($dx, $dy) = delete @$self{qw(delayed_scroll_x delayed_scroll_y)};

   if ($dx || $dy) {
      my ($mx, $my, $mw, $mh) = @$self{qw(mapx mapy mapw maph)};

      {
         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;
               }
            }
         }
      }

      # now scroll

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

      # shift in new space if moving to "negative indices"
      if ($self->{mapy} < 0) {
         unshift @$_, (undef) x -$self->{mapy} for @$map;
         $self->{mapy} = 0;
      }

      if ($self->{mapx} < 0) {
         unshift @$map, (undef) x -$self->{mapx};
         $self->{mapx} = 0;
      }

      $self->map_scroll ($dx, $dy);
   }

   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 = () if $cell->[0] < 0;

         $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;
      }

      push @dirty, [$x, $y];
   }

   $self->map_update (\@dirty);
}

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

   my ($dx, $dy) = split / /, $data;

   $self->{delayed_scroll_x} += $dx;
   $self->{delayed_scroll_y} += $dy;

   $self->map_scroll ($dx, $dy);
}

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

   $self->{map}  = [];
   $self->{mapx} = 0;
   $self->{mapy} = 0;

   delete $self->{delayed_scroll_x};
   delete $self->{delayed_scroll_y};

   $self->map_clear;
}

sub feed_mapinfo {
   my ($self, $data) = @_;
   
   my ($token, @data) = split / /, $data;

   (delete $self->{mapinfo_cb}{$token})->(@data)
      if $self->{mapinfo_cb}{$token};

   $self->map_change (@data) if $token eq "-";
}

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

   my $token = ++$self->{token};

   $self->{mapinfo_cb}{$token} = $cb;
   $self->send ("mapinfo $token $data");
}

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

   my ($num, $len, $data) = unpack "NNa*", $data;

   $self->send_queue;
   $self->{face}[$num]{image} = $data;
   $self->face_update ($num, $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_change ($mode, ...) [OVERWRITE]

   current <flags> <x> <y> <width> <height> <hashstring>

=cut

sub map_info { }

=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 ($facenum, $facedata) [OVERWRITE]

Called with the face number of face structure whenever a face image has
changed.

=cut

sub face_update { }

=item $conn->face_find ($facenum, $facedata) [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_queue {
   my ($self, $cmd) = @_;

   if (defined $cmd) {
      push @{ $self->{send_queue} }, $cmd;
   } else {
      --$self->{outstanding};
   }

   if ($self->{outstanding} < $self->{max_outstanding} && @{ $self->{send_queue} }) {
      ++$self->{outstanding};
      $self->send (pop @{ $self->{send_queue} });
   }
}

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

   my $setup = join " ", setup => %{$self->{setup_req}},
                  mapsize => "$self->{mapw}x$self->{maph}";

   $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.24
Committed:	Mon Apr 17 06:50:45 2006 UTC (18 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.23:	+19 -3 lines
Log Message:	implement mapinfo support
#	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	max_outstanding => 2,
36	token => "a0",
37	@_
38	}, $class;
39
40	$self->{fh} = new IO::Socket::INET PeerHost => $self->{host}, PeerPort => $self->{port}
41	or die "$self->{host}:$self->{port}: $!";
42	$self->{fh}->blocking (0); # stupid nonblock default
43
44	my $buf;
45
46	$self->{w} = AnyEvent->io (fh => $self->{fh}, poll => 'r', cb => sub {
47	if (sysread $self->{fh}, $buf, 16384, length $buf) {
48	for (;;) {
49	last unless 2 <= length $buf;
50	my $len = unpack "n", $buf;
51	last unless $len + 2 <= length $buf;
52
53	substr $buf, 0, 2, "";
54	$self->feed (substr $buf, 0, $len, "");
55	}
56	} else {
57	delete $self->{w};
58	close $self->{fh};
59	}
60	});
61
62	$self->{setup_req} = {
63	sound => 1,
64	exp64 => 1,
65	map1acmd => 1,
66	itemcmd => 2,
67	darkness => 1,
68	facecache => 1,
69	newmapcmd => 1,
70	mapinfocmd => 1,
71	plugincmd => 1,
72	extendedTextInfos => 1,
73	};
74
75	$self->send ("version 1023 1027 perlclient");
76	$self->send_setup;
77
78	$self
79	}
80
81	sub feed {
82	my ($self, $data) = @_;
83
84	$data =~ s/^(\S+)(?:\s\|$)//
85	or return;
86
87	my $command = "feed_$1";
88
89	$self->$command ($data);
90	}
91
92	sub feed_version {
93	my ($self, $version) = @_;
94	}
95
96	sub feed_setup {
97	my ($self, $data) = @_;
98
99	$data =~ s/^ +//;
100
101	$self->{setup} = { split / +/, $data };
102
103	my ($mapw, $maph) = split /x/, $self->{setup}{mapsize};
104
105	if ($mapw != $self->{mapw} \|\| $maph != $self->{maph}) {
106	($self->{mapw}, $self->{maph}) = ($mapw, $maph);
107	$self->send_setup;
108	} else {
109	$self->send ("addme");
110	}
111
112	$self->feed_newmap;
113	}
114
115	sub feed_addme_success {
116	my ($self, $data) = @_;
117	}
118
119	sub feed_addme_failure {
120	my ($self, $data) = @_;
121	# maybe should notify user
122	}
123
124	=back
125
126	=head2 METHODS THAT CAN/MUST BE OVERWRITTEN
127
128	=over 4
129
130	=cut
131
132	sub feed_face1 {
133	my ($self, $data) = @_;
134
135	my ($num, $chksum, $name) = unpack "nNa*", $data;
136
137	my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };
138
139	if (my $data = $self->face_find ($num, $face)) {
140	$face->{image} = $data;
141	$self->face_update ($num, $face);
142	} else {
143	$self->send_queue ("askface $num");
144	}
145	}
146
147	=item $conn->anim_update ($num) [OVERWRITE]
148
149	=cut
150
151	sub anim_update { }
152
153	sub feed_anim {
154	my ($self, $data) = @_;
155
156	my ($num, @faces) = unpack "n*", $data;
157
158	$self->{anim}[$num] = \@faces;
159
160	$self->anim_update ($num);
161	}
162
163	=item $conn->play_sound ($x, $y, $soundnum, $type)
164
165	=cut
166
167	sub sound_play { }
168
169	sub feed_sound {
170	my ($self, $data) = @_;
171
172	$self->sound_play (unpack "CCnC", $data);
173	}
174
175	=item $conn->query ($flags, $prompt)
176
177	=cut
178
179	sub query { }
180
181	sub feed_query {
182	my ($self, $data) = @_;
183
184	my ($flags, $prompt) = split /\s+/, $data, 2;
185
186	if ($flags == 0 && $prompt =~ /^What is your name\?\s+:$/ && length $self->{user}) {
187	$self->send ("reply $self->{user}");
188	} elsif ($flags == 4 && $prompt =~ /^What is your password\?\s+:$/ && length $self->{pass}) {
189	$self->send ("reply $self->{pass}");
190	} elsif ($flags == 4 && $prompt =~ /^Please type your password again\.\s+:$/ && length $self->{pass}) {
191	$self->send ("reply $self->{pass}");
192	} else {
193	$self->query ($flags, $prompt);
194	}
195	}
196
197	=item $conn->drawinfo ($color, $text)
198
199	=cut
200
201	sub drawinfo { }
202
203	sub feed_drawinfo {
204	my ($self, $data) = @_;
205
206	$self->drawinfo (split / /, $data, 2);
207	}
208
209	=item $conn->player_update ($player)
210
211	tag, weight, face, name
212
213	=cut
214
215	sub player_update { }
216
217	sub feed_player {
218	my ($self, $data) = @_;
219
220	my ($tag, $weight, $face, $name) = unpack "NNN C/a", $data;
221
222	$self->player_update ($self->{player} = {
223	tag => $tag,
224	weight => $weight,
225	face => $face,
226	name => $name,
227	});
228	}
229
230	=item $conn->stats_update ($stats)
231
232	=cut
233
234	sub stats_update { }
235
236	sub feed_stats {
237	my ($self, $data) = @_;
238
239	while (length $data) {
240	my $stat = unpack "C", substr $data, 0, 1, "";
241	my $value;
242
243	if ($stat == 26 \|\| $stat == 29 \|\| $stat == 30 \|\| $stat == 31 \|\| $stat == 11) {
244	$value = unpack "N", substr $data, 0, 4, "";
245	} elsif ($stat == 17 \|\| $stat == 19) {
246	$value = (1 / 100000) * unpack "N", substr $data, 0, 4, "";
247	} elsif ($stat == 20 \|\| $stat == 21) {
248	my $len = unpack "C", substr $data, 0, 1, "";
249	$value = substr $data, 0, $len, "";
250	} elsif ($stat == 28) {
251	my ($lo, $hi) = unpack "NN", substr $data, 0, 8, "";
252	$value = $hi * 2**32 + $lo;
253	} elsif ($stat >= 118 && $stat <= 129) {
254	my ($level, $lo, $hi) = unpack "CNN", substr $data, 0, 9, "";
255	$value = [$level, $hi * 2**32 + $lo];
256	} else {
257	$value = unpack "n", substr $data, 0, 2, "";
258	}
259
260	$self->{stat}{$stat} = $value;
261	}
262
263	$self->stats_update ($self->{stat});
264	}
265
266	=item $conn->inventory_clear ($id)
267
268	=cut
269
270	sub inventory_clear { }
271
272	sub feed_delinv {
273	my ($self, $data) = @_;
274
275	$self->inventory_clear ($data);
276
277	delete $self->{inventory}[$data];
278	}
279
280	=item $conn->items_delete ($tag...)
281
282	=cut
283
284	sub items_delete { }
285
286	sub feed_delitem {
287	my ($self, $data) = @_;
288
289	$self->items_delete (unpack "n*", $data);
290	}
291
292	=item $conn->inventory_add ($id, [\%item...])
293
294	=cut
295
296	sub inventory_add {
297	}
298
299	sub feed_item2 {
300	my ($self, $data) = @_;
301
302	my ($location, @values) = unpack "N (NNNN C/a* nC Nn)*", $data;
303
304	my @items;
305
306	while (@values) {
307	my ($tag, $flags, $weight, $face, $names, $anim, $animspeed, $nrof, $type) =
308	splice @values, 0, 9, ();
309
310	my ($name, $name_pl) = split /\x000/, $names;
311
312	push @items, {
313	tag => $tag,
314	flags => $flags,
315	weight => $weight,
316	face => $face,
317	name => $name,
318	name_pl => $name_pl,
319	anim => $anim,
320	animspeed => $animspeed * 0.120, #???
321	nrof => $nrof,
322	type => $type,
323	};
324	}
325
326	$self->inventory_add ($location, \@items);
327	}
328
329	=item $conn->item_update ($tag)
330
331	=cut
332
333	sub item_update { }
334
335	sub feed_upditem {
336	#todo
337	}
338
339	sub feed_map1a {
340	my ($self, $data) = @_;
341
342	my $map = $self->{map} \|\|= [];
343
344	my ($dx, $dy) = delete @$self{qw(delayed_scroll_x delayed_scroll_y)};
345
346	if ($dx \|\| $dy) {
347	my ($mx, $my, $mw, $mh) = @$self{qw(mapx mapy mapw maph)};
348
349	{
350	my @darkness;
351
352	if ($dx > 0) {
353	push @darkness, [$mx, $my, $dx - 1, $mh];
354	} elsif ($dx < 0) {
355	push @darkness, [$mx + $mw + $dx + 1, $my, 1 - $dx, $mh];
356	}
357
358	if ($dy > 0) {
359	push @darkness, [$mx, $my, $mw, $dy - 1];
360	} elsif ($dy < 0) {
361	push @darkness, [$mx, $my + $mh + $dy + 1, $mw, 1 - $dy];
362	}
363
364	for (@darkness) {
365	my ($x0, $y0, $w, $h) = @$_;
366	for my $x ($x0 .. $x0 + $w) {
367	for my $y ($y0 .. $y0 + $h) {
368
369	my $cell = $map->[$x][$y]
370	or next;
371
372	$cell->[0] = -1;
373	}
374	}
375	}
376	}
377
378	# now scroll
379
380	$self->{mapx} += $dx;
381	$self->{mapy} += $dy;
382
383	# shift in new space if moving to "negative indices"
384	if ($self->{mapy} < 0) {
385	unshift @$_, (undef) x -$self->{mapy} for @$map;
386	$self->{mapy} = 0;
387	}
388
389	if ($self->{mapx} < 0) {
390	unshift @$map, (undef) x -$self->{mapx};
391	$self->{mapx} = 0;
392	}
393
394	$self->map_scroll ($dx, $dy);
395	}
396
397	my @dirty;
398	my ($coord, $x, $y, $darkness, $fa, $fb, $fc, $cell);
399
400	while (length $data) {
401	$coord = unpack "n", substr $data, 0, 2, "";
402
403	$x = (($coord >> 10) & 63) + $self->{mapx};
404	$y = (($coord >> 4) & 63) + $self->{mapy};
405
406	$cell = $map->[$x][$y] \|\|= [];
407
408	if ($coord & 15) {
409	@$cell = () if $cell->[0] < 0;
410
411	$cell->[0] = $coord & 8
412	? unpack "C", substr $data, 0, 1, ""
413	: 255;
414
415	$cell->[1] = unpack "n", substr $data, 0, 2, ""
416	if $coord & 4;
417	$cell->[2] = unpack "n", substr $data, 0, 2, ""
418	if $coord & 2;
419	$cell->[3] = unpack "n", substr $data, 0, 2, ""
420	if $coord & 1;
421	} else {
422	$cell->[0] = -1;
423	}
424
425	push @dirty, [$x, $y];
426	}
427
428	$self->map_update (\@dirty);
429	}
430
431	sub feed_map_scroll {
432	my ($self, $data) = @_;
433
434	my ($dx, $dy) = split / /, $data;
435
436	$self->{delayed_scroll_x} += $dx;
437	$self->{delayed_scroll_y} += $dy;
438
439	$self->map_scroll ($dx, $dy);
440	}
441
442	sub feed_newmap {
443	my ($self) = @_;
444
445	$self->{map} = [];
446	$self->{mapx} = 0;
447	$self->{mapy} = 0;
448
449	delete $self->{delayed_scroll_x};
450	delete $self->{delayed_scroll_y};
451
452	$self->map_clear;
453	}
454
455	sub feed_mapinfo {
456	my ($self, $data) = @_;
457
458	my ($token, @data) = split / /, $data;
459
460	(delete $self->{mapinfo_cb}{$token})->(@data)
461	if $self->{mapinfo_cb}{$token};
462
463	$self->map_change (@data) if $token eq "-";
464	}
465
466	sub send_mapinfo {
467	my ($self, $data, $cb) = @_;
468
469	my $token = ++$self->{token};
470
471	$self->{mapinfo_cb}{$token} = $cb;
472	$self->send ("mapinfo $token $data");
473	}
474
475	sub feed_image {
476	my ($self, $data) = @_;
477
478	my ($num, $len, $data) = unpack "NNa*", $data;
479
480	$self->send_queue;
481	$self->{face}[$num]{image} = $data;
482	$self->face_update ($num, $self->{face}[$num]);
483
484	my @dirty;
485
486	for my $x (0..$self->{mapw} - 1) {
487	for my $y (0..$self->{maph} - 1) {
488	push @dirty, [$x, $y]
489	if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
490	}
491	}
492
493	$self->map_update (\@dirty);
494	}
495
496	=item $conn->map_change ($mode, ...) [OVERWRITE]
497
498	current <flags> <x> <y> <width> <height> <hashstring>
499
500	=cut
501
502	sub map_info { }
503
504	=item $conn->map_clear [OVERWRITE]
505
506	Called whenever the map is to be erased completely.
507
508	=cut
509
510	sub map_clear { }
511
512	=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
513
514	Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
515	have been updated and need refreshing.
516
517	=cut
518
519	sub map_update { }
520
521	=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
522
523	Called whenever the map has been scrolled.
524
525	=cut
526
527	sub map_scroll { }
528
529	=item $conn->face_update ($facenum, $facedata) [OVERWRITE]
530
531	Called with the face number of face structure whenever a face image has
532	changed.
533
534	=cut
535
536	sub face_update { }
537
538	=item $conn->face_find ($facenum, $facedata) [OVERWRITE]
539
540	Find and return the png image for the given face, or the empty list if no
541	face could be found, in which case it will be requested from the server.
542
543	=cut
544
545	sub face_find { }
546
547	=item $conn->send ($data)
548
549	Send a single packet/line to the server.
550
551	=cut
552
553	sub send {
554	my ($self, $data) = @_;
555
556	$data = pack "na*", length $data, $data;
557
558	syswrite $self->{fh}, $data;
559	}
560
561	sub send_queue {
562	my ($self, $cmd) = @_;
563
564	if (defined $cmd) {
565	push @{ $self->{send_queue} }, $cmd;
566	} else {
567	--$self->{outstanding};
568	}
569
570	if ($self->{outstanding} < $self->{max_outstanding} && @{ $self->{send_queue} }) {
571	++$self->{outstanding};
572	$self->send (pop @{ $self->{send_queue} });
573	}
574	}
575
576	sub send_setup {
577	my ($self) = @_;
578
579	my $setup = join " ", setup => %{$self->{setup_req}},
580	mapsize => "$self->{mapw}x$self->{maph}";
581
582	$self->send ($setup);
583	}
584
585	=back
586
587	=head1 AUTHOR
588
589	Marc Lehmann <schmorp@schmorp.de>
590	http://home.schmorp.de/
591
592	Robin Redeker <elmex@ta-sa.org>
593	http://www.ta-sa.org/
594
595	=cut
596
597	1