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

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) = @_;

   $self->map_info (split / /, $data, 7);
}

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