Deliantra/Deliantra/Protocol.pm

=head1 NAME

Crossfire::Protocol - client protocol module

=head1 SYNOPSIS

   use base Crossfire::Protocol; # you have to subclass

=head1 DESCRIPTION

Base class to implement a corssfire client.

=over 4

=cut

package Crossfire::Protocol;

our $VERSION = '0.1';

use strict;

use AnyEvent;
use IO::Socket::INET;

=item new Crossfire::Protocol host => ..., port => ...

=cut

sub new {
   my $class = shift;
   my $self = bless {
      mapw            => 13,
      maph            => 13,
      max_outstanding => 2,
      token           => "a0",
      @_
   }, $class;

   $self->{fh} = new IO::Socket::INET PeerHost => $self->{host}, PeerPort => $self->{port}
      or die "$self->{host}:$self->{port}: $!";
   $self->{fh}->blocking (0); # stupid nonblock default

   my $buf;

   $self->{w} = AnyEvent->io (fh => $self->{fh}, poll => 'r', cb => sub {
      if (sysread $self->{fh}, $buf, 16384, length $buf) {
         for (;;) {
            last unless 2 <= length $buf;
            my $len = unpack "n", $buf;
            last unless $len + 2 <= length $buf;

            substr $buf, 0, 2, "";
            $self->feed (substr $buf, 0, $len, "");
         }
      } else {
         delete $self->{w};
         close $self->{fh};
      }
   });

   $self->{setup_req} = {
      sound             => 1,
      exp64             => 1,
      map1acmd          => 1,
      itemcmd           => 2,
      darkness          => 1,
      facecache         => 1,
      newmapcmd         => 1,
      mapinfocmd        => 1,
      plugincmd         => 1,
      extendedTextInfos => 1,
   };

   $self->send ("version 1023 1027 perlclient");
   $self->send_setup;

   $self
}

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

   $data =~ s/^(\S+)(?:\s|$)//
      or return;

   my $command = "feed_$1";

   $self->$command ($data);
}

sub feed_version {
   my ($self, $version) = @_;
}

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

   $data =~ s/^ +//;

   $self->{setup} = { split / +/, $data };

   my ($mapw, $maph) = split /x/, $self->{setup}{mapsize};

   if ($mapw != $self->{mapw} || $maph != $self->{maph}) {
      ($self->{mapw}, $self->{maph}) = ($mapw, $maph);
      $self->send_setup;
   } else {
      $self->send ("addme");
   }

   $self->feed_newmap;
}

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

sub feed_addme_failure {
   my ($self, $data) = @_;
   # maybe should notify user
}

=back

=head2 METHODS THAT CAN/MUST BE OVERWRITTEN

=over 4

=cut

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

   my ($num, $chksum, $name) = unpack "nNa*", $data;

   my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };

   if (my $data = $self->face_find ($num, $face)) {
      $face->{image} = $data;
      $self->face_update ($num, $face);
   } else {
      $self->send_queue ("askface $num");
   }
}

=item $conn->anim_update ($num) [OVERWRITE]

=cut

sub anim_update { }

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

   my ($num, @faces) = unpack "n*", $data;

   $self->{anim}[$num] = \@faces;

   $self->anim_update ($num);
}

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

=cut

sub sound_play { }

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

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

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

=cut

sub query { }

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

   my ($flags, $prompt) = split /\s+/, $data, 2;

   if ($flags == 0 && $prompt =~ /^What is your name\?\s+:$/ && length $self->{user}) {
      $self->send ("reply $self->{user}");
   } elsif ($flags == 4 && $prompt =~ /^What is your password\?\s+:$/ && length $self->{pass}) {
      $self->send ("reply $self->{pass}");
   } elsif ($flags == 4 && $prompt =~ /^Please type your password again\.\s+:$/ && length $self->{pass}) {
      $self->send ("reply $self->{pass}");
   } else {
      $self->query ($flags, $prompt);
   }
}

=item $conn->drawinfo ($color, $text)

=cut

sub drawinfo { }

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

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

=item $conn->player_update ($player)

tag, weight, face, name

=cut

sub player_update { }

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

   my ($tag, $weight, $face, $name) = unpack "NNN C/a", $data;

   $self->player_update ($self->{player} = {
      tag    => $tag,
      weight => $weight,
      face   => $face,
      name   => $name,
   });
}

=item $conn->stats_update ($stats)

=cut

sub stats_update { }

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

   while (length $data) {
      my $stat = unpack "C", substr $data, 0, 1, "";
      my $value;

      if ($stat == 26 || $stat == 29 || $stat == 30 || $stat == 31 || $stat == 11) {
         $value = unpack "N", substr $data, 0, 4, "";
      } elsif ($stat == 17 || $stat == 19) {
         $value = (1 / 100000) * unpack "N", substr $data, 0, 4, "";
      } elsif ($stat == 20 || $stat == 21) {
         my $len = unpack "C", substr $data, 0, 1, "";
         $value = substr $data, 0, $len, "";
      } elsif ($stat == 28) {
         my ($lo, $hi) = unpack "NN", substr $data, 0, 8, "";
         $value = $hi * 2**32 + $lo;
      } elsif ($stat >= 118 && $stat <= 129) {
         my ($level, $lo, $hi) = unpack "CNN", substr $data, 0, 9, "";
         $value = [$level, $hi * 2**32 + $lo];
      } else {
         $value = unpack "n", substr $data, 0, 2, "";
      }

      $self->{stat}{$stat} = $value;
   }

   $self->stats_update ($self->{stat});
}

=item $conn->inventory_clear ($id)

=cut

sub inventory_clear { }

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

   $self->inventory_clear ($data);

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

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

=cut

sub items_delete { }

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

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

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

=cut

sub inventory_add {
}

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

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

   my @items;

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

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

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

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

=item $conn->item_update ($tag)

=cut

sub item_update { }

sub feed_upditem {
   #todo
}

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

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

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

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

      {
         my @darkness;

         if ($dx > 0) {
            push @darkness, [$mx, $my, $dx - 1, $mh];
         } elsif ($dx < 0) {
            push @darkness, [$mx + $mw + $dx + 1, $my, 1 - $dx, $mh];
         }

         if ($dy > 0) {
            push @darkness, [$mx, $my, $mw, $dy - 1];
         } elsif ($dy < 0) {
            push @darkness, [$mx, $my + $mh + $dy + 1, $mw, 1 - $dy];
         }

         for (@darkness) {
            my ($x0, $y0, $w, $h) = @$_;
            for my $x ($x0 .. $x0 + $w) {
               for my $y ($y0 .. $y0 + $h) {

                  my $cell = $map->[$x][$y]
                     or next;

                  $cell->[0] = -1;
               }
            }
         }
      }

      # now scroll

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

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

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

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

   my @dirty;
   my ($coord, $x, $y, $darkness, $fa, $fb, $fc, $cell);

   while (length $data) {
      $coord = unpack "n", substr $data, 0, 2, "";

      $x = (($coord >> 10) & 63) + $self->{mapx};
      $y = (($coord >>  4) & 63) + $self->{mapy};

      $cell = $map->[$x][$y] ||= [];

      if ($coord & 15) {
         @$cell = () if $cell->[0] < 0;

         $cell->[0] = $coord & 8
                    ? unpack "C", substr $data, 0, 1, ""
                    : 255;

         $cell->[1] = unpack "n", substr $data, 0, 2, ""
            if $coord & 4;
         $cell->[2] = unpack "n", substr $data, 0, 2, ""
            if $coord & 2;
         $cell->[3] = unpack "n", substr $data, 0, 2, ""
            if $coord & 1;
      } else {
         $cell->[0] = -1;
      }

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

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

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

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

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

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

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

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

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

   $self->map_clear;
}

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

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

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

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

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

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

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

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

   $self->send_queue;
   $self->{face}[$num]{image} = $data;
   $self->face_update ($num, $self->{face}[$num]);

   my @dirty;

   for my $x (0..$self->{mapw} - 1) {
      for my $y (0..$self->{maph} - 1) {
         push @dirty, [$x, $y]
            if grep $_ == $num, @{$self->{map}[$x][$y] || []};
      }
   }

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

=item $conn->map_change ($mode, ...) [OVERWRITE]

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

=cut

sub map_info { }

=item $conn->map_clear [OVERWRITE]

Called whenever the map is to be erased completely.

=cut

sub map_clear  { }

=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]

Called with a list of x|y coordinate pairs (as arrayrefs) for cells that
have been updated and need refreshing.

=cut

sub map_update { }

=item $conn->map_scroll ($dx, $dy) [OVERWRITE]

Called whenever the map has been scrolled.

=cut

sub map_scroll { }

=item $conn->face_update ($facenum, $facedata) [OVERWRITE]

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

=cut

sub face_update { }

=item $conn->face_find ($facenum, $facedata) [OVERWRITE]

Find and return the png image for the given face, or the empty list if no
face could be found, in which case it will be requested from the server.

=cut

sub face_find { }

=item $conn->send ($data)

Send a single packet/line to the server.

=cut

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

   $data = pack "na*", length $data, $data;

   syswrite $self->{fh}, $data;
}

sub send_queue {
   my ($self, $cmd) = @_;

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

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

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

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

   $self->send ($setup);
}

=back

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

 Robin Redeker <elmex@ta-sa.org>
 http://www.ta-sa.org/

=cut

1
Revision:	1.24
Committed:	Mon Apr 17 06:50:45 2006 UTC (18 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.23:	+19 -3 lines
Log Message:	implement mapinfo support
#	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.24	token => "a0",
37	root	1.10	@_
38			}, $class;
39	root	1.1
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	root	1.8	for (;;) {
49			last unless 2 <= length $buf;
50	root	1.1	my $len = unpack "n", $buf;
51	root	1.8	last unless $len + 2 <= length $buf;
52
53			substr $buf, 0, 2, "";
54			$self->feed (substr $buf, 0, $len, "");
55	root	1.1	}
56			} else {
57			delete $self->{w};
58			close $self->{fh};
59			}
60			});
61
62	root	1.11	$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	root	1.22	mapinfocmd => 1,
71			plugincmd => 1,
72	root	1.11	extendedTextInfos => 1,
73			};
74
75	root	1.1	$self->send ("version 1023 1027 perlclient");
76	root	1.11	$self->send_setup;
77	root	1.1
78			$self
79			}
80
81			sub feed {
82			my ($self, $data) = @_;
83
84	root	1.11	$data =~ s/^(\S+)(?:\s\|$)//
85	root	1.1	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	root	1.10	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	root	1.11	$self->send_setup;
108			} else {
109			$self->send ("addme");
110	root	1.10	}
111	root	1.1
112			$self->feed_newmap;
113			}
114
115	root	1.11	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	root	1.14	=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	root	1.23	if (my $data = $self->face_find ($num, $face)) {
140	root	1.14	$face->{image} = $data;
141	root	1.20	$self->face_update ($num, $face);
142	root	1.14	} else {
143	root	1.17	$self->send_queue ("askface $num");
144	root	1.14	}
145			}
146
147			=item $conn->anim_update ($num) [OVERWRITE]
148
149			=cut
150
151			sub anim_update { }
152
153			sub feed_anim {
154			my ($self, $data) = @_;
155
156			my ($num, @faces) = unpack "n*", $data;
157
158			$self->{anim}[$num] = \@faces;
159
160			$self->anim_update ($num);
161			}
162
163			=item $conn->play_sound ($x, $y, $soundnum, $type)
164	root	1.11
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	root	1.14	=item $conn->query ($flags, $prompt)
176	root	1.6
177			=cut
178
179	root	1.14	sub query { }
180	root	1.6
181	root	1.1	sub feed_query {
182			my ($self, $data) = @_;
183	root	1.6
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	root	1.1	}
196
197	root	1.14	=item $conn->drawinfo ($color, $text)
198
199			=cut
200
201			sub drawinfo { }
202
203			sub feed_drawinfo {
204			my ($self, $data) = @_;
205
206			$self->drawinfo (split / /, $data, 2);
207			}
208
209			=item $conn->player_update ($player)
210	root	1.6
211			tag, weight, face, name
212
213			=cut
214
215			sub player_update { }
216
217			sub feed_player {
218			my ($self, $data) = @_;
219
220			my ($tag, $weight, $face, $name) = unpack "NNN C/a", $data;
221
222			$self->player_update ($self->{player} = {
223			tag => $tag,
224			weight => $weight,
225			face => $face,
226			name => $name,
227			});
228			}
229
230	root	1.14	=item $conn->stats_update ($stats)
231	root	1.6
232			=cut
233
234			sub stats_update { }
235
236	root	1.1	sub feed_stats {
237			my ($self, $data) = @_;
238	root	1.6
239			while (length $data) {
240			my $stat = unpack "C", substr $data, 0, 1, "";
241			my $value;
242
243			if ($stat == 26 \|\| $stat == 29 \|\| $stat == 30 \|\| $stat == 31 \|\| $stat == 11) {
244			$value = unpack "N", substr $data, 0, 4, "";
245			} elsif ($stat == 17 \|\| $stat == 19) {
246			$value = (1 / 100000) * unpack "N", substr $data, 0, 4, "";
247			} elsif ($stat == 20 \|\| $stat == 21) {
248			my $len = unpack "C", substr $data, 0, 1, "";
249			$value = substr $data, 0, $len, "";
250			} elsif ($stat == 28) {
251			my ($lo, $hi) = unpack "NN", substr $data, 0, 8, "";
252			$value = $hi * 2**32 + $lo;
253			} elsif ($stat >= 118 && $stat <= 129) {
254			my ($level, $lo, $hi) = unpack "CNN", substr $data, 0, 9, "";
255			$value = [$level, $hi * 2**32 + $lo];
256			} else {
257			$value = unpack "n", substr $data, 0, 2, "";
258			}
259
260			$self->{stat}{$stat} = $value;
261			}
262
263			$self->stats_update ($self->{stat});
264	root	1.1	}
265
266	root	1.14	=item $conn->inventory_clear ($id)
267
268			=cut
269
270			sub inventory_clear { }
271
272			sub feed_delinv {
273	root	1.1	my ($self, $data) = @_;
274
275	root	1.14	$self->inventory_clear ($data);
276	root	1.3
277	root	1.14	delete $self->{inventory}[$data];
278	root	1.1	}
279
280	root	1.14	=item $conn->items_delete ($tag...)
281	root	1.6
282			=cut
283
284	root	1.14	sub items_delete { }
285	root	1.6
286	root	1.14	sub feed_delitem {
287	root	1.6	my ($self, $data) = @_;
288
289	root	1.14	$self->items_delete (unpack "n*", $data);
290			}
291
292			=item $conn->inventory_add ($id, [\%item...])
293	root	1.6
294	root	1.14	=cut
295	root	1.6
296	root	1.14	sub inventory_add {
297	root	1.6	}
298
299	root	1.14	sub feed_item2 {
300	root	1.1	my ($self, $data) = @_;
301	root	1.14
302			my ($location, @values) = unpack "N (NNNN C/a* nC Nn)*", $data;
303
304			my @items;
305
306			while (@values) {
307			my ($tag, $flags, $weight, $face, $names, $anim, $animspeed, $nrof, $type) =
308			splice @values, 0, 9, ();
309
310			my ($name, $name_pl) = split /\x000/, $names;
311
312			push @items, {
313			tag => $tag,
314			flags => $flags,
315			weight => $weight,
316			face => $face,
317			name => $name,
318			name_pl => $name_pl,
319			anim => $anim,
320			animspeed => $animspeed * 0.120, #???
321			nrof => $nrof,
322			type => $type,
323			};
324			}
325
326			$self->inventory_add ($location, \@items);
327	root	1.1	}
328
329	root	1.14	=item $conn->item_update ($tag)
330
331			=cut
332
333			sub item_update { }
334	root	1.1
335	root	1.14	sub feed_upditem {
336			#todo
337	root	1.1	}
338
339			sub feed_map1a {
340			my ($self, $data) = @_;
341
342			my $map = $self->{map} \|\|= [];
343
344	root	1.14	my ($dx, $dy) = delete @$self{qw(delayed_scroll_x delayed_scroll_y)};
345
346			if ($dx \|\| $dy) {
347			my ($mx, $my, $mw, $mh) = @$self{qw(mapx mapy mapw maph)};
348
349			{
350			my @darkness;
351
352			if ($dx > 0) {
353			push @darkness, [$mx, $my, $dx - 1, $mh];
354			} elsif ($dx < 0) {
355			push @darkness, [$mx + $mw + $dx + 1, $my, 1 - $dx, $mh];
356			}
357
358			if ($dy > 0) {
359			push @darkness, [$mx, $my, $mw, $dy - 1];
360			} elsif ($dy < 0) {
361			push @darkness, [$mx, $my + $mh + $dy + 1, $mw, 1 - $dy];
362			}
363
364			for (@darkness) {
365			my ($x0, $y0, $w, $h) = @$_;
366			for my $x ($x0 .. $x0 + $w) {
367			for my $y ($y0 .. $y0 + $h) {
368
369			my $cell = $map->[$x][$y]
370			or next;
371
372			$cell->[0] = -1;
373			}
374			}
375			}
376			}
377
378			# now scroll
379
380			$self->{mapx} += $dx;
381			$self->{mapy} += $dy;
382
383			# shift in new space if moving to "negative indices"
384			if ($self->{mapy} < 0) {
385	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.24
439			$self->map_scroll ($dx, $dy);
440	root	1.1	}
441
442			sub feed_newmap {
443			my ($self) = @_;
444
445			$self->{map} = [];
446			$self->{mapx} = 0;
447			$self->{mapy} = 0;
448
449	root	1.14	delete $self->{delayed_scroll_x};
450			delete $self->{delayed_scroll_y};
451
452	root	1.1	$self->map_clear;
453			}
454
455	root	1.22	sub feed_mapinfo {
456			my ($self, $data) = @_;
457	root	1.24
458			my ($token, @data) = split / /, $data;
459
460			(delete $self->{mapinfo_cb}{$token})->(@data)
461			if $self->{mapinfo_cb}{$token};
462	root	1.22
463	root	1.24	$self->map_change (@data) if $token eq "-";
464			}
465
466			sub send_mapinfo {
467			my ($self, $data, $cb) = @_;
468
469			my $token = ++$self->{token};
470
471			$self->{mapinfo_cb}{$token} = $cb;
472			$self->send ("mapinfo $token $data");
473	root	1.22	}
474
475	root	1.1	sub feed_image {
476			my ($self, $data) = @_;
477
478	root	1.3	my ($num, $len, $data) = unpack "NNa*", $data;
479	root	1.1
480	root	1.22	$self->send_queue;
481	root	1.3	$self->{face}[$num]{image} = $data;
482	root	1.20	$self->face_update ($num, $self->{face}[$num]);
483	root	1.1
484	root	1.3	my @dirty;
485	root	1.2
486			for my $x (0..$self->{mapw} - 1) {
487			for my $y (0..$self->{maph} - 1) {
488			push @dirty, [$x, $y]
489			if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
490			}
491			}
492	root	1.6
493	root	1.2	$self->map_update (\@dirty);
494	root	1.1	}
495
496	root	1.24	=item $conn->map_change ($mode, ...) [OVERWRITE]
497	root	1.22
498			current <flags> <x> <y> <width> <height> <hashstring>
499
500			=cut
501
502			sub map_info { }
503
504	root	1.1	=item $conn->map_clear [OVERWRITE]
505
506			Called whenever the map is to be erased completely.
507
508			=cut
509
510			sub map_clear { }
511
512			=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
513
514			Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
515			have been updated and need refreshing.
516
517			=cut
518
519			sub map_update { }
520
521			=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
522
523			Called whenever the map has been scrolled.
524
525			=cut
526
527			sub map_scroll { }
528
529	root	1.20	=item $conn->face_update ($facenum, $facedata) [OVERWRITE]
530	root	1.1
531			Called with the face number of face structure whenever a face image has
532			changed.
533
534			=cut
535
536			sub face_update { }
537
538	root	1.23	=item $conn->face_find ($facenum, $facedata) [OVERWRITE]
539	root	1.3
540			Find and return the png image for the given face, or the empty list if no
541			face could be found, in which case it will be requested from the server.
542
543			=cut
544
545			sub face_find { }
546
547	root	1.1	=item $conn->send ($data)
548
549			Send a single packet/line to the server.
550
551			=cut
552
553			sub send {
554			my ($self, $data) = @_;
555
556			$data = pack "na*", length $data, $data;
557
558			syswrite $self->{fh}, $data;
559			}
560
561	root	1.17	sub send_queue {
562			my ($self, $cmd) = @_;
563
564			if (defined $cmd) {
565			push @{ $self->{send_queue} }, $cmd;
566			} else {
567			--$self->{outstanding};
568			}
569
570	root	1.19	if ($self->{outstanding} < $self->{max_outstanding} && @{ $self->{send_queue} }) {
571	root	1.17	++$self->{outstanding};
572	root	1.19	$self->send (pop @{ $self->{send_queue} });
573	root	1.17	}
574			}
575
576	root	1.11	sub send_setup {
577			my ($self) = @_;
578
579			my $setup = join " ", setup => %{$self->{setup_req}},
580			mapsize => "$self->{mapw}x$self->{maph}";
581	root	1.15
582	root	1.11	$self->send ($setup);
583			}
584
585	root	1.1	=back
586
587			=head1 AUTHOR
588
589			Marc Lehmann <schmorp@schmorp.de>
590			http://home.schmorp.de/
591
592			Robin Redeker <elmex@ta-sa.org>
593			http://www.ta-sa.org/
594
595			=cut
596
597			1