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 => 6,
      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} = sub {
      $self->send_queue;
      $cb->(@_);
   };
   $self->send_queue ("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 (shift @{ $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.32
Committed:	Thu Apr 20 07:13:09 2006 UTC (18 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.31:	+7 -4 lines
Log Message:	* empty log message *
#	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	root	1.32	max_outstanding => 6,
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	root	1.30
123			$self->addme_success ($data);
124	root	1.11	}
125
126			sub feed_addme_failure {
127			my ($self, $data) = @_;
128	root	1.30
129			$self->addme_failure ($data);
130	root	1.11	}
131
132	root	1.14	=back
133
134			=head2 METHODS THAT CAN/MUST BE OVERWRITTEN
135
136			=over 4
137
138	root	1.30	=item $self->addme_success
139
140			=item $self->addme_failure
141
142	root	1.14	=cut
143
144	root	1.30	sub addme_success { }
145			sub addme_failure { }
146
147	root	1.14	sub feed_face1 {
148			my ($self, $data) = @_;
149
150			my ($num, $chksum, $name) = unpack "nNa*", $data;
151
152	root	1.29	$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	root	1.14	my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };
161
162	root	1.23	if (my $data = $self->face_find ($num, $face)) {
163	root	1.14	$face->{image} = $data;
164	root	1.20	$self->face_update ($num, $face);
165	root	1.14	} else {
166	root	1.17	$self->send_queue ("askface $num");
167	root	1.14	}
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	root	1.28	=item $conn->sound_play ($x, $y, $soundnum, $type)
187	root	1.11
188			=cut
189
190			sub sound_play { }
191
192			sub feed_sound {
193			my ($self, $data) = @_;
194
195	root	1.28	$self->sound_play (unpack "ccnC", $data);
196	root	1.11	}
197
198	root	1.14	=item $conn->query ($flags, $prompt)
199	root	1.6
200			=cut
201
202	root	1.14	sub query { }
203	root	1.6
204	root	1.1	sub feed_query {
205			my ($self, $data) = @_;
206	root	1.6
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	root	1.1	}
219
220	root	1.14	=item $conn->drawinfo ($color, $text)
221
222			=cut
223
224			sub drawinfo { }
225
226			sub feed_drawinfo {
227			my ($self, $data) = @_;
228
229	root	1.25	my ($flags, $text) = split / /, $data, 2;
230
231			utf8::decode $text if utf8::valid $text;
232
233			$self->drawinfo ($flags, $text);
234	root	1.14	}
235
236			=item $conn->player_update ($player)
237	root	1.6
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	root	1.14	=item $conn->stats_update ($stats)
258	root	1.6
259			=cut
260
261			sub stats_update { }
262
263	root	1.1	sub feed_stats {
264			my ($self, $data) = @_;
265	root	1.6
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	root	1.31	my ($hi, $lo) = unpack "NN", substr $data, 0, 8, "";
279	root	1.6	$value = $hi * 2**32 + $lo;
280	root	1.31	} elsif (($stat >= 118 && $stat <= 129) \|\| ($stat >= 140 && $stat < 190)) {
281	root	1.6	my ($level, $lo, $hi) = unpack "CNN", substr $data, 0, 9, "";
282			$value = [$level, $hi * 2**32 + $lo];
283			} else {
284	root	1.31	$value = unpack "s", pack "S", unpack "n", substr $data, 0, 2, "";
285	root	1.6	}
286
287			$self->{stat}{$stat} = $value;
288			}
289
290			$self->stats_update ($self->{stat});
291	root	1.1	}
292
293	root	1.14	=item $conn->inventory_clear ($id)
294
295			=cut
296
297			sub inventory_clear { }
298
299			sub feed_delinv {
300	root	1.1	my ($self, $data) = @_;
301
302	root	1.14	$self->inventory_clear ($data);
303	root	1.3
304	root	1.14	delete $self->{inventory}[$data];
305	root	1.1	}
306
307	root	1.14	=item $conn->items_delete ($tag...)
308	root	1.6
309			=cut
310
311	root	1.14	sub items_delete { }
312	root	1.6
313	root	1.14	sub feed_delitem {
314	root	1.6	my ($self, $data) = @_;
315
316	root	1.14	$self->items_delete (unpack "n*", $data);
317			}
318
319			=item $conn->inventory_add ($id, [\%item...])
320	root	1.6
321	root	1.14	=cut
322	root	1.6
323	root	1.14	sub inventory_add {
324	root	1.6	}
325
326	root	1.14	sub feed_item2 {
327	root	1.1	my ($self, $data) = @_;
328	root	1.14
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	root	1.29	animspeed => $animspeed * $TICK, #???
348	root	1.14	nrof => $nrof,
349			type => $type,
350			};
351			}
352
353			$self->inventory_add ($location, \@items);
354	root	1.1	}
355
356	root	1.14	=item $conn->item_update ($tag)
357
358			=cut
359
360			sub item_update { }
361	root	1.1
362	root	1.14	sub feed_upditem {
363			#todo
364	root	1.29	#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	root	1.1	}
458
459			sub feed_map1a {
460			my ($self, $data) = @_;
461
462			my $map = $self->{map} \|\|= [];
463
464	root	1.14	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	root	1.16	unshift @$_, (undef) x -$self->{mapy} for @$map;
506	root	1.14	$self->{mapy} = 0;
507			}
508
509			if ($self->{mapx} < 0) {
510	root	1.16	unshift @$map, (undef) x -$self->{mapx};
511	root	1.14	$self->{mapx} = 0;
512			}
513
514			$self->map_scroll ($dx, $dy);
515			}
516
517	root	1.1	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	root	1.10	$x = (($coord >> 10) & 63) + $self->{mapx};
524			$y = (($coord >> 4) & 63) + $self->{mapy};
525	root	1.1
526			$cell = $map->[$x][$y] \|\|= [];
527
528	root	1.10	if ($coord & 15) {
529	root	1.14	@$cell = () if $cell->[0] < 0;
530
531	root	1.10	$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	root	1.1
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	root	1.14	$self->{delayed_scroll_x} += $dx;
557			$self->{delayed_scroll_y} += $dy;
558	root	1.24
559			$self->map_scroll ($dx, $dy);
560	root	1.1	}
561
562			sub feed_newmap {
563			my ($self) = @_;
564
565			$self->{map} = [];
566			$self->{mapx} = 0;
567			$self->{mapy} = 0;
568
569	root	1.14	delete $self->{delayed_scroll_x};
570			delete $self->{delayed_scroll_y};
571
572	root	1.1	$self->map_clear;
573			}
574
575	root	1.22	sub feed_mapinfo {
576			my ($self, $data) = @_;
577	root	1.24
578			my ($token, @data) = split / /, $data;
579
580			(delete $self->{mapinfo_cb}{$token})->(@data)
581			if $self->{mapinfo_cb}{$token};
582	root	1.22
583	root	1.24	$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	root	1.32	$self->{mapinfo_cb}{$token} = sub {
592			$self->send_queue;
593			$cb->(@_);
594			};
595			$self->send_queue ("mapinfo $token $data");
596	root	1.22	}
597
598	root	1.1	sub feed_image {
599			my ($self, $data) = @_;
600
601	root	1.3	my ($num, $len, $data) = unpack "NNa*", $data;
602	root	1.1
603	root	1.22	$self->send_queue;
604	root	1.3	$self->{face}[$num]{image} = $data;
605	root	1.20	$self->face_update ($num, $self->{face}[$num]);
606	root	1.1
607	root	1.3	my @dirty;
608	root	1.2
609			for my $x (0..$self->{mapw} - 1) {
610			for my $y (0..$self->{maph} - 1) {
611			push @dirty, [$x, $y]
612			if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
613			}
614			}
615	root	1.6
616	root	1.2	$self->map_update (\@dirty);
617	root	1.1	}
618
619	root	1.29	sub feed_replyinfo {
620			my ($self, $data) = @_;
621
622			if ($data =~ s/^image_sums \d+ \d+ //) {
623			my ($num, $chksum, $faceset, $name) = unpack "n N C C/Z*", $data;
624
625			$self->need_face ($num, $name, $chksum);
626			} elsif ($data =~ s/^skill_info\s+//) {
627			for (split /\012/, $data) {
628			my ($id, $name) = split /:/, $_, 2;
629			$self->{skill_info}{$id} = $name;
630			}
631			} elsif ($data =~ s/^spell_paths\s+//) {
632			for (split /\012/, $data) {
633			my ($id, $name) = split /:/, $_, 2;
634			$self->{spell_paths}{$id} = $name;
635			}
636			}
637			}
638
639	root	1.24	=item $conn->map_change ($mode, ...) [OVERWRITE]
640	root	1.22
641			current <flags> <x> <y> <width> <height> <hashstring>
642
643			=cut
644
645			sub map_info { }
646
647	root	1.1	=item $conn->map_clear [OVERWRITE]
648
649			Called whenever the map is to be erased completely.
650
651			=cut
652
653			sub map_clear { }
654
655			=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
656
657			Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
658			have been updated and need refreshing.
659
660			=cut
661
662			sub map_update { }
663
664			=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
665
666			Called whenever the map has been scrolled.
667
668			=cut
669
670			sub map_scroll { }
671
672	root	1.20	=item $conn->face_update ($facenum, $facedata) [OVERWRITE]
673	root	1.1
674			Called with the face number of face structure whenever a face image has
675			changed.
676
677			=cut
678
679			sub face_update { }
680
681	root	1.23	=item $conn->face_find ($facenum, $facedata) [OVERWRITE]
682	root	1.3
683			Find and return the png image for the given face, or the empty list if no
684			face could be found, in which case it will be requested from the server.
685
686			=cut
687
688			sub face_find { }
689
690	root	1.1	=item $conn->send ($data)
691
692			Send a single packet/line to the server.
693
694			=cut
695
696			sub send {
697			my ($self, $data) = @_;
698
699			$data = pack "na*", length $data, $data;
700
701			syswrite $self->{fh}, $data;
702			}
703
704	root	1.27	=item $conn->send_command ($command)
705
706			Uses either command or ncom to send a user-level command to the
707			server. Encodes the command to UTF-8.
708
709			=cut
710
711	root	1.26	sub send_command {
712			my ($self, $command) = @_;
713
714			utf8::encode $command;
715			$self->send ("command $command");
716			}
717
718	root	1.17	sub send_queue {
719			my ($self, $cmd) = @_;
720
721			if (defined $cmd) {
722			push @{ $self->{send_queue} }, $cmd;
723			} else {
724			--$self->{outstanding};
725			}
726
727	root	1.19	if ($self->{outstanding} < $self->{max_outstanding} && @{ $self->{send_queue} }) {
728	root	1.17	++$self->{outstanding};
729	root	1.32	$self->send (shift @{ $self->{send_queue} });
730	root	1.17	}
731			}
732
733	root	1.11	sub send_setup {
734			my ($self) = @_;
735
736			my $setup = join " ", setup => %{$self->{setup_req}},
737			mapsize => "$self->{mapw}x$self->{maph}";
738	root	1.15
739	root	1.11	$self->send ($setup);
740			}
741
742	root	1.1	=back
743
744			=head1 AUTHOR
745
746			Marc Lehmann <schmorp@schmorp.de>
747			http://home.schmorp.de/
748
749			Robin Redeker <elmex@ta-sa.org>
750			http://www.ta-sa.org/
751
752			=cut
753
754			1