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

   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.27
Committed:	Mon Apr 17 19:36:11 2006 UTC (18 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.26:	+7 -0 lines
Log Message:	more utf-8
#	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	root	1.25	my ($flags, $text) = split / /, $data, 2;
207
208			utf8::decode $text if utf8::valid $text;
209
210			$self->drawinfo ($flags, $text);
211	root	1.14	}
212
213			=item $conn->player_update ($player)
214	root	1.6
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	root	1.14	=item $conn->stats_update ($stats)
235	root	1.6
236			=cut
237
238			sub stats_update { }
239
240	root	1.1	sub feed_stats {
241			my ($self, $data) = @_;
242	root	1.6
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	root	1.1	}
269
270	root	1.14	=item $conn->inventory_clear ($id)
271
272			=cut
273
274			sub inventory_clear { }
275
276			sub feed_delinv {
277	root	1.1	my ($self, $data) = @_;
278
279	root	1.14	$self->inventory_clear ($data);
280	root	1.3
281	root	1.14	delete $self->{inventory}[$data];
282	root	1.1	}
283
284	root	1.14	=item $conn->items_delete ($tag...)
285	root	1.6
286			=cut
287
288	root	1.14	sub items_delete { }
289	root	1.6
290	root	1.14	sub feed_delitem {
291	root	1.6	my ($self, $data) = @_;
292
293	root	1.14	$self->items_delete (unpack "n*", $data);
294			}
295
296			=item $conn->inventory_add ($id, [\%item...])
297	root	1.6
298	root	1.14	=cut
299	root	1.6
300	root	1.14	sub inventory_add {
301	root	1.6	}
302
303	root	1.14	sub feed_item2 {
304	root	1.1	my ($self, $data) = @_;
305	root	1.14
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	root	1.1	}
332
333	root	1.14	=item $conn->item_update ($tag)
334
335			=cut
336
337			sub item_update { }
338	root	1.1
339	root	1.14	sub feed_upditem {
340			#todo
341	root	1.1	}
342
343			sub feed_map1a {
344			my ($self, $data) = @_;
345
346			my $map = $self->{map} \|\|= [];
347
348	root	1.14	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	root	1.16	unshift @$_, (undef) x -$self->{mapy} for @$map;
390	root	1.14	$self->{mapy} = 0;
391			}
392
393			if ($self->{mapx} < 0) {
394	root	1.16	unshift @$map, (undef) x -$self->{mapx};
395	root	1.14	$self->{mapx} = 0;
396			}
397
398			$self->map_scroll ($dx, $dy);
399			}
400
401	root	1.1	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	root	1.10	$x = (($coord >> 10) & 63) + $self->{mapx};
408			$y = (($coord >> 4) & 63) + $self->{mapy};
409	root	1.1
410			$cell = $map->[$x][$y] \|\|= [];
411
412	root	1.10	if ($coord & 15) {
413	root	1.14	@$cell = () if $cell->[0] < 0;
414
415	root	1.10	$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	root	1.1
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	root	1.14	$self->{delayed_scroll_x} += $dx;
441			$self->{delayed_scroll_y} += $dy;
442	root	1.24
443			$self->map_scroll ($dx, $dy);
444	root	1.1	}
445
446			sub feed_newmap {
447			my ($self) = @_;
448
449			$self->{map} = [];
450			$self->{mapx} = 0;
451			$self->{mapy} = 0;
452
453	root	1.14	delete $self->{delayed_scroll_x};
454			delete $self->{delayed_scroll_y};
455
456	root	1.1	$self->map_clear;
457			}
458
459	root	1.22	sub feed_mapinfo {
460			my ($self, $data) = @_;
461	root	1.24
462			my ($token, @data) = split / /, $data;
463
464			(delete $self->{mapinfo_cb}{$token})->(@data)
465			if $self->{mapinfo_cb}{$token};
466	root	1.22
467	root	1.24	$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	root	1.22	}
478
479	root	1.1	sub feed_image {
480			my ($self, $data) = @_;
481
482	root	1.3	my ($num, $len, $data) = unpack "NNa*", $data;
483	root	1.1
484	root	1.22	$self->send_queue;
485	root	1.3	$self->{face}[$num]{image} = $data;
486	root	1.20	$self->face_update ($num, $self->{face}[$num]);
487	root	1.1
488	root	1.3	my @dirty;
489	root	1.2
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	root	1.6
497	root	1.2	$self->map_update (\@dirty);
498	root	1.1	}
499
500	root	1.24	=item $conn->map_change ($mode, ...) [OVERWRITE]
501	root	1.22
502			current <flags> <x> <y> <width> <height> <hashstring>
503
504			=cut
505
506			sub map_info { }
507
508	root	1.1	=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	root	1.20	=item $conn->face_update ($facenum, $facedata) [OVERWRITE]
534	root	1.1
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	root	1.23	=item $conn->face_find ($facenum, $facedata) [OVERWRITE]
543	root	1.3
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	root	1.1	=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	root	1.27	=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	root	1.26	sub send_command {
573			my ($self, $command) = @_;
574
575			utf8::encode $command;
576			$self->send ("command $command");
577			}
578
579	root	1.17	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	root	1.19	if ($self->{outstanding} < $self->{max_outstanding} && @{ $self->{send_queue} }) {
589	root	1.17	++$self->{outstanding};
590	root	1.19	$self->send (pop @{ $self->{send_queue} });
591	root	1.17	}
592			}
593
594	root	1.11	sub send_setup {
595			my ($self) = @_;
596
597			my $setup = join " ", setup => %{$self->{setup_req}},
598			mapsize => "$self->{mapw}x$self->{maph}";
599	root	1.15
600	root	1.11	$self->send ($setup);
601			}
602
603	root	1.1	=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