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

   my ($flags, $text) = split / /, $data, 2;

   utf8::decode $text if utf8::valid $text;

   $self->drawinfo ($flags, $text);
}

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

=item $conn->send_command ($command)

Uses either command or ncom to send a user-level command to the
server. Encodes the command to UTF-8.

=cut

sub send_command {
   my ($self, $command) = @_;

   utf8::encode $command;
   $self->send ("command $command");
}

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.28
Committed:	Tue Apr 18 04:36:55 2006 UTC (18 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.27:	+2 -2 lines
Log Message:	fix sound 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->sound_play ($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	my ($flags, $text) = split / /, $data, 2;
207
208	utf8::decode $text if utf8::valid $text;
209
210	$self->drawinfo ($flags, $text);
211	}
212
213	=item $conn->player_update ($player)
214
215	tag, weight, face, name
216
217	=cut
218
219	sub player_update { }
220
221	sub feed_player {
222	my ($self, $data) = @_;
223
224	my ($tag, $weight, $face, $name) = unpack "NNN C/a", $data;
225
226	$self->player_update ($self->{player} = {
227	tag => $tag,
228	weight => $weight,
229	face => $face,
230	name => $name,
231	});
232	}
233
234	=item $conn->stats_update ($stats)
235
236	=cut
237
238	sub stats_update { }
239
240	sub feed_stats {
241	my ($self, $data) = @_;
242
243	while (length $data) {
244	my $stat = unpack "C", substr $data, 0, 1, "";
245	my $value;
246
247	if ($stat == 26 \|\| $stat == 29 \|\| $stat == 30 \|\| $stat == 31 \|\| $stat == 11) {
248	$value = unpack "N", substr $data, 0, 4, "";
249	} elsif ($stat == 17 \|\| $stat == 19) {
250	$value = (1 / 100000) * unpack "N", substr $data, 0, 4, "";
251	} elsif ($stat == 20 \|\| $stat == 21) {
252	my $len = unpack "C", substr $data, 0, 1, "";
253	$value = substr $data, 0, $len, "";
254	} elsif ($stat == 28) {
255	my ($lo, $hi) = unpack "NN", substr $data, 0, 8, "";
256	$value = $hi * 2**32 + $lo;
257	} elsif ($stat >= 118 && $stat <= 129) {
258	my ($level, $lo, $hi) = unpack "CNN", substr $data, 0, 9, "";
259	$value = [$level, $hi * 2**32 + $lo];
260	} else {
261	$value = unpack "n", substr $data, 0, 2, "";
262	}
263
264	$self->{stat}{$stat} = $value;
265	}
266
267	$self->stats_update ($self->{stat});
268	}
269
270	=item $conn->inventory_clear ($id)
271
272	=cut
273
274	sub inventory_clear { }
275
276	sub feed_delinv {
277	my ($self, $data) = @_;
278
279	$self->inventory_clear ($data);
280
281	delete $self->{inventory}[$data];
282	}
283
284	=item $conn->items_delete ($tag...)
285
286	=cut
287
288	sub items_delete { }
289
290	sub feed_delitem {
291	my ($self, $data) = @_;
292
293	$self->items_delete (unpack "n*", $data);
294	}
295
296	=item $conn->inventory_add ($id, [\%item...])
297
298	=cut
299
300	sub inventory_add {
301	}
302
303	sub feed_item2 {
304	my ($self, $data) = @_;
305
306	my ($location, @values) = unpack "N (NNNN C/a* nC Nn)*", $data;
307
308	my @items;
309
310	while (@values) {
311	my ($tag, $flags, $weight, $face, $names, $anim, $animspeed, $nrof, $type) =
312	splice @values, 0, 9, ();
313
314	my ($name, $name_pl) = split /\x000/, $names;
315
316	push @items, {
317	tag => $tag,
318	flags => $flags,
319	weight => $weight,
320	face => $face,
321	name => $name,
322	name_pl => $name_pl,
323	anim => $anim,
324	animspeed => $animspeed * 0.120, #???
325	nrof => $nrof,
326	type => $type,
327	};
328	}
329
330	$self->inventory_add ($location, \@items);
331	}
332
333	=item $conn->item_update ($tag)
334
335	=cut
336
337	sub item_update { }
338
339	sub feed_upditem {
340	#todo
341	}
342
343	sub feed_map1a {
344	my ($self, $data) = @_;
345
346	my $map = $self->{map} \|\|= [];
347
348	my ($dx, $dy) = delete @$self{qw(delayed_scroll_x delayed_scroll_y)};
349
350	if ($dx \|\| $dy) {
351	my ($mx, $my, $mw, $mh) = @$self{qw(mapx mapy mapw maph)};
352
353	{
354	my @darkness;
355
356	if ($dx > 0) {
357	push @darkness, [$mx, $my, $dx - 1, $mh];
358	} elsif ($dx < 0) {
359	push @darkness, [$mx + $mw + $dx + 1, $my, 1 - $dx, $mh];
360	}
361
362	if ($dy > 0) {
363	push @darkness, [$mx, $my, $mw, $dy - 1];
364	} elsif ($dy < 0) {
365	push @darkness, [$mx, $my + $mh + $dy + 1, $mw, 1 - $dy];
366	}
367
368	for (@darkness) {
369	my ($x0, $y0, $w, $h) = @$_;
370	for my $x ($x0 .. $x0 + $w) {
371	for my $y ($y0 .. $y0 + $h) {
372
373	my $cell = $map->[$x][$y]
374	or next;
375
376	$cell->[0] = -1;
377	}
378	}
379	}
380	}
381
382	# now scroll
383
384	$self->{mapx} += $dx;
385	$self->{mapy} += $dy;
386
387	# shift in new space if moving to "negative indices"
388	if ($self->{mapy} < 0) {
389	unshift @$_, (undef) x -$self->{mapy} for @$map;
390	$self->{mapy} = 0;
391	}
392
393	if ($self->{mapx} < 0) {
394	unshift @$map, (undef) x -$self->{mapx};
395	$self->{mapx} = 0;
396	}
397
398	$self->map_scroll ($dx, $dy);
399	}
400
401	my @dirty;
402	my ($coord, $x, $y, $darkness, $fa, $fb, $fc, $cell);
403
404	while (length $data) {
405	$coord = unpack "n", substr $data, 0, 2, "";
406
407	$x = (($coord >> 10) & 63) + $self->{mapx};
408	$y = (($coord >> 4) & 63) + $self->{mapy};
409
410	$cell = $map->[$x][$y] \|\|= [];
411
412	if ($coord & 15) {
413	@$cell = () if $cell->[0] < 0;
414
415	$cell->[0] = $coord & 8
416	? unpack "C", substr $data, 0, 1, ""
417	: 255;
418
419	$cell->[1] = unpack "n", substr $data, 0, 2, ""
420	if $coord & 4;
421	$cell->[2] = unpack "n", substr $data, 0, 2, ""
422	if $coord & 2;
423	$cell->[3] = unpack "n", substr $data, 0, 2, ""
424	if $coord & 1;
425	} else {
426	$cell->[0] = -1;
427	}
428
429	push @dirty, [$x, $y];
430	}
431
432	$self->map_update (\@dirty);
433	}
434
435	sub feed_map_scroll {
436	my ($self, $data) = @_;
437
438	my ($dx, $dy) = split / /, $data;
439
440	$self->{delayed_scroll_x} += $dx;
441	$self->{delayed_scroll_y} += $dy;
442
443	$self->map_scroll ($dx, $dy);
444	}
445
446	sub feed_newmap {
447	my ($self) = @_;
448
449	$self->{map} = [];
450	$self->{mapx} = 0;
451	$self->{mapy} = 0;
452
453	delete $self->{delayed_scroll_x};
454	delete $self->{delayed_scroll_y};
455
456	$self->map_clear;
457	}
458
459	sub feed_mapinfo {
460	my ($self, $data) = @_;
461
462	my ($token, @data) = split / /, $data;
463
464	(delete $self->{mapinfo_cb}{$token})->(@data)
465	if $self->{mapinfo_cb}{$token};
466
467	$self->map_change (@data) if $token eq "-";
468	}
469
470	sub send_mapinfo {
471	my ($self, $data, $cb) = @_;
472
473	my $token = ++$self->{token};
474
475	$self->{mapinfo_cb}{$token} = $cb;
476	$self->send ("mapinfo $token $data");
477	}
478
479	sub feed_image {
480	my ($self, $data) = @_;
481
482	my ($num, $len, $data) = unpack "NNa*", $data;
483
484	$self->send_queue;
485	$self->{face}[$num]{image} = $data;
486	$self->face_update ($num, $self->{face}[$num]);
487
488	my @dirty;
489
490	for my $x (0..$self->{mapw} - 1) {
491	for my $y (0..$self->{maph} - 1) {
492	push @dirty, [$x, $y]
493	if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
494	}
495	}
496
497	$self->map_update (\@dirty);
498	}
499
500	=item $conn->map_change ($mode, ...) [OVERWRITE]
501
502	current <flags> <x> <y> <width> <height> <hashstring>
503
504	=cut
505
506	sub map_info { }
507
508	=item $conn->map_clear [OVERWRITE]
509
510	Called whenever the map is to be erased completely.
511
512	=cut
513
514	sub map_clear { }
515
516	=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
517
518	Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
519	have been updated and need refreshing.
520
521	=cut
522
523	sub map_update { }
524
525	=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
526
527	Called whenever the map has been scrolled.
528
529	=cut
530
531	sub map_scroll { }
532
533	=item $conn->face_update ($facenum, $facedata) [OVERWRITE]
534
535	Called with the face number of face structure whenever a face image has
536	changed.
537
538	=cut
539
540	sub face_update { }
541
542	=item $conn->face_find ($facenum, $facedata) [OVERWRITE]
543
544	Find and return the png image for the given face, or the empty list if no
545	face could be found, in which case it will be requested from the server.
546
547	=cut
548
549	sub face_find { }
550
551	=item $conn->send ($data)
552
553	Send a single packet/line to the server.
554
555	=cut
556
557	sub send {
558	my ($self, $data) = @_;
559
560	$data = pack "na*", length $data, $data;
561
562	syswrite $self->{fh}, $data;
563	}
564
565	=item $conn->send_command ($command)
566
567	Uses either command or ncom to send a user-level command to the
568	server. Encodes the command to UTF-8.
569
570	=cut
571
572	sub send_command {
573	my ($self, $command) = @_;
574
575	utf8::encode $command;
576	$self->send ("command $command");
577	}
578
579	sub send_queue {
580	my ($self, $cmd) = @_;
581
582	if (defined $cmd) {
583	push @{ $self->{send_queue} }, $cmd;
584	} else {
585	--$self->{outstanding};
586	}
587
588	if ($self->{outstanding} < $self->{max_outstanding} && @{ $self->{send_queue} }) {
589	++$self->{outstanding};
590	$self->send (pop @{ $self->{send_queue} });
591	}
592	}
593
594	sub send_setup {
595	my ($self) = @_;
596
597	my $setup = join " ", setup => %{$self->{setup_req}},
598	mapsize => "$self->{mapw}x$self->{maph}";
599
600	$self->send ($setup);
601	}
602
603	=back
604
605	=head1 AUTHOR
606
607	Marc Lehmann <schmorp@schmorp.de>
608	http://home.schmorp.de/
609
610	Robin Redeker <elmex@ta-sa.org>
611	http://www.ta-sa.org/
612
613	=cut
614
615	1