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 ($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.30
Committed:	Wed Apr 19 09:38:51 2006 UTC (18 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.29:	+11 -1 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			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	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			my ($lo, $hi) = unpack "NN", substr $data, 0, 8, "";
279			$value = $hi * 2**32 + $lo;
280			} elsif ($stat >= 118 && $stat <= 129) {
281			my ($level, $lo, $hi) = unpack "CNN", substr $data, 0, 9, "";
282			$value = [$level, $hi * 2**32 + $lo];
283			} else {
284			$value = unpack "n", substr $data, 0, 2, "";
285			}
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			$self->{mapinfo_cb}{$token} = $cb;
592			$self->send ("mapinfo $token $data");
593	root	1.22	}
594
595	root	1.1	sub feed_image {
596			my ($self, $data) = @_;
597
598	root	1.3	my ($num, $len, $data) = unpack "NNa*", $data;
599	root	1.1
600	root	1.22	$self->send_queue;
601	root	1.3	$self->{face}[$num]{image} = $data;
602	root	1.20	$self->face_update ($num, $self->{face}[$num]);
603	root	1.1
604	root	1.3	my @dirty;
605	root	1.2
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	root	1.6
613	root	1.2	$self->map_update (\@dirty);
614	root	1.1	}
615
616	root	1.29	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	root	1.24	=item $conn->map_change ($mode, ...) [OVERWRITE]
637	root	1.22
638			current <flags> <x> <y> <width> <height> <hashstring>
639
640			=cut
641
642			sub map_info { }
643
644	root	1.1	=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	root	1.20	=item $conn->face_update ($facenum, $facedata) [OVERWRITE]
670	root	1.1
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	root	1.23	=item $conn->face_find ($facenum, $facedata) [OVERWRITE]
679	root	1.3
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	root	1.1	=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	root	1.27	=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	root	1.26	sub send_command {
709			my ($self, $command) = @_;
710
711			utf8::encode $command;
712			$self->send ("command $command");
713			}
714
715	root	1.17	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	root	1.19	if ($self->{outstanding} < $self->{max_outstanding} && @{ $self->{send_queue} }) {
725	root	1.17	++$self->{outstanding};
726	root	1.19	$self->send (pop @{ $self->{send_queue} });
727	root	1.17	}
728			}
729
730	root	1.11	sub send_setup {
731			my ($self) = @_;
732
733			my $setup = join " ", setup => %{$self->{setup_req}},
734			mapsize => "$self->{mapw}x$self->{maph}";
735	root	1.15
736	root	1.11	$self->send ($setup);
737			}
738
739	root	1.1	=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