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;

my $TICK = 0.120; # one server tick, not exposed through the protocol of course

=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,
      spellmon          => 1,
   };

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

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

   $self->addme_success ($data);
}

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

   $self->addme_failure ($data);
}

=back

=head2 METHODS THAT CAN/MUST BE OVERWRITTEN

=over 4

=item $self->addme_success

=item $self->addme_failure

=cut

sub addme_success { }
sub addme_failure { }

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

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

   $self->need_face ($num, $name, $chksum);
}

sub need_face {
   my ($self, $num, $name, $chksum) = @_;

   return if $self->{face}[$num];

   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 ($hi, $lo) = unpack "NN", substr $data, 0, 8, "";
         $value = $hi * 2**32 + $lo;
      } elsif (($stat >= 118 && $stat <= 129) || ($stat >= 140 && $stat < 190)) {
         my ($level, $lo, $hi) = unpack "CNN", substr $data, 0, 9, "";
         $value = [$level, $hi * 2**32 + $lo];
      } else {
         $value = unpack "s", pack "S", 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 * $TICK, #???
         nrof      => $nrof,
         type      => $type,
      };
   }

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

=item $conn->item_update ($tag)

=cut

sub item_update { }

sub feed_upditem {
   #todo
#define UPD_LOCATION    0x01
#define UPD_FLAGS       0x02
#define UPD_WEIGHT      0x04
#define UPD_FACE        0x08
#define UPD_NAME        0x10
#define UPD_ANIM        0x20
#define UPD_ANIMSPEED   0x40
#define UPD_NROF        0x80
}

=item $conn->spell_add ($spell)

      $spell = {
         tag          => ...,
         level        => ...,
         casting_time => ...,
         mana         => ...,
         grace        => ...,
         damage       => ...,
         skill        => ...,
         path         => ...,
         face         => ...,
         name         => ...,
         message      => ...,
      };

=item $conn->spell_update ($spell)

(the default implementation calls delete then add)

=item $conn->spell_delete ($spell)

=cut

sub spell_add { }

sub spell_update {
   my ($self, $spell) = @_;

   $self->spell_delete ($spell);
   $self->spell_add ($spell);
}

sub spell_delete { }

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

   my @data = unpack "(NnnnnnCNN C/a n/a)*", $data;

   while (@data) {
      my $spell = {
         tag          => (shift @data),
         level        => (shift @data),
         casting_time => (shift @data),
         mana         => (shift @data),
         grace        => (shift @data),
         damage       => (shift @data),
         skill        => (shift @data),
         path         => (shift @data),
         face         => (shift @data),
         name         => (shift @data),
         message      => (shift @data),
      };

      $self->send ("requestinfo image_sums $spell->{face} $spell->{face}")
         unless $self->{spell_face}[$spell->{face}]++;

      $self->spell_add ($self->{spell}{$spell->{tag}} = $spell);
   }
}

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

   my ($flags, $tag) = unpack "CN", substr $data, 0, 5, "";

   # only 1, 2, 4 supported
   # completely untested
   
   my $spell = $self->{spell}{$tag};

   $spell->{mana}   = unpack "n", substr $data, 0, 2, "" if $flags & 1;
   $spell->{grace}  = unpack "n", substr $data, 0, 2, "" if $flags & 2;
   $spell->{damage} = unpack "n", substr $data, 0, 2, "" if $flags & 4;
   
   $self->spell_update ($spell);
}

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

   $self->spell_delete (delete $self->{spell}{unpack "N", $data});
}

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

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

   if ($data =~ s/^image_sums \d+ \d+ //) {
      my ($num, $chksum, $faceset, $name) = unpack "n N C C/Z*", $data;

      $self->need_face ($num, $name, $chksum);
   } elsif ($data =~ s/^skill_info\s+//) {
      for (split /\012/, $data) {
         my ($id, $name) = split /:/, $_, 2;
         $self->{skill_info}{$id} = $name;
      }
   } elsif ($data =~ s/^spell_paths\s+//) {
      for (split /\012/, $data) {
         my ($id, $name) = split /:/, $_, 2;
         $self->{spell_paths}{$id} = $name;
      }
   }
}

=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.31
Committed:	Thu Apr 20 04:11:28 2006 UTC (18 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.30:	+3 -3 lines
Log Message:	fix skill experience stats
#	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	my $TICK = 0.120; # one server tick, not exposed through the protocol of course
27
28	=item new Crossfire::Protocol host => ..., port => ...
29
30	=cut
31
32	sub new {
33	my $class = shift;
34	my $self = bless {
35	mapw => 13,
36	maph => 13,
37	max_outstanding => 2,
38	token => "a0",
39	@_
40	}, $class;
41
42	$self->{fh} = new IO::Socket::INET PeerHost => $self->{host}, PeerPort => $self->{port}
43	or die "$self->{host}:$self->{port}: $!";
44	$self->{fh}->blocking (0); # stupid nonblock default
45
46	my $buf;
47
48	$self->{w} = AnyEvent->io (fh => $self->{fh}, poll => 'r', cb => sub {
49	if (sysread $self->{fh}, $buf, 16384, length $buf) {
50	for (;;) {
51	last unless 2 <= length $buf;
52	my $len = unpack "n", $buf;
53	last unless $len + 2 <= length $buf;
54
55	substr $buf, 0, 2, "";
56	$self->feed (substr $buf, 0, $len, "");
57	}
58	} else {
59	delete $self->{w};
60	close $self->{fh};
61	}
62	});
63
64	$self->{setup_req} = {
65	sound => 1,
66	exp64 => 1,
67	map1acmd => 1,
68	itemcmd => 2,
69	darkness => 1,
70	facecache => 1,
71	newmapcmd => 1,
72	mapinfocmd => 1,
73	plugincmd => 1,
74	extendedTextInfos => 1,
75	spellmon => 1,
76	};
77
78	$self->send ("version 1023 1027 perlclient");
79	$self->send_setup;
80	$self->send ("requestinfo skill_info");
81	$self->send ("requestinfo spell_paths");
82
83	$self
84	}
85
86	sub feed {
87	my ($self, $data) = @_;
88
89	$data =~ s/^(\S+)(?:\s\|$)//
90	or return;
91
92	my $command = "feed_$1";
93
94	$self->$command ($data);
95	}
96
97	sub feed_version {
98	my ($self, $version) = @_;
99	}
100
101	sub feed_setup {
102	my ($self, $data) = @_;
103
104	$data =~ s/^ +//;
105
106	$self->{setup} = { split / +/, $data };
107
108	my ($mapw, $maph) = split /x/, $self->{setup}{mapsize};
109
110	if ($mapw != $self->{mapw} \|\| $maph != $self->{maph}) {
111	($self->{mapw}, $self->{maph}) = ($mapw, $maph);
112	$self->send_setup;
113	} else {
114	$self->send ("addme");
115	}
116
117	$self->feed_newmap;
118	}
119
120	sub feed_addme_success {
121	my ($self, $data) = @_;
122
123	$self->addme_success ($data);
124	}
125
126	sub feed_addme_failure {
127	my ($self, $data) = @_;
128
129	$self->addme_failure ($data);
130	}
131
132	=back
133
134	=head2 METHODS THAT CAN/MUST BE OVERWRITTEN
135
136	=over 4
137
138	=item $self->addme_success
139
140	=item $self->addme_failure
141
142	=cut
143
144	sub addme_success { }
145	sub addme_failure { }
146
147	sub feed_face1 {
148	my ($self, $data) = @_;
149
150	my ($num, $chksum, $name) = unpack "nNa*", $data;
151
152	$self->need_face ($num, $name, $chksum);
153	}
154
155	sub need_face {
156	my ($self, $num, $name, $chksum) = @_;
157
158	return if $self->{face}[$num];
159
160	my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };
161
162	if (my $data = $self->face_find ($num, $face)) {
163	$face->{image} = $data;
164	$self->face_update ($num, $face);
165	} else {
166	$self->send_queue ("askface $num");
167	}
168	}
169
170	=item $conn->anim_update ($num) [OVERWRITE]
171
172	=cut
173
174	sub anim_update { }
175
176	sub feed_anim {
177	my ($self, $data) = @_;
178
179	my ($num, @faces) = unpack "n*", $data;
180
181	$self->{anim}[$num] = \@faces;
182
183	$self->anim_update ($num);
184	}
185
186	=item $conn->sound_play ($x, $y, $soundnum, $type)
187
188	=cut
189
190	sub sound_play { }
191
192	sub feed_sound {
193	my ($self, $data) = @_;
194
195	$self->sound_play (unpack "ccnC", $data);
196	}
197
198	=item $conn->query ($flags, $prompt)
199
200	=cut
201
202	sub query { }
203
204	sub feed_query {
205	my ($self, $data) = @_;
206
207	my ($flags, $prompt) = split /\s+/, $data, 2;
208
209	if ($flags == 0 && $prompt =~ /^What is your name\?\s+:$/ && length $self->{user}) {
210	$self->send ("reply $self->{user}");
211	} elsif ($flags == 4 && $prompt =~ /^What is your password\?\s+:$/ && length $self->{pass}) {
212	$self->send ("reply $self->{pass}");
213	} elsif ($flags == 4 && $prompt =~ /^Please type your password again\.\s+:$/ && length $self->{pass}) {
214	$self->send ("reply $self->{pass}");
215	} else {
216	$self->query ($flags, $prompt);
217	}
218	}
219
220	=item $conn->drawinfo ($color, $text)
221
222	=cut
223
224	sub drawinfo { }
225
226	sub feed_drawinfo {
227	my ($self, $data) = @_;
228
229	my ($flags, $text) = split / /, $data, 2;
230
231	utf8::decode $text if utf8::valid $text;
232
233	$self->drawinfo ($flags, $text);
234	}
235
236	=item $conn->player_update ($player)
237
238	tag, weight, face, name
239
240	=cut
241
242	sub player_update { }
243
244	sub feed_player {
245	my ($self, $data) = @_;
246
247	my ($tag, $weight, $face, $name) = unpack "NNN C/a", $data;
248
249	$self->player_update ($self->{player} = {
250	tag => $tag,
251	weight => $weight,
252	face => $face,
253	name => $name,
254	});
255	}
256
257	=item $conn->stats_update ($stats)
258
259	=cut
260
261	sub stats_update { }
262
263	sub feed_stats {
264	my ($self, $data) = @_;
265
266	while (length $data) {
267	my $stat = unpack "C", substr $data, 0, 1, "";
268	my $value;
269
270	if ($stat == 26 \|\| $stat == 29 \|\| $stat == 30 \|\| $stat == 31 \|\| $stat == 11) {
271	$value = unpack "N", substr $data, 0, 4, "";
272	} elsif ($stat == 17 \|\| $stat == 19) {
273	$value = (1 / 100000) * unpack "N", substr $data, 0, 4, "";
274	} elsif ($stat == 20 \|\| $stat == 21) {
275	my $len = unpack "C", substr $data, 0, 1, "";
276	$value = substr $data, 0, $len, "";
277	} elsif ($stat == 28) {
278	my ($hi, $lo) = unpack "NN", substr $data, 0, 8, "";
279	$value = $hi * 2**32 + $lo;
280	} elsif (($stat >= 118 && $stat <= 129) \|\| ($stat >= 140 && $stat < 190)) {
281	my ($level, $lo, $hi) = unpack "CNN", substr $data, 0, 9, "";
282	$value = [$level, $hi * 2**32 + $lo];
283	} else {
284	$value = unpack "s", pack "S", unpack "n", substr $data, 0, 2, "";
285	}
286
287	$self->{stat}{$stat} = $value;
288	}
289
290	$self->stats_update ($self->{stat});
291	}
292
293	=item $conn->inventory_clear ($id)
294
295	=cut
296
297	sub inventory_clear { }
298
299	sub feed_delinv {
300	my ($self, $data) = @_;
301
302	$self->inventory_clear ($data);
303
304	delete $self->{inventory}[$data];
305	}
306
307	=item $conn->items_delete ($tag...)
308
309	=cut
310
311	sub items_delete { }
312
313	sub feed_delitem {
314	my ($self, $data) = @_;
315
316	$self->items_delete (unpack "n*", $data);
317	}
318
319	=item $conn->inventory_add ($id, [\%item...])
320
321	=cut
322
323	sub inventory_add {
324	}
325
326	sub feed_item2 {
327	my ($self, $data) = @_;
328
329	my ($location, @values) = unpack "N (NNNN C/a* nC Nn)*", $data;
330
331	my @items;
332
333	while (@values) {
334	my ($tag, $flags, $weight, $face, $names, $anim, $animspeed, $nrof, $type) =
335	splice @values, 0, 9, ();
336
337	my ($name, $name_pl) = split /\x000/, $names;
338
339	push @items, {
340	tag => $tag,
341	flags => $flags,
342	weight => $weight,
343	face => $face,
344	name => $name,
345	name_pl => $name_pl,
346	anim => $anim,
347	animspeed => $animspeed * $TICK, #???
348	nrof => $nrof,
349	type => $type,
350	};
351	}
352
353	$self->inventory_add ($location, \@items);
354	}
355
356	=item $conn->item_update ($tag)
357
358	=cut
359
360	sub item_update { }
361
362	sub feed_upditem {
363	#todo
364	#define UPD_LOCATION 0x01
365	#define UPD_FLAGS 0x02
366	#define UPD_WEIGHT 0x04
367	#define UPD_FACE 0x08
368	#define UPD_NAME 0x10
369	#define UPD_ANIM 0x20
370	#define UPD_ANIMSPEED 0x40
371	#define UPD_NROF 0x80
372	}
373
374	=item $conn->spell_add ($spell)
375
376	$spell = {
377	tag => ...,
378	level => ...,
379	casting_time => ...,
380	mana => ...,
381	grace => ...,
382	damage => ...,
383	skill => ...,
384	path => ...,
385	face => ...,
386	name => ...,
387	message => ...,
388	};
389
390	=item $conn->spell_update ($spell)
391
392	(the default implementation calls delete then add)
393
394	=item $conn->spell_delete ($spell)
395
396	=cut
397
398	sub spell_add { }
399
400	sub spell_update {
401	my ($self, $spell) = @_;
402
403	$self->spell_delete ($spell);
404	$self->spell_add ($spell);
405	}
406
407	sub spell_delete { }
408
409	sub feed_addspell {
410	my ($self, $data) = @_;
411
412	my @data = unpack "(NnnnnnCNN C/a n/a)*", $data;
413
414	while (@data) {
415	my $spell = {
416	tag => (shift @data),
417	level => (shift @data),
418	casting_time => (shift @data),
419	mana => (shift @data),
420	grace => (shift @data),
421	damage => (shift @data),
422	skill => (shift @data),
423	path => (shift @data),
424	face => (shift @data),
425	name => (shift @data),
426	message => (shift @data),
427	};
428
429	$self->send ("requestinfo image_sums $spell->{face} $spell->{face}")
430	unless $self->{spell_face}[$spell->{face}]++;
431
432	$self->spell_add ($self->{spell}{$spell->{tag}} = $spell);
433	}
434	}
435
436	sub feed_updspell {
437	my ($self, $data) = @_;
438
439	my ($flags, $tag) = unpack "CN", substr $data, 0, 5, "";
440
441	# only 1, 2, 4 supported
442	# completely untested
443
444	my $spell = $self->{spell}{$tag};
445
446	$spell->{mana} = unpack "n", substr $data, 0, 2, "" if $flags & 1;
447	$spell->{grace} = unpack "n", substr $data, 0, 2, "" if $flags & 2;
448	$spell->{damage} = unpack "n", substr $data, 0, 2, "" if $flags & 4;
449
450	$self->spell_update ($spell);
451	}
452
453	sub feed_delspell {
454	my ($self, $data) = @_;
455
456	$self->spell_delete (delete $self->{spell}{unpack "N", $data});
457	}
458
459	sub feed_map1a {
460	my ($self, $data) = @_;
461
462	my $map = $self->{map} \|\|= [];
463
464	my ($dx, $dy) = delete @$self{qw(delayed_scroll_x delayed_scroll_y)};
465
466	if ($dx \|\| $dy) {
467	my ($mx, $my, $mw, $mh) = @$self{qw(mapx mapy mapw maph)};
468
469	{
470	my @darkness;
471
472	if ($dx > 0) {
473	push @darkness, [$mx, $my, $dx - 1, $mh];
474	} elsif ($dx < 0) {
475	push @darkness, [$mx + $mw + $dx + 1, $my, 1 - $dx, $mh];
476	}
477
478	if ($dy > 0) {
479	push @darkness, [$mx, $my, $mw, $dy - 1];
480	} elsif ($dy < 0) {
481	push @darkness, [$mx, $my + $mh + $dy + 1, $mw, 1 - $dy];
482	}
483
484	for (@darkness) {
485	my ($x0, $y0, $w, $h) = @$_;
486	for my $x ($x0 .. $x0 + $w) {
487	for my $y ($y0 .. $y0 + $h) {
488
489	my $cell = $map->[$x][$y]
490	or next;
491
492	$cell->[0] = -1;
493	}
494	}
495	}
496	}
497
498	# now scroll
499
500	$self->{mapx} += $dx;
501	$self->{mapy} += $dy;
502
503	# shift in new space if moving to "negative indices"
504	if ($self->{mapy} < 0) {
505	unshift @$_, (undef) x -$self->{mapy} for @$map;
506	$self->{mapy} = 0;
507	}
508
509	if ($self->{mapx} < 0) {
510	unshift @$map, (undef) x -$self->{mapx};
511	$self->{mapx} = 0;
512	}
513
514	$self->map_scroll ($dx, $dy);
515	}
516
517	my @dirty;
518	my ($coord, $x, $y, $darkness, $fa, $fb, $fc, $cell);
519
520	while (length $data) {
521	$coord = unpack "n", substr $data, 0, 2, "";
522
523	$x = (($coord >> 10) & 63) + $self->{mapx};
524	$y = (($coord >> 4) & 63) + $self->{mapy};
525
526	$cell = $map->[$x][$y] \|\|= [];
527
528	if ($coord & 15) {
529	@$cell = () if $cell->[0] < 0;
530
531	$cell->[0] = $coord & 8
532	? unpack "C", substr $data, 0, 1, ""
533	: 255;
534
535	$cell->[1] = unpack "n", substr $data, 0, 2, ""
536	if $coord & 4;
537	$cell->[2] = unpack "n", substr $data, 0, 2, ""
538	if $coord & 2;
539	$cell->[3] = unpack "n", substr $data, 0, 2, ""
540	if $coord & 1;
541	} else {
542	$cell->[0] = -1;
543	}
544
545	push @dirty, [$x, $y];
546	}
547
548	$self->map_update (\@dirty);
549	}
550
551	sub feed_map_scroll {
552	my ($self, $data) = @_;
553
554	my ($dx, $dy) = split / /, $data;
555
556	$self->{delayed_scroll_x} += $dx;
557	$self->{delayed_scroll_y} += $dy;
558
559	$self->map_scroll ($dx, $dy);
560	}
561
562	sub feed_newmap {
563	my ($self) = @_;
564
565	$self->{map} = [];
566	$self->{mapx} = 0;
567	$self->{mapy} = 0;
568
569	delete $self->{delayed_scroll_x};
570	delete $self->{delayed_scroll_y};
571
572	$self->map_clear;
573	}
574
575	sub feed_mapinfo {
576	my ($self, $data) = @_;
577
578	my ($token, @data) = split / /, $data;
579
580	(delete $self->{mapinfo_cb}{$token})->(@data)
581	if $self->{mapinfo_cb}{$token};
582
583	$self->map_change (@data) if $token eq "-";
584	}
585
586	sub send_mapinfo {
587	my ($self, $data, $cb) = @_;
588
589	my $token = ++$self->{token};
590
591	$self->{mapinfo_cb}{$token} = $cb;
592	$self->send ("mapinfo $token $data");
593	}
594
595	sub feed_image {
596	my ($self, $data) = @_;
597
598	my ($num, $len, $data) = unpack "NNa*", $data;
599
600	$self->send_queue;
601	$self->{face}[$num]{image} = $data;
602	$self->face_update ($num, $self->{face}[$num]);
603
604	my @dirty;
605
606	for my $x (0..$self->{mapw} - 1) {
607	for my $y (0..$self->{maph} - 1) {
608	push @dirty, [$x, $y]
609	if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
610	}
611	}
612
613	$self->map_update (\@dirty);
614	}
615
616	sub feed_replyinfo {
617	my ($self, $data) = @_;
618
619	if ($data =~ s/^image_sums \d+ \d+ //) {
620	my ($num, $chksum, $faceset, $name) = unpack "n N C C/Z*", $data;
621
622	$self->need_face ($num, $name, $chksum);
623	} elsif ($data =~ s/^skill_info\s+//) {
624	for (split /\012/, $data) {
625	my ($id, $name) = split /:/, $_, 2;
626	$self->{skill_info}{$id} = $name;
627	}
628	} elsif ($data =~ s/^spell_paths\s+//) {
629	for (split /\012/, $data) {
630	my ($id, $name) = split /:/, $_, 2;
631	$self->{spell_paths}{$id} = $name;
632	}
633	}
634	}
635
636	=item $conn->map_change ($mode, ...) [OVERWRITE]
637
638	current <flags> <x> <y> <width> <height> <hashstring>
639
640	=cut
641
642	sub map_info { }
643
644	=item $conn->map_clear [OVERWRITE]
645
646	Called whenever the map is to be erased completely.
647
648	=cut
649
650	sub map_clear { }
651
652	=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
653
654	Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
655	have been updated and need refreshing.
656
657	=cut
658
659	sub map_update { }
660
661	=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
662
663	Called whenever the map has been scrolled.
664
665	=cut
666
667	sub map_scroll { }
668
669	=item $conn->face_update ($facenum, $facedata) [OVERWRITE]
670
671	Called with the face number of face structure whenever a face image has
672	changed.
673
674	=cut
675
676	sub face_update { }
677
678	=item $conn->face_find ($facenum, $facedata) [OVERWRITE]
679
680	Find and return the png image for the given face, or the empty list if no
681	face could be found, in which case it will be requested from the server.
682
683	=cut
684
685	sub face_find { }
686
687	=item $conn->send ($data)
688
689	Send a single packet/line to the server.
690
691	=cut
692
693	sub send {
694	my ($self, $data) = @_;
695
696	$data = pack "na*", length $data, $data;
697
698	syswrite $self->{fh}, $data;
699	}
700
701	=item $conn->send_command ($command)
702
703	Uses either command or ncom to send a user-level command to the
704	server. Encodes the command to UTF-8.
705
706	=cut
707
708	sub send_command {
709	my ($self, $command) = @_;
710
711	utf8::encode $command;
712	$self->send ("command $command");
713	}
714
715	sub send_queue {
716	my ($self, $cmd) = @_;
717
718	if (defined $cmd) {
719	push @{ $self->{send_queue} }, $cmd;
720	} else {
721	--$self->{outstanding};
722	}
723
724	if ($self->{outstanding} < $self->{max_outstanding} && @{ $self->{send_queue} }) {
725	++$self->{outstanding};
726	$self->send (pop @{ $self->{send_queue} });
727	}
728	}
729
730	sub send_setup {
731	my ($self) = @_;
732
733	my $setup = join " ", setup => %{$self->{setup_req}},
734	mapsize => "$self->{mapw}x$self->{maph}";
735
736	$self->send ($setup);
737	}
738
739	=back
740
741	=head1 AUTHOR
742
743	Marc Lehmann <schmorp@schmorp.de>
744	http://home.schmorp.de/
745
746	Robin Redeker <elmex@ta-sa.org>
747	http://www.ta-sa.org/
748
749	=cut
750
751	1