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

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;

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