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";

#   warn "$command\n";#d#]
   $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) = @_;

   warn "send_queue<$cmd>$self->{outstanding} <@{ $self->{send_queue} || [] }\n";#d#
   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.17
Committed:	Wed Apr 12 21:43:11 2006 UTC (18 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.16:	+22 -3 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	root	1.14	# warn "$command\n";#d#]
87	root	1.1	$self->$command ($data);
88			}
89
90			sub feed_version {
91			my ($self, $version) = @_;
92			}
93
94			sub feed_setup {
95			my ($self, $data) = @_;
96
97			$data =~ s/^ +//;
98
99			$self->{setup} = { split / +/, $data };
100
101	root	1.10	my ($mapw, $maph) = split /x/, $self->{setup}{mapsize};
102
103			if ($mapw != $self->{mapw} \|\| $maph != $self->{maph}) {
104			($self->{mapw}, $self->{maph}) = ($mapw, $maph);
105	root	1.11	$self->send_setup;
106			} else {
107			$self->send ("addme");
108	root	1.10	}
109	root	1.1
110			$self->feed_newmap;
111			}
112
113	root	1.11	sub feed_addme_success {
114			my ($self, $data) = @_;
115			}
116
117			sub feed_addme_failure {
118			my ($self, $data) = @_;
119			# maybe should notify user
120			}
121
122	root	1.14	=back
123
124			=head2 METHODS THAT CAN/MUST BE OVERWRITTEN
125
126			=over 4
127
128			=cut
129
130			sub feed_face1 {
131			my ($self, $data) = @_;
132
133			my ($num, $chksum, $name) = unpack "nNa*", $data;
134
135			my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };
136
137			if (my $data = $self->face_find ($face)) {
138			$face->{image} = $data;
139			$self->face_update ($face);
140			} else {
141	root	1.17	$self->send_queue ("askface $num");
142	root	1.14	}
143			}
144
145			=item $conn->anim_update ($num) [OVERWRITE]
146
147			=cut
148
149			sub anim_update { }
150
151			sub feed_anim {
152			my ($self, $data) = @_;
153
154			my ($num, @faces) = unpack "n*", $data;
155
156			$self->{anim}[$num] = \@faces;
157
158			$self->anim_update ($num);
159			}
160
161			=item $conn->play_sound ($x, $y, $soundnum, $type)
162	root	1.11
163			=cut
164
165			sub sound_play { }
166
167			sub feed_sound {
168			my ($self, $data) = @_;
169
170			$self->sound_play (unpack "CCnC", $data);
171			}
172
173	root	1.14	=item $conn->query ($flags, $prompt)
174	root	1.6
175			=cut
176
177	root	1.14	sub query { }
178	root	1.6
179	root	1.1	sub feed_query {
180			my ($self, $data) = @_;
181	root	1.6
182			my ($flags, $prompt) = split /\s+/, $data, 2;
183
184			if ($flags == 0 && $prompt =~ /^What is your name\?\s+:$/ && length $self->{user}) {
185			$self->send ("reply $self->{user}");
186			} elsif ($flags == 4 && $prompt =~ /^What is your password\?\s+:$/ && length $self->{pass}) {
187			$self->send ("reply $self->{pass}");
188			} elsif ($flags == 4 && $prompt =~ /^Please type your password again\.\s+:$/ && length $self->{pass}) {
189			$self->send ("reply $self->{pass}");
190			} else {
191			$self->query ($flags, $prompt);
192			}
193	root	1.1	}
194
195	root	1.14	=item $conn->drawinfo ($color, $text)
196
197			=cut
198
199			sub drawinfo { }
200
201			sub feed_drawinfo {
202			my ($self, $data) = @_;
203
204			$self->drawinfo (split / /, $data, 2);
205			}
206
207			=item $conn->player_update ($player)
208	root	1.6
209			tag, weight, face, name
210
211			=cut
212
213			sub player_update { }
214
215			sub feed_player {
216			my ($self, $data) = @_;
217
218			my ($tag, $weight, $face, $name) = unpack "NNN C/a", $data;
219
220			$self->player_update ($self->{player} = {
221			tag => $tag,
222			weight => $weight,
223			face => $face,
224			name => $name,
225			});
226			}
227
228	root	1.14	=item $conn->stats_update ($stats)
229	root	1.6
230			=cut
231
232			sub stats_update { }
233
234	root	1.1	sub feed_stats {
235			my ($self, $data) = @_;
236	root	1.6
237			while (length $data) {
238			my $stat = unpack "C", substr $data, 0, 1, "";
239			my $value;
240
241			if ($stat == 26 \|\| $stat == 29 \|\| $stat == 30 \|\| $stat == 31 \|\| $stat == 11) {
242			$value = unpack "N", substr $data, 0, 4, "";
243			} elsif ($stat == 17 \|\| $stat == 19) {
244			$value = (1 / 100000) * unpack "N", substr $data, 0, 4, "";
245			} elsif ($stat == 20 \|\| $stat == 21) {
246			my $len = unpack "C", substr $data, 0, 1, "";
247			$value = substr $data, 0, $len, "";
248			} elsif ($stat == 28) {
249			my ($lo, $hi) = unpack "NN", substr $data, 0, 8, "";
250			$value = $hi * 2**32 + $lo;
251			} elsif ($stat >= 118 && $stat <= 129) {
252			my ($level, $lo, $hi) = unpack "CNN", substr $data, 0, 9, "";
253			$value = [$level, $hi * 2**32 + $lo];
254			} else {
255			$value = unpack "n", substr $data, 0, 2, "";
256			}
257
258			$self->{stat}{$stat} = $value;
259			}
260
261			$self->stats_update ($self->{stat});
262	root	1.1	}
263
264	root	1.14	=item $conn->inventory_clear ($id)
265
266			=cut
267
268			sub inventory_clear { }
269
270			sub feed_delinv {
271	root	1.1	my ($self, $data) = @_;
272
273	root	1.14	$self->inventory_clear ($data);
274	root	1.3
275	root	1.14	delete $self->{inventory}[$data];
276	root	1.1	}
277
278	root	1.14	=item $conn->items_delete ($tag...)
279	root	1.6
280			=cut
281
282	root	1.14	sub items_delete { }
283	root	1.6
284	root	1.14	sub feed_delitem {
285	root	1.6	my ($self, $data) = @_;
286
287	root	1.14	$self->items_delete (unpack "n*", $data);
288			}
289
290			=item $conn->inventory_add ($id, [\%item...])
291	root	1.6
292	root	1.14	=cut
293	root	1.6
294	root	1.14	sub inventory_add {
295	root	1.6	}
296
297	root	1.14	sub feed_item2 {
298	root	1.1	my ($self, $data) = @_;
299	root	1.14
300			my ($location, @values) = unpack "N (NNNN C/a* nC Nn)*", $data;
301
302			my @items;
303
304			while (@values) {
305			my ($tag, $flags, $weight, $face, $names, $anim, $animspeed, $nrof, $type) =
306			splice @values, 0, 9, ();
307
308			my ($name, $name_pl) = split /\x000/, $names;
309
310			push @items, {
311			tag => $tag,
312			flags => $flags,
313			weight => $weight,
314			face => $face,
315			name => $name,
316			name_pl => $name_pl,
317			anim => $anim,
318			animspeed => $animspeed * 0.120, #???
319			nrof => $nrof,
320			type => $type,
321			};
322			}
323
324			$self->inventory_add ($location, \@items);
325	root	1.1	}
326
327	root	1.14	=item $conn->item_update ($tag)
328
329			=cut
330
331			sub item_update { }
332	root	1.1
333	root	1.14	sub feed_upditem {
334			#todo
335	root	1.1	}
336
337			sub feed_map1a {
338			my ($self, $data) = @_;
339
340			my $map = $self->{map} \|\|= [];
341
342	root	1.14	my ($dx, $dy) = delete @$self{qw(delayed_scroll_x delayed_scroll_y)};
343
344			if ($dx \|\| $dy) {
345			my ($mx, $my, $mw, $mh) = @$self{qw(mapx mapy mapw maph)};
346
347			# TODO: optimise this a lot, or maybe just do it on c-level
348			# set flag to -1 for spaces we scroll out
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	root	1.16	unshift @$_, (undef) x -$self->{mapy} for @$map;
386	root	1.14	$self->{mapy} = 0;
387			}
388
389			if ($self->{mapx} < 0) {
390	root	1.16	unshift @$map, (undef) x -$self->{mapx};
391	root	1.14	$self->{mapx} = 0;
392			}
393
394			$self->map_scroll ($dx, $dy);
395			}
396
397	root	1.1	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	root	1.10	$x = (($coord >> 10) & 63) + $self->{mapx};
404			$y = (($coord >> 4) & 63) + $self->{mapy};
405	root	1.1
406			$cell = $map->[$x][$y] \|\|= [];
407
408	root	1.10	if ($coord & 15) {
409	root	1.14	@$cell = () if $cell->[0] < 0;
410
411	root	1.10	$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	root	1.1
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	root	1.14	$self->{delayed_scroll_x} += $dx;
437			$self->{delayed_scroll_y} += $dy;
438	root	1.1	}
439
440			sub feed_newmap {
441			my ($self) = @_;
442
443			$self->{map} = [];
444			$self->{mapx} = 0;
445			$self->{mapy} = 0;
446
447	root	1.14	delete $self->{delayed_scroll_x};
448			delete $self->{delayed_scroll_y};
449
450	root	1.1	$self->map_clear;
451			}
452
453			sub feed_image {
454			my ($self, $data) = @_;
455
456	root	1.17	$self->send_queue;
457
458	root	1.3	my ($num, $len, $data) = unpack "NNa*", $data;
459	root	1.1
460	root	1.3	$self->{face}[$num]{image} = $data;
461	root	1.5	$self->face_update ($self->{face}[$num]);
462	root	1.1
463	root	1.3	my @dirty;
464	root	1.2
465			for my $x (0..$self->{mapw} - 1) {
466			for my $y (0..$self->{maph} - 1) {
467			push @dirty, [$x, $y]
468			if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
469			}
470			}
471	root	1.6
472	root	1.2	$self->map_update (\@dirty);
473	root	1.1	}
474
475			=item $conn->map_clear [OVERWRITE]
476
477			Called whenever the map is to be erased completely.
478
479			=cut
480
481			sub map_clear { }
482
483			=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
484
485			Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
486			have been updated and need refreshing.
487
488			=cut
489
490			sub map_update { }
491
492			=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
493
494			Called whenever the map has been scrolled.
495
496			=cut
497
498			sub map_scroll { }
499
500	root	1.5	=item $conn->face_update ($face) [OVERWRITE]
501	root	1.1
502			Called with the face number of face structure whenever a face image has
503			changed.
504
505			=cut
506
507			sub face_update { }
508
509	root	1.5	=item $conn->face_find ($face) [OVERWRITE]
510	root	1.3
511			Find and return the png image for the given face, or the empty list if no
512			face could be found, in which case it will be requested from the server.
513
514			=cut
515
516			sub face_find { }
517
518	root	1.1	=item $conn->send ($data)
519
520			Send a single packet/line to the server.
521
522			=cut
523
524			sub send {
525			my ($self, $data) = @_;
526
527			$data = pack "na*", length $data, $data;
528
529			syswrite $self->{fh}, $data;
530			}
531
532	root	1.17	sub send_queue {
533			my ($self, $cmd) = @_;
534
535			warn "send_queue<$cmd>$self->{outstanding} <@{ $self->{send_queue} \|\| [] }\n";#d#
536			if (defined $cmd) {
537			push @{ $self->{send_queue} }, $cmd;
538			} else {
539			--$self->{outstanding};
540			}
541
542			if ($self->{outstanding} < $self->{max_outstanding}) {
543			++$self->{outstanding};
544			$self->send (shift @{ $self->{send_queue} });
545			}
546			}
547
548	root	1.11	sub send_setup {
549			my ($self) = @_;
550
551			my $setup = join " ", setup => %{$self->{setup_req}},
552			mapsize => "$self->{mapw}x$self->{maph}";
553	root	1.15
554	root	1.11	$self->send ($setup);
555			}
556
557	root	1.1	=back
558
559			=head1 AUTHOR
560
561			Marc Lehmann <schmorp@schmorp.de>
562			http://home.schmorp.de/
563
564			Robin Redeker <elmex@ta-sa.org>
565			http://www.ta-sa.org/
566
567			=cut
568
569			1