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,
      @_
   }, $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
}

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

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

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

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_image {
   my ($self, $data) = @_;

   $self->send_queue;

   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_queue {
   my ($self, $cmd) = @_;

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

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