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}};
      $self->{container}{$item->{container}} = [
         grep $_ != $item, @{ $self->{container}{$item->{container}} }
      ];
   }
}

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

   $self->_del_items (@{ $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;
      push @{ $self->{container}{$location} }, $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);
      $self->{container}{$item->{container}} = [
         grep $_ != $item, @{ $self->{container}{$item->{container}} }
      ];

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

      push @{ $self->{container}{$item->{container}} }, $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.34
Committed:	Sat Apr 29 16:17:13 2006 UTC (18 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.33:	+9 -5 lines
Log Message:	* empty log message *
#	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	$self->{container}{$item->{container}} = [
459	grep $_ != $item, @{ $self->{container}{$item->{container}} }
460	];
461	}
462	}
463
464	sub feed_delinv {
465	my ($self, $data) = @_;
466
467	$self->_del_items (@{ $self->{container}{$data} });
468	$self->container_clear ($data);
469	}
470
471	sub feed_delitem {
472	my ($self, $data) = @_;
473
474	my @items = map $self->{item}{$_}, unpack "N*", $data;
475	$self->_del_items (@items);
476	$self->item_delete (@items);
477	}
478
479	sub feed_item2 {
480	my ($self, $data) = @_;
481
482	my ($location, @values) = unpack "N (NNNN C/a* nC Nn)*", $data;
483
484	my @items;
485
486	while (@values) {
487	my ($tag, $flags, $weight, $face, $names, $anim, $animspeed, $nrof, $type) =
488	splice @values, 0, 9, ();
489
490	utf8::decode $names if utf8::valid $names;
491	my ($name, $name_pl) = split /\x00/, $names;
492
493	my $item = {
494	container => $location,
495	tag => $tag,
496	flags => $flags,
497	weight => $weight,
498	face => $face,
499	name => $name,
500	name_pl => $name_pl,
501	anim => $anim,
502	animspeed => $animspeed * TICK, #???
503	nrof => $nrof,
504	type => $type,
505	};
506
507	$self->{item}{$tag} = $item;
508	push @{ $self->{container}{$location} }, $item;
509	push @items, $item;
510	}
511
512	$self->container_add ($location, \@items);
513	}
514
515	sub feed_upditem {
516	my ($self, $data) = @_;
517
518	my ($flags, $tag) = unpack "NN", substr $data, 0, 8, "";
519
520	my $item = $self->{item}{$tag};
521
522	if ($flags & UPD_LOCATION) {
523	$self->item_delete ($item);
524	$self->{container}{$item->{container}} = [
525	grep $_ != $item, @{ $self->{container}{$item->{container}} }
526	];
527
528	$item->{container} = unpack "N", substr $data, 0, 4, "";
529
530	push @{ $self->{container}{$item->{container}} }, $item;
531	$self->container_add ($item->{location}, $item);
532	}
533
534	$item->{flags} = unpack "N", substr $data, 0, 4, "" if $flags & UPD_FLAGS;
535	$item->{weight} = unpack "N", substr $data, 0, 4, "" if $flags & UPD_WEIGHT;
536	$item->{face} = unpack "N", substr $data, 0, 4, "" if $flags & UPD_FACE;
537
538	if ($flags & UPD_NAME) {
539	my $len = unpack "C", substr $data, 0, 1, "";
540
541	my $names = substr $data, 0, $len, "";
542	utf8::decode $names if utf8::valid $names;
543	@$item{qw(name name_pl)} = split /\x00/, $names;
544	}
545
546	$item->{anim} = unpack "n", substr $data, 0, 2, "" if $flags & UPD_ANIM;
547	$item->{animspeed} = TICK * unpack "C", substr $data, 0, 1, "" if $flags & UPD_ANIMSPEED;
548	$item->{nrof} = unpack "N", substr $data, 0, 4, "" if $flags & UPD_NROF;
549
550	$self->item_update ($item);
551	}
552
553	=item $conn->spell_add ($spell)
554
555	$spell = {
556	tag => ...,
557	level => ...,
558	casting_time => ...,
559	mana => ...,
560	grace => ...,
561	damage => ...,
562	skill => ...,
563	path => ...,
564	face => ...,
565	name => ...,
566	message => ...,
567	};
568
569	=item $conn->spell_update ($spell)
570
571	(the default implementation calls delete then add)
572
573	=item $conn->spell_delete ($spell)
574
575	=cut
576
577	sub spell_add { }
578
579	sub spell_update {
580	my ($self, $spell) = @_;
581
582	$self->spell_delete ($spell);
583	$self->spell_add ($spell);
584	}
585
586	sub spell_delete { }
587
588	sub feed_addspell {
589	my ($self, $data) = @_;
590
591	my @data = unpack "(NnnnnnCNN C/a n/a)*", $data;
592
593	while (@data) {
594	my $spell = {
595	tag => (shift @data),
596	level => (shift @data),
597	casting_time => (shift @data),
598	mana => (shift @data),
599	grace => (shift @data),
600	damage => (shift @data),
601	skill => (shift @data),
602	path => (shift @data),
603	face => (shift @data),
604	name => (shift @data),
605	message => (shift @data),
606	};
607
608	$self->send ("requestinfo image_sums $spell->{face} $spell->{face}")
609	unless $self->{spell_face}[$spell->{face}]++;
610
611	$self->spell_add ($self->{spell}{$spell->{tag}} = $spell);
612	}
613	}
614
615	sub feed_updspell {
616	my ($self, $data) = @_;
617
618	my ($flags, $tag) = unpack "CN", substr $data, 0, 5, "";
619
620	# only 1, 2, 4 supported
621	# completely untested
622
623	my $spell = $self->{spell}{$tag};
624
625	$spell->{mana} = unpack "n", substr $data, 0, 2, "" if $flags & UPD_SP_MANA;
626	$spell->{grace} = unpack "n", substr $data, 0, 2, "" if $flags & UPD_SP_GRACE;
627	$spell->{damage} = unpack "n", substr $data, 0, 2, "" if $flags & UPD_SP_DAMAGE;
628
629	$self->spell_update ($spell);
630	}
631
632	sub feed_delspell {
633	my ($self, $data) = @_;
634
635	$self->spell_delete (delete $self->{spell}{unpack "N", $data});
636	}
637
638	sub feed_map1a {
639	my ($self, $data) = @_;
640
641	my $map = $self->{map} \|\|= [];
642
643	my ($dx, $dy) = delete @$self{qw(delayed_scroll_x delayed_scroll_y)};
644
645	if ($dx \|\| $dy) {
646	my ($mx, $my, $mw, $mh) = @$self{qw(mapx mapy mapw maph)};
647
648	{
649	my @darkness;
650
651	if ($dx > 0) {
652	push @darkness, [$mx, $my, $dx - 1, $mh];
653	} elsif ($dx < 0) {
654	push @darkness, [$mx + $mw + $dx + 1, $my, 1 - $dx, $mh];
655	}
656
657	if ($dy > 0) {
658	push @darkness, [$mx, $my, $mw, $dy - 1];
659	} elsif ($dy < 0) {
660	push @darkness, [$mx, $my + $mh + $dy + 1, $mw, 1 - $dy];
661	}
662
663	for (@darkness) {
664	my ($x0, $y0, $w, $h) = @$_;
665	for my $x ($x0 .. $x0 + $w) {
666	for my $y ($y0 .. $y0 + $h) {
667
668	my $cell = $map->[$x][$y]
669	or next;
670
671	$cell->[0] = -1;
672	}
673	}
674	}
675	}
676
677	# now scroll
678
679	$self->{mapx} += $dx;
680	$self->{mapy} += $dy;
681
682	# shift in new space if moving to "negative indices"
683	if ($self->{mapy} < 0) {
684	unshift @$_, (undef) x -$self->{mapy} for @$map;
685	$self->{mapy} = 0;
686	}
687
688	if ($self->{mapx} < 0) {
689	unshift @$map, (undef) x -$self->{mapx};
690	$self->{mapx} = 0;
691	}
692
693	$self->map_scroll ($dx, $dy);
694	}
695
696	my @dirty;
697	my ($coord, $x, $y, $darkness, $fa, $fb, $fc, $cell);
698
699	while (length $data) {
700	$coord = unpack "n", substr $data, 0, 2, "";
701
702	$x = (($coord >> 10) & 63) + $self->{mapx};
703	$y = (($coord >> 4) & 63) + $self->{mapy};
704
705	$cell = $map->[$x][$y] \|\|= [];
706
707	if ($coord & 15) {
708	@$cell = () if $cell->[0] < 0;
709
710	$cell->[0] = $coord & 8
711	? unpack "C", substr $data, 0, 1, ""
712	: 255;
713
714	$cell->[1] = unpack "n", substr $data, 0, 2, ""
715	if $coord & 4;
716	$cell->[2] = unpack "n", substr $data, 0, 2, ""
717	if $coord & 2;
718	$cell->[3] = unpack "n", substr $data, 0, 2, ""
719	if $coord & 1;
720	} else {
721	$cell->[0] = -1;
722	}
723
724	push @dirty, [$x, $y];
725	}
726
727	$self->map_update (\@dirty);
728	}
729
730	sub feed_map_scroll {
731	my ($self, $data) = @_;
732
733	my ($dx, $dy) = split / /, $data;
734
735	$self->{delayed_scroll_x} += $dx;
736	$self->{delayed_scroll_y} += $dy;
737
738	$self->map_scroll ($dx, $dy);
739	}
740
741	sub feed_newmap {
742	my ($self) = @_;
743
744	$self->{map} = [];
745	$self->{mapx} = 0;
746	$self->{mapy} = 0;
747
748	delete $self->{delayed_scroll_x};
749	delete $self->{delayed_scroll_y};
750
751	$self->map_clear;
752	}
753
754	sub feed_mapinfo {
755	my ($self, $data) = @_;
756
757	my ($token, @data) = split / /, $data;
758
759	(delete $self->{mapinfo_cb}{$token})->(@data)
760	if $self->{mapinfo_cb}{$token};
761
762	$self->map_change (@data) if $token eq "-";
763	}
764
765	sub send_mapinfo {
766	my ($self, $data, $cb) = @_;
767
768	my $token = ++$self->{token};
769
770	$self->{mapinfo_cb}{$token} = sub {
771	$self->send_queue;
772	$cb->(@_);
773	};
774	$self->send_queue ("mapinfo $token $data");
775	}
776
777	sub feed_image {
778	my ($self, $data) = @_;
779
780	my ($num, $len, $data) = unpack "NNa*", $data;
781
782	$self->send_queue;
783	$self->{face}[$num]{image} = $data;
784	$self->face_update ($num, $self->{face}[$num]);
785
786	my @dirty;
787
788	for my $x (0..$self->{mapw} - 1) {
789	for my $y (0..$self->{maph} - 1) {
790	push @dirty, [$x, $y]
791	if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
792	}
793	}
794
795	$self->map_update (\@dirty);
796	}
797
798	sub feed_replyinfo {
799	my ($self, $data) = @_;
800
801	if ($data =~ s/^image_sums \d+ \d+ //) {
802	my ($num, $chksum, $faceset, $name) = unpack "n N C C/Z*", $data;
803
804	$self->need_face ($num, $name, $chksum);
805	} elsif ($data =~ s/^skill_info\s+//) {
806	for (split /\012/, $data) {
807	my ($id, $name) = split /:/, $_, 2;
808	$self->{skill_info}{$id} = $name;
809	}
810	} elsif ($data =~ s/^spell_paths\s+//) {
811	for (split /\012/, $data) {
812	my ($id, $name) = split /:/, $_, 2;
813	$self->{spell_paths}{$id} = $name;
814	}
815	}
816	}
817
818	=item $conn->map_change ($mode, ...) [OVERWRITE]
819
820	current <flags> <x> <y> <width> <height> <hashstring>
821
822	=cut
823
824	sub map_info { }
825
826	=item $conn->map_clear [OVERWRITE]
827
828	Called whenever the map is to be erased completely.
829
830	=cut
831
832	sub map_clear { }
833
834	=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
835
836	Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
837	have been updated and need refreshing.
838
839	=cut
840
841	sub map_update { }
842
843	=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
844
845	Called whenever the map has been scrolled.
846
847	=cut
848
849	sub map_scroll { }
850
851	=item $conn->face_update ($facenum, $facedata) [OVERWRITE]
852
853	Called with the face number of face structure whenever a face image has
854	changed.
855
856	=cut
857
858	sub face_update { }
859
860	=item $conn->face_find ($facenum, $facedata) [OVERWRITE]
861
862	Find and return the png image for the given face, or the empty list if no
863	face could be found, in which case it will be requested from the server.
864
865	=cut
866
867	sub face_find { }
868
869	=item $conn->send ($data)
870
871	Send a single packet/line to the server.
872
873	=cut
874
875	sub send {
876	my ($self, $data) = @_;
877
878	$data = pack "na*", length $data, $data;
879
880	syswrite $self->{fh}, $data;
881	}
882
883	=item $conn->send_command ($command)
884
885	Uses either command or ncom to send a user-level command to the
886	server. Encodes the command to UTF-8.
887
888	=cut
889
890	sub send_command {
891	my ($self, $command) = @_;
892
893	utf8::encode $command;
894	$self->send ("command $command");
895	}
896
897	sub send_queue {
898	my ($self, $cmd) = @_;
899
900	if (defined $cmd) {
901	push @{ $self->{send_queue} }, $cmd;
902	} else {
903	--$self->{outstanding};
904	}
905
906	if ($self->{outstanding} < $self->{max_outstanding} && @{ $self->{send_queue} }) {
907	++$self->{outstanding};
908	$self->send (shift @{ $self->{send_queue} });
909	}
910	}
911
912	sub send_setup {
913	my ($self) = @_;
914
915	my $setup = join " ", setup => %{$self->{setup_req}},
916	mapsize => "$self->{mapw}x$self->{maph}";
917
918	$self->send ($setup);
919	}
920
921	=back
922
923	=head1 AUTHOR
924
925	Marc Lehmann <schmorp@schmorp.de>
926	http://home.schmorp.de/
927
928	Robin Redeker <elmex@ta-sa.org>
929	http://www.ta-sa.org/
930
931	=cut
932
933	1