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;

BEGIN {
   my %CONSTANTS = (
      TICK              => 0.120, # one server tick, not exposed through the protocol of course
      CS_QUERY_YESNO    => 0x1,
      CS_QUERY_SINGLECHAR       => 0x2,
      CS_QUERY_HIDEINPUT        => 0x4,
      CS_SAY_NORMAL     => 0x1,
      CS_SAY_SHOUT      => 0x2,
      CS_SAY_GSAY       => 0x4,
      FLOAT_MULTI       => 100000,
      FLOAT_MULTF       => 100000.0,
      CS_STAT_HP        => 1,
      CS_STAT_MAXHP     => 2,
      CS_STAT_SP        => 3,
      CS_STAT_MAXSP     => 4,
      CS_STAT_STR       => 5,
      CS_STAT_INT       => 6,
      CS_STAT_WIS       => 7,
      CS_STAT_DEX       => 8,
      CS_STAT_CON       => 9,
      CS_STAT_CHA       => 10,
      CS_STAT_EXP       => 11,
      CS_STAT_LEVEL     => 12,
      CS_STAT_WC        => 13,
      CS_STAT_AC        => 14,
      CS_STAT_DAM       => 15,
      CS_STAT_ARMOUR    => 16,
      CS_STAT_SPEED     => 17,
      CS_STAT_FOOD      => 18,
      CS_STAT_WEAP_SP   => 19,
      CS_STAT_RANGE     => 20,
      CS_STAT_TITLE     => 21,
      CS_STAT_POW       => 22,
      CS_STAT_GRACE     => 23,
      CS_STAT_MAXGRACE  => 24,
      CS_STAT_FLAGS     => 25,
      CS_STAT_WEIGHT_LIM        => 26,
      CS_STAT_EXP64     => 28,
      CS_STAT_SPELL_ATTUNE      => 29,
      CS_STAT_SPELL_REPEL       => 30,
      CS_STAT_SPELL_DENY        => 31,
      CS_STAT_RESIST_START      => 100,
      CS_STAT_RESIST_END        => 117,
      CS_STAT_RES_PHYS  => 100,
      CS_STAT_RES_MAG   => 101,
      CS_STAT_RES_FIRE  => 102,
      CS_STAT_RES_ELEC  => 103,
      CS_STAT_RES_COLD  => 104,
      CS_STAT_RES_CONF  => 105,
      CS_STAT_RES_ACID  => 106,
      CS_STAT_RES_DRAIN => 107,
      CS_STAT_RES_GHOSTHIT      => 108,
      CS_STAT_RES_POISON        => 109,
      CS_STAT_RES_SLOW  => 110,
      CS_STAT_RES_PARA  => 111,
      CS_STAT_TURN_UNDEAD       => 112,
      CS_STAT_RES_FEAR  => 113,
      CS_STAT_RES_DEPLETE       => 114,
      CS_STAT_RES_DEATH => 115,
      CS_STAT_RES_HOLYWORD      => 116,
      CS_STAT_RES_BLIND => 117,
      CS_STAT_SKILLEXP_START    => 118,
      CS_STAT_SKILLEXP_END      => 129,
      CS_STAT_SKILLEXP_AGILITY  => 118,
      CS_STAT_SKILLEXP_AGLEVEL  => 119,
      CS_STAT_SKILLEXP_PERSONAL => 120,
      CS_STAT_SKILLEXP_PELEVEL  => 121,
      CS_STAT_SKILLEXP_MENTAL   => 122,
      CS_STAT_SKILLEXP_MELEVEL  => 123,
      CS_STAT_SKILLEXP_PHYSIQUE => 124,
      CS_STAT_SKILLEXP_PHLEVEL  => 125,
      CS_STAT_SKILLEXP_MAGIC    => 126,
      CS_STAT_SKILLEXP_MALEVEL  => 127,
      CS_STAT_SKILLEXP_WISDOM   => 128,
      CS_STAT_SKILLEXP_WILEVEL  => 129,
      CS_STAT_SKILLINFO => 140,
      CS_NUM_SKILLS     => 50,
      SF_FIREON         => 0x01,
      SF_RUNON          => 0x02,
      NDI_BLACK         => 0,
      NDI_WHITE         => 1,
      NDI_NAVY          => 2,
      NDI_RED           => 3,
      NDI_ORANGE        => 4,
      NDI_BLUE          => 5,
      NDI_DK_ORANGE     => 6,
      NDI_GREEN         => 7,
      NDI_LT_GREEN      => 8,
      NDI_GREY          => 9,
      NDI_BROWN         => 10,
      NDI_GOLD          => 11,
      NDI_TAN           => 12,
      NDI_MAX_COLOR     => 12,
      NDI_COLOR_MASK    => 0xff,
      NDI_UNIQUE        => 0x100,
      NDI_ALL           => 0x200,
      a_none            => 0,
      a_readied         => 1,
      a_wielded         => 2,
      a_worn            => 3,
      a_active          => 4,
      a_applied         => 5,
      F_APPLIED         => 0x000F,
      F_LOCATION        => 0x00F0,
      F_UNPAID          => 0x0200,
      F_MAGIC           => 0x0400,
      F_CURSED          => 0x0800,
      F_DAMNED          => 0x1000,
      F_OPEN            => 0x2000,
      F_NOPICK          => 0x4000,
      F_LOCKED          => 0x8000,
      CF_FACE_NONE      => 0,
      CF_FACE_BITMAP    => 1,
      CF_FACE_XPM       => 2,
      CF_FACE_PNG       => 3,
      CF_FACE_CACHE     => 0x10,
      FACE_FLOOR        => 0x80,
      FACE_COLOR_MASK   => 0xf,
      UPD_LOCATION      => 0x01,
      UPD_FLAGS         => 0x02,
      UPD_WEIGHT        => 0x04,
      UPD_FACE          => 0x08,
      UPD_NAME          => 0x10,
      UPD_ANIM          => 0x20,
      UPD_ANIMSPEED     => 0x40,
      UPD_NROF          => 0x80,
      UPD_SP_MANA       => 0x01,
      UPD_SP_GRACE      => 0x02,
      UPD_SP_DAMAGE     => 0x04,
      SOUND_NORMAL      => 0,
      SOUND_SPELL       => 1,
   );

   while (my ($k, $v) = each %CONSTANTS) {
      eval "sub $k () { $v } 1"
         or die;
   }
}

=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 { }

my %stat_32bit = map +($_ => 1),
   CS_STAT_WEIGHT_LIM,
   CS_STAT_SPELL_ATTUNE,
   CS_STAT_SPELL_REPEL,
   CS_STAT_SPELL_DENY,
   CS_STAT_EXP;

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

   while (length $data) {
      my $stat = unpack "C", substr $data, 0, 1, "";
      my $value;

      if ($stat_32bit{$stat}) {
         $value = unpack "N", substr $data, 0, 4, "";
      } elsif ($stat == CS_STAT_SPEED || $stat == CS_STAT_WEAP_SP) {
         $value = (1 / FLOAT_MULTF) * unpack "N", substr $data, 0, 4, "";
      } elsif ($stat == CS_STAT_RANGE || $stat == CS_STAT_TITLE) {
         my $len = unpack "C", substr $data, 0, 1, "";
         $value = substr $data, 0, $len, "";
      } elsif ($stat == CS_STAT_EXP64) {
         my ($hi, $lo) = unpack "NN", substr $data, 0, 8, "";
         $value = $hi * 2**32 + $lo;
      } elsif (($stat >= CS_STAT_SKILLEXP_START && $stat <= CS_STAT_SKILLEXP_END)
               || ($stat >= CS_STAT_SKILLINFO && $stat < CS_STAT_SKILLINFO + CS_NUM_SKILLS)) {
         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->container_add ($id, $item...)

=item $conn->container_clear ($id)

=item $conn->item_update ($item)

=item $conn->item_delete ($item...)

=cut

sub container_add { }
sub container_clear { }
sub item_delete { }
sub item_update { }

sub _del_items {
   my ($self, @items) = @_;

   for my $item (@items) {
      delete $self->{item}{$item->{tag}};
      delete $self->{container}{$item->{container}}{$item->{tag}};
   }
}

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

   $self->_del_items (values %{ $self->{container}{$data} });
   $self->container_clear ($data);
}

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

   my @items = map $self->{item}{$_}, unpack "N*", $data;
   $self->_del_items (@items);
   $self->item_delete (@items);
}

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, ();

      utf8::decode $names if utf8::valid $names;
      my ($name, $name_pl) = split /\x00/, $names;

      my $item = {
         container => $location,
         tag       => $tag,
         flags     => $flags,
         weight    => $weight,
         face      => $face,
         name      => $name,
         name_pl   => $name_pl,
         anim      => $anim,
         animspeed => $animspeed * TICK, #???
         nrof      => $nrof,
         type      => $type,
      };

      $self->{item}{$tag} = $item;
      $self->{container}{$location}{$tag} = $item;
      push @items, $item;
   }

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

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

   my ($flags, $tag) = unpack "NN", substr $data, 0, 8, "";

   my $item = $self->{item}{$tag};

   if ($flags & UPD_LOCATION) {
      $self->item_delete ($item);
      delete $self->{container}{$item->{container}}{$tag};

      $item->{container} = unpack "N", substr $data, 0, 4, "";

      $self->{container}{$item->{container}}{$tag} = $item;
      $self->container_add ($item->{location}, $item);
   }

   $item->{flags}  = unpack "N", substr $data, 0, 4, "" if $flags & UPD_FLAGS;
   $item->{weight} = unpack "N", substr $data, 0, 4, "" if $flags & UPD_WEIGHT;
   $item->{face}   = unpack "N", substr $data, 0, 4, "" if $flags & UPD_FACE;

   if ($flags & UPD_NAME) {
      my $len = unpack "C", substr $data, 0, 1, "";

      my $names = substr $data, 0, $len, "";
      utf8::decode $names if utf8::valid $names;
      @$item{qw(name name_pl)} = split /\x00/, $names;
   }

   $item->{anim}   = unpack "n", substr $data, 0, 2, "" if $flags & UPD_ANIM;
   $item->{animspeed} = TICK * unpack "C", substr $data, 0, 1, "" if $flags & UPD_ANIMSPEED;
   $item->{nrof}   = unpack "N", substr $data, 0, 4, "" if $flags & UPD_NROF;

   $self->item_update ($item);
}

=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 & UPD_SP_MANA;
   $spell->{grace}  = unpack "n", substr $data, 0, 2, "" if $flags & UPD_SP_GRACE;
   $spell->{damage} = unpack "n", substr $data, 0, 2, "" if $flags & UPD_SP_DAMAGE;
   
   $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.33
Committed:	Sun Apr 23 23:57:13 2006 UTC (18 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.32:	+221 -46 lines
Log Message:	implement container/item handling, expose lots of protocol constants, the container protocol indeed sucks
#	Content
1	=head1 NAME
2
3	Crossfire::Protocol - client protocol module
4
5	=head1 SYNOPSIS
6
7	use base Crossfire::Protocol; # you have to subclass
8
9	=head1 DESCRIPTION
10
11	Base class to implement a corssfire client.
12
13	=over 4
14
15	=cut
16
17	package Crossfire::Protocol;
18
19	our $VERSION = '0.1';
20
21	use strict;
22
23	use AnyEvent;
24	use IO::Socket::INET;
25
26	BEGIN {
27	my %CONSTANTS = (
28	TICK => 0.120, # one server tick, not exposed through the protocol of course
29	CS_QUERY_YESNO => 0x1,
30	CS_QUERY_SINGLECHAR => 0x2,
31	CS_QUERY_HIDEINPUT => 0x4,
32	CS_SAY_NORMAL => 0x1,
33	CS_SAY_SHOUT => 0x2,
34	CS_SAY_GSAY => 0x4,
35	FLOAT_MULTI => 100000,
36	FLOAT_MULTF => 100000.0,
37	CS_STAT_HP => 1,
38	CS_STAT_MAXHP => 2,
39	CS_STAT_SP => 3,
40	CS_STAT_MAXSP => 4,
41	CS_STAT_STR => 5,
42	CS_STAT_INT => 6,
43	CS_STAT_WIS => 7,
44	CS_STAT_DEX => 8,
45	CS_STAT_CON => 9,
46	CS_STAT_CHA => 10,
47	CS_STAT_EXP => 11,
48	CS_STAT_LEVEL => 12,
49	CS_STAT_WC => 13,
50	CS_STAT_AC => 14,
51	CS_STAT_DAM => 15,
52	CS_STAT_ARMOUR => 16,
53	CS_STAT_SPEED => 17,
54	CS_STAT_FOOD => 18,
55	CS_STAT_WEAP_SP => 19,
56	CS_STAT_RANGE => 20,
57	CS_STAT_TITLE => 21,
58	CS_STAT_POW => 22,
59	CS_STAT_GRACE => 23,
60	CS_STAT_MAXGRACE => 24,
61	CS_STAT_FLAGS => 25,
62	CS_STAT_WEIGHT_LIM => 26,
63	CS_STAT_EXP64 => 28,
64	CS_STAT_SPELL_ATTUNE => 29,
65	CS_STAT_SPELL_REPEL => 30,
66	CS_STAT_SPELL_DENY => 31,
67	CS_STAT_RESIST_START => 100,
68	CS_STAT_RESIST_END => 117,
69	CS_STAT_RES_PHYS => 100,
70	CS_STAT_RES_MAG => 101,
71	CS_STAT_RES_FIRE => 102,
72	CS_STAT_RES_ELEC => 103,
73	CS_STAT_RES_COLD => 104,
74	CS_STAT_RES_CONF => 105,
75	CS_STAT_RES_ACID => 106,
76	CS_STAT_RES_DRAIN => 107,
77	CS_STAT_RES_GHOSTHIT => 108,
78	CS_STAT_RES_POISON => 109,
79	CS_STAT_RES_SLOW => 110,
80	CS_STAT_RES_PARA => 111,
81	CS_STAT_TURN_UNDEAD => 112,
82	CS_STAT_RES_FEAR => 113,
83	CS_STAT_RES_DEPLETE => 114,
84	CS_STAT_RES_DEATH => 115,
85	CS_STAT_RES_HOLYWORD => 116,
86	CS_STAT_RES_BLIND => 117,
87	CS_STAT_SKILLEXP_START => 118,
88	CS_STAT_SKILLEXP_END => 129,
89	CS_STAT_SKILLEXP_AGILITY => 118,
90	CS_STAT_SKILLEXP_AGLEVEL => 119,
91	CS_STAT_SKILLEXP_PERSONAL => 120,
92	CS_STAT_SKILLEXP_PELEVEL => 121,
93	CS_STAT_SKILLEXP_MENTAL => 122,
94	CS_STAT_SKILLEXP_MELEVEL => 123,
95	CS_STAT_SKILLEXP_PHYSIQUE => 124,
96	CS_STAT_SKILLEXP_PHLEVEL => 125,
97	CS_STAT_SKILLEXP_MAGIC => 126,
98	CS_STAT_SKILLEXP_MALEVEL => 127,
99	CS_STAT_SKILLEXP_WISDOM => 128,
100	CS_STAT_SKILLEXP_WILEVEL => 129,
101	CS_STAT_SKILLINFO => 140,
102	CS_NUM_SKILLS => 50,
103	SF_FIREON => 0x01,
104	SF_RUNON => 0x02,
105	NDI_BLACK => 0,
106	NDI_WHITE => 1,
107	NDI_NAVY => 2,
108	NDI_RED => 3,
109	NDI_ORANGE => 4,
110	NDI_BLUE => 5,
111	NDI_DK_ORANGE => 6,
112	NDI_GREEN => 7,
113	NDI_LT_GREEN => 8,
114	NDI_GREY => 9,
115	NDI_BROWN => 10,
116	NDI_GOLD => 11,
117	NDI_TAN => 12,
118	NDI_MAX_COLOR => 12,
119	NDI_COLOR_MASK => 0xff,
120	NDI_UNIQUE => 0x100,
121	NDI_ALL => 0x200,
122	a_none => 0,
123	a_readied => 1,
124	a_wielded => 2,
125	a_worn => 3,
126	a_active => 4,
127	a_applied => 5,
128	F_APPLIED => 0x000F,
129	F_LOCATION => 0x00F0,
130	F_UNPAID => 0x0200,
131	F_MAGIC => 0x0400,
132	F_CURSED => 0x0800,
133	F_DAMNED => 0x1000,
134	F_OPEN => 0x2000,
135	F_NOPICK => 0x4000,
136	F_LOCKED => 0x8000,
137	CF_FACE_NONE => 0,
138	CF_FACE_BITMAP => 1,
139	CF_FACE_XPM => 2,
140	CF_FACE_PNG => 3,
141	CF_FACE_CACHE => 0x10,
142	FACE_FLOOR => 0x80,
143	FACE_COLOR_MASK => 0xf,
144	UPD_LOCATION => 0x01,
145	UPD_FLAGS => 0x02,
146	UPD_WEIGHT => 0x04,
147	UPD_FACE => 0x08,
148	UPD_NAME => 0x10,
149	UPD_ANIM => 0x20,
150	UPD_ANIMSPEED => 0x40,
151	UPD_NROF => 0x80,
152	UPD_SP_MANA => 0x01,
153	UPD_SP_GRACE => 0x02,
154	UPD_SP_DAMAGE => 0x04,
155	SOUND_NORMAL => 0,
156	SOUND_SPELL => 1,
157	);
158
159	while (my ($k, $v) = each %CONSTANTS) {
160	eval "sub $k () { $v } 1"
161	or die;
162	}
163	}
164
165	=item new Crossfire::Protocol host => ..., port => ...
166
167	=cut
168
169	sub new {
170	my $class = shift;
171	my $self = bless {
172	mapw => 13,
173	maph => 13,
174	max_outstanding => 2,
175	token => "a0",
176	@_
177	}, $class;
178
179	$self->{fh} = new IO::Socket::INET PeerHost => $self->{host}, PeerPort => $self->{port}
180	or die "$self->{host}:$self->{port}: $!";
181	$self->{fh}->blocking (0); # stupid nonblock default
182
183	my $buf;
184
185	$self->{w} = AnyEvent->io (fh => $self->{fh}, poll => 'r', cb => sub {
186	if (sysread $self->{fh}, $buf, 16384, length $buf) {
187	for (;;) {
188	last unless 2 <= length $buf;
189	my $len = unpack "n", $buf;
190	last unless $len + 2 <= length $buf;
191
192	substr $buf, 0, 2, "";
193	$self->feed (substr $buf, 0, $len, "");
194	}
195	} else {
196	delete $self->{w};
197	close $self->{fh};
198	}
199	});
200
201	$self->{setup_req} = {
202	sound => 1,
203	exp64 => 1,
204	map1acmd => 1,
205	itemcmd => 2,
206	darkness => 1,
207	facecache => 1,
208	newmapcmd => 1,
209	mapinfocmd => 1,
210	plugincmd => 1,
211	extendedTextInfos => 1,
212	spellmon => 1,
213	};
214
215	$self->send ("version 1023 1027 perlclient");
216	$self->send_setup;
217	$self->send ("requestinfo skill_info");
218	$self->send ("requestinfo spell_paths");
219
220	$self
221	}
222
223	sub feed {
224	my ($self, $data) = @_;
225
226	$data =~ s/^(\S+)(?:\s\|$)//
227	or return;
228
229	my $command = "feed_$1";
230
231	$self->$command ($data);
232	}
233
234	sub feed_version {
235	my ($self, $version) = @_;
236	}
237
238	sub feed_setup {
239	my ($self, $data) = @_;
240
241	$data =~ s/^ +//;
242
243	$self->{setup} = { split / +/, $data };
244
245	my ($mapw, $maph) = split /x/, $self->{setup}{mapsize};
246
247	if ($mapw != $self->{mapw} \|\| $maph != $self->{maph}) {
248	($self->{mapw}, $self->{maph}) = ($mapw, $maph);
249	$self->send_setup;
250	} else {
251	$self->send ("addme");
252	}
253
254	$self->feed_newmap;
255	}
256
257	sub feed_addme_success {
258	my ($self, $data) = @_;
259
260	$self->addme_success ($data);
261	}
262
263	sub feed_addme_failure {
264	my ($self, $data) = @_;
265
266	$self->addme_failure ($data);
267	}
268
269	=back
270
271	=head2 METHODS THAT CAN/MUST BE OVERWRITTEN
272
273	=over 4
274
275	=item $self->addme_success
276
277	=item $self->addme_failure
278
279	=cut
280
281	sub addme_success { }
282	sub addme_failure { }
283
284	sub feed_face1 {
285	my ($self, $data) = @_;
286
287	my ($num, $chksum, $name) = unpack "nNa*", $data;
288
289	$self->need_face ($num, $name, $chksum);
290	}
291
292	sub need_face {
293	my ($self, $num, $name, $chksum) = @_;
294
295	return if $self->{face}[$num];
296
297	my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };
298
299	if (my $data = $self->face_find ($num, $face)) {
300	$face->{image} = $data;
301	$self->face_update ($num, $face);
302	} else {
303	$self->send_queue ("askface $num");
304	}
305	}
306
307	=item $conn->anim_update ($num) [OVERWRITE]
308
309	=cut
310
311	sub anim_update { }
312
313	sub feed_anim {
314	my ($self, $data) = @_;
315
316	my ($num, @faces) = unpack "n*", $data;
317
318	$self->{anim}[$num] = \@faces;
319
320	$self->anim_update ($num);
321	}
322
323	=item $conn->sound_play ($x, $y, $soundnum, $type)
324
325	=cut
326
327	sub sound_play { }
328
329	sub feed_sound {
330	my ($self, $data) = @_;
331
332	$self->sound_play (unpack "ccnC", $data);
333	}
334
335	=item $conn->query ($flags, $prompt)
336
337	=cut
338
339	sub query { }
340
341	sub feed_query {
342	my ($self, $data) = @_;
343
344	my ($flags, $prompt) = split /\s+/, $data, 2;
345
346	if ($flags == 0 && $prompt =~ /^What is your name\?\s+:$/ && length $self->{user}) {
347	$self->send ("reply $self->{user}");
348	} elsif ($flags == 4 && $prompt =~ /^What is your password\?\s+:$/ && length $self->{pass}) {
349	$self->send ("reply $self->{pass}");
350	} elsif ($flags == 4 && $prompt =~ /^Please type your password again\.\s+:$/ && length $self->{pass}) {
351	$self->send ("reply $self->{pass}");
352	} else {
353	$self->query ($flags, $prompt);
354	}
355	}
356
357	=item $conn->drawinfo ($color, $text)
358
359	=cut
360
361	sub drawinfo { }
362
363	sub feed_drawinfo {
364	my ($self, $data) = @_;
365
366	my ($flags, $text) = split / /, $data, 2;
367
368	utf8::decode $text if utf8::valid $text;
369
370	$self->drawinfo ($flags, $text);
371	}
372
373	=item $conn->player_update ($player)
374
375	tag, weight, face, name
376
377	=cut
378
379	sub player_update { }
380
381	sub feed_player {
382	my ($self, $data) = @_;
383
384	my ($tag, $weight, $face, $name) = unpack "NNN C/a", $data;
385
386	$self->player_update ($self->{player} = {
387	tag => $tag,
388	weight => $weight,
389	face => $face,
390	name => $name,
391	});
392	}
393
394	=item $conn->stats_update ($stats)
395
396	=cut
397
398	sub stats_update { }
399
400	my %stat_32bit = map +($_ => 1),
401	CS_STAT_WEIGHT_LIM,
402	CS_STAT_SPELL_ATTUNE,
403	CS_STAT_SPELL_REPEL,
404	CS_STAT_SPELL_DENY,
405	CS_STAT_EXP;
406
407	sub feed_stats {
408	my ($self, $data) = @_;
409
410	while (length $data) {
411	my $stat = unpack "C", substr $data, 0, 1, "";
412	my $value;
413
414	if ($stat_32bit{$stat}) {
415	$value = unpack "N", substr $data, 0, 4, "";
416	} elsif ($stat == CS_STAT_SPEED \|\| $stat == CS_STAT_WEAP_SP) {
417	$value = (1 / FLOAT_MULTF) * unpack "N", substr $data, 0, 4, "";
418	} elsif ($stat == CS_STAT_RANGE \|\| $stat == CS_STAT_TITLE) {
419	my $len = unpack "C", substr $data, 0, 1, "";
420	$value = substr $data, 0, $len, "";
421	} elsif ($stat == CS_STAT_EXP64) {
422	my ($hi, $lo) = unpack "NN", substr $data, 0, 8, "";
423	$value = $hi * 2**32 + $lo;
424	} elsif (($stat >= CS_STAT_SKILLEXP_START && $stat <= CS_STAT_SKILLEXP_END)
425	\|\| ($stat >= CS_STAT_SKILLINFO && $stat < CS_STAT_SKILLINFO + CS_NUM_SKILLS)) {
426	my ($level, $lo, $hi) = unpack "CNN", substr $data, 0, 9, "";
427	$value = [$level, $hi * 2**32 + $lo];
428	} else {
429	$value = unpack "s", pack "S", unpack "n", substr $data, 0, 2, "";
430	}
431
432	$self->{stat}{$stat} = $value;
433	}
434
435	$self->stats_update ($self->{stat});
436	}
437
438	=item $conn->container_add ($id, $item...)
439
440	=item $conn->container_clear ($id)
441
442	=item $conn->item_update ($item)
443
444	=item $conn->item_delete ($item...)
445
446	=cut
447
448	sub container_add { }
449	sub container_clear { }
450	sub item_delete { }
451	sub item_update { }
452
453	sub _del_items {
454	my ($self, @items) = @_;
455
456	for my $item (@items) {
457	delete $self->{item}{$item->{tag}};
458	delete $self->{container}{$item->{container}}{$item->{tag}};
459	}
460	}
461
462	sub feed_delinv {
463	my ($self, $data) = @_;
464
465	$self->_del_items (values %{ $self->{container}{$data} });
466	$self->container_clear ($data);
467	}
468
469	sub feed_delitem {
470	my ($self, $data) = @_;
471
472	my @items = map $self->{item}{$_}, unpack "N*", $data;
473	$self->_del_items (@items);
474	$self->item_delete (@items);
475	}
476
477	sub feed_item2 {
478	my ($self, $data) = @_;
479
480	my ($location, @values) = unpack "N (NNNN C/a* nC Nn)*", $data;
481
482	my @items;
483
484	while (@values) {
485	my ($tag, $flags, $weight, $face, $names, $anim, $animspeed, $nrof, $type) =
486	splice @values, 0, 9, ();
487
488	utf8::decode $names if utf8::valid $names;
489	my ($name, $name_pl) = split /\x00/, $names;
490
491	my $item = {
492	container => $location,
493	tag => $tag,
494	flags => $flags,
495	weight => $weight,
496	face => $face,
497	name => $name,
498	name_pl => $name_pl,
499	anim => $anim,
500	animspeed => $animspeed * TICK, #???
501	nrof => $nrof,
502	type => $type,
503	};
504
505	$self->{item}{$tag} = $item;
506	$self->{container}{$location}{$tag} = $item;
507	push @items, $item;
508	}
509
510	$self->container_add ($location, \@items);
511	}
512
513	sub feed_upditem {
514	my ($self, $data) = @_;
515
516	my ($flags, $tag) = unpack "NN", substr $data, 0, 8, "";
517
518	my $item = $self->{item}{$tag};
519
520	if ($flags & UPD_LOCATION) {
521	$self->item_delete ($item);
522	delete $self->{container}{$item->{container}}{$tag};
523
524	$item->{container} = unpack "N", substr $data, 0, 4, "";
525
526	$self->{container}{$item->{container}}{$tag} = $item;
527	$self->container_add ($item->{location}, $item);
528	}
529
530	$item->{flags} = unpack "N", substr $data, 0, 4, "" if $flags & UPD_FLAGS;
531	$item->{weight} = unpack "N", substr $data, 0, 4, "" if $flags & UPD_WEIGHT;
532	$item->{face} = unpack "N", substr $data, 0, 4, "" if $flags & UPD_FACE;
533
534	if ($flags & UPD_NAME) {
535	my $len = unpack "C", substr $data, 0, 1, "";
536
537	my $names = substr $data, 0, $len, "";
538	utf8::decode $names if utf8::valid $names;
539	@$item{qw(name name_pl)} = split /\x00/, $names;
540	}
541
542	$item->{anim} = unpack "n", substr $data, 0, 2, "" if $flags & UPD_ANIM;
543	$item->{animspeed} = TICK * unpack "C", substr $data, 0, 1, "" if $flags & UPD_ANIMSPEED;
544	$item->{nrof} = unpack "N", substr $data, 0, 4, "" if $flags & UPD_NROF;
545
546	$self->item_update ($item);
547	}
548
549	=item $conn->spell_add ($spell)
550
551	$spell = {
552	tag => ...,
553	level => ...,
554	casting_time => ...,
555	mana => ...,
556	grace => ...,
557	damage => ...,
558	skill => ...,
559	path => ...,
560	face => ...,
561	name => ...,
562	message => ...,
563	};
564
565	=item $conn->spell_update ($spell)
566
567	(the default implementation calls delete then add)
568
569	=item $conn->spell_delete ($spell)
570
571	=cut
572
573	sub spell_add { }
574
575	sub spell_update {
576	my ($self, $spell) = @_;
577
578	$self->spell_delete ($spell);
579	$self->spell_add ($spell);
580	}
581
582	sub spell_delete { }
583
584	sub feed_addspell {
585	my ($self, $data) = @_;
586
587	my @data = unpack "(NnnnnnCNN C/a n/a)*", $data;
588
589	while (@data) {
590	my $spell = {
591	tag => (shift @data),
592	level => (shift @data),
593	casting_time => (shift @data),
594	mana => (shift @data),
595	grace => (shift @data),
596	damage => (shift @data),
597	skill => (shift @data),
598	path => (shift @data),
599	face => (shift @data),
600	name => (shift @data),
601	message => (shift @data),
602	};
603
604	$self->send ("requestinfo image_sums $spell->{face} $spell->{face}")
605	unless $self->{spell_face}[$spell->{face}]++;
606
607	$self->spell_add ($self->{spell}{$spell->{tag}} = $spell);
608	}
609	}
610
611	sub feed_updspell {
612	my ($self, $data) = @_;
613
614	my ($flags, $tag) = unpack "CN", substr $data, 0, 5, "";
615
616	# only 1, 2, 4 supported
617	# completely untested
618
619	my $spell = $self->{spell}{$tag};
620
621	$spell->{mana} = unpack "n", substr $data, 0, 2, "" if $flags & UPD_SP_MANA;
622	$spell->{grace} = unpack "n", substr $data, 0, 2, "" if $flags & UPD_SP_GRACE;
623	$spell->{damage} = unpack "n", substr $data, 0, 2, "" if $flags & UPD_SP_DAMAGE;
624
625	$self->spell_update ($spell);
626	}
627
628	sub feed_delspell {
629	my ($self, $data) = @_;
630
631	$self->spell_delete (delete $self->{spell}{unpack "N", $data});
632	}
633
634	sub feed_map1a {
635	my ($self, $data) = @_;
636
637	my $map = $self->{map} \|\|= [];
638
639	my ($dx, $dy) = delete @$self{qw(delayed_scroll_x delayed_scroll_y)};
640
641	if ($dx \|\| $dy) {
642	my ($mx, $my, $mw, $mh) = @$self{qw(mapx mapy mapw maph)};
643
644	{
645	my @darkness;
646
647	if ($dx > 0) {
648	push @darkness, [$mx, $my, $dx - 1, $mh];
649	} elsif ($dx < 0) {
650	push @darkness, [$mx + $mw + $dx + 1, $my, 1 - $dx, $mh];
651	}
652
653	if ($dy > 0) {
654	push @darkness, [$mx, $my, $mw, $dy - 1];
655	} elsif ($dy < 0) {
656	push @darkness, [$mx, $my + $mh + $dy + 1, $mw, 1 - $dy];
657	}
658
659	for (@darkness) {
660	my ($x0, $y0, $w, $h) = @$_;
661	for my $x ($x0 .. $x0 + $w) {
662	for my $y ($y0 .. $y0 + $h) {
663
664	my $cell = $map->[$x][$y]
665	or next;
666
667	$cell->[0] = -1;
668	}
669	}
670	}
671	}
672
673	# now scroll
674
675	$self->{mapx} += $dx;
676	$self->{mapy} += $dy;
677
678	# shift in new space if moving to "negative indices"
679	if ($self->{mapy} < 0) {
680	unshift @$_, (undef) x -$self->{mapy} for @$map;
681	$self->{mapy} = 0;
682	}
683
684	if ($self->{mapx} < 0) {
685	unshift @$map, (undef) x -$self->{mapx};
686	$self->{mapx} = 0;
687	}
688
689	$self->map_scroll ($dx, $dy);
690	}
691
692	my @dirty;
693	my ($coord, $x, $y, $darkness, $fa, $fb, $fc, $cell);
694
695	while (length $data) {
696	$coord = unpack "n", substr $data, 0, 2, "";
697
698	$x = (($coord >> 10) & 63) + $self->{mapx};
699	$y = (($coord >> 4) & 63) + $self->{mapy};
700
701	$cell = $map->[$x][$y] \|\|= [];
702
703	if ($coord & 15) {
704	@$cell = () if $cell->[0] < 0;
705
706	$cell->[0] = $coord & 8
707	? unpack "C", substr $data, 0, 1, ""
708	: 255;
709
710	$cell->[1] = unpack "n", substr $data, 0, 2, ""
711	if $coord & 4;
712	$cell->[2] = unpack "n", substr $data, 0, 2, ""
713	if $coord & 2;
714	$cell->[3] = unpack "n", substr $data, 0, 2, ""
715	if $coord & 1;
716	} else {
717	$cell->[0] = -1;
718	}
719
720	push @dirty, [$x, $y];
721	}
722
723	$self->map_update (\@dirty);
724	}
725
726	sub feed_map_scroll {
727	my ($self, $data) = @_;
728
729	my ($dx, $dy) = split / /, $data;
730
731	$self->{delayed_scroll_x} += $dx;
732	$self->{delayed_scroll_y} += $dy;
733
734	$self->map_scroll ($dx, $dy);
735	}
736
737	sub feed_newmap {
738	my ($self) = @_;
739
740	$self->{map} = [];
741	$self->{mapx} = 0;
742	$self->{mapy} = 0;
743
744	delete $self->{delayed_scroll_x};
745	delete $self->{delayed_scroll_y};
746
747	$self->map_clear;
748	}
749
750	sub feed_mapinfo {
751	my ($self, $data) = @_;
752
753	my ($token, @data) = split / /, $data;
754
755	(delete $self->{mapinfo_cb}{$token})->(@data)
756	if $self->{mapinfo_cb}{$token};
757
758	$self->map_change (@data) if $token eq "-";
759	}
760
761	sub send_mapinfo {
762	my ($self, $data, $cb) = @_;
763
764	my $token = ++$self->{token};
765
766	$self->{mapinfo_cb}{$token} = sub {
767	$self->send_queue;
768	$cb->(@_);
769	};
770	$self->send_queue ("mapinfo $token $data");
771	}
772
773	sub feed_image {
774	my ($self, $data) = @_;
775
776	my ($num, $len, $data) = unpack "NNa*", $data;
777
778	$self->send_queue;
779	$self->{face}[$num]{image} = $data;
780	$self->face_update ($num, $self->{face}[$num]);
781
782	my @dirty;
783
784	for my $x (0..$self->{mapw} - 1) {
785	for my $y (0..$self->{maph} - 1) {
786	push @dirty, [$x, $y]
787	if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
788	}
789	}
790
791	$self->map_update (\@dirty);
792	}
793
794	sub feed_replyinfo {
795	my ($self, $data) = @_;
796
797	if ($data =~ s/^image_sums \d+ \d+ //) {
798	my ($num, $chksum, $faceset, $name) = unpack "n N C C/Z*", $data;
799
800	$self->need_face ($num, $name, $chksum);
801	} elsif ($data =~ s/^skill_info\s+//) {
802	for (split /\012/, $data) {
803	my ($id, $name) = split /:/, $_, 2;
804	$self->{skill_info}{$id} = $name;
805	}
806	} elsif ($data =~ s/^spell_paths\s+//) {
807	for (split /\012/, $data) {
808	my ($id, $name) = split /:/, $_, 2;
809	$self->{spell_paths}{$id} = $name;
810	}
811	}
812	}
813
814	=item $conn->map_change ($mode, ...) [OVERWRITE]
815
816	current <flags> <x> <y> <width> <height> <hashstring>
817
818	=cut
819
820	sub map_info { }
821
822	=item $conn->map_clear [OVERWRITE]
823
824	Called whenever the map is to be erased completely.
825
826	=cut
827
828	sub map_clear { }
829
830	=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
831
832	Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
833	have been updated and need refreshing.
834
835	=cut
836
837	sub map_update { }
838
839	=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
840
841	Called whenever the map has been scrolled.
842
843	=cut
844
845	sub map_scroll { }
846
847	=item $conn->face_update ($facenum, $facedata) [OVERWRITE]
848
849	Called with the face number of face structure whenever a face image has
850	changed.
851
852	=cut
853
854	sub face_update { }
855
856	=item $conn->face_find ($facenum, $facedata) [OVERWRITE]
857
858	Find and return the png image for the given face, or the empty list if no
859	face could be found, in which case it will be requested from the server.
860
861	=cut
862
863	sub face_find { }
864
865	=item $conn->send ($data)
866
867	Send a single packet/line to the server.
868
869	=cut
870
871	sub send {
872	my ($self, $data) = @_;
873
874	$data = pack "na*", length $data, $data;
875
876	syswrite $self->{fh}, $data;
877	}
878
879	=item $conn->send_command ($command)
880
881	Uses either command or ncom to send a user-level command to the
882	server. Encodes the command to UTF-8.
883
884	=cut
885
886	sub send_command {
887	my ($self, $command) = @_;
888
889	utf8::encode $command;
890	$self->send ("command $command");
891	}
892
893	sub send_queue {
894	my ($self, $cmd) = @_;
895
896	if (defined $cmd) {
897	push @{ $self->{send_queue} }, $cmd;
898	} else {
899	--$self->{outstanding};
900	}
901
902	if ($self->{outstanding} < $self->{max_outstanding} && @{ $self->{send_queue} }) {
903	++$self->{outstanding};
904	$self->send (shift @{ $self->{send_queue} });
905	}
906	}
907
908	sub send_setup {
909	my ($self) = @_;
910
911	my $setup = join " ", setup => %{$self->{setup_req}},
912	mapsize => "$self->{mapw}x$self->{maph}";
913
914	$self->send ($setup);
915	}
916
917	=back
918
919	=head1 AUTHOR
920
921	Marc Lehmann <schmorp@schmorp.de>
922	http://home.schmorp.de/
923
924	Robin Redeker <elmex@ta-sa.org>
925	http://www.ta-sa.org/
926
927	=cut
928
929	1