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 (0 < 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 {
         $self->feed_eof;
      }
   });

   $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/^ +//;

   my $prev_setup = $self->{setup};

   $self->{setup} = { split / +/, $data };

   if ($self->{setup}{extendedTextInfos} > 0 && !$prev_setup) {
      $self->send ("toggleextendedtext 1"); # books
      $self->send ("toggleextendedtext 2"); # cards
      $self->send ("toggleextendedtext 3"); # papers
      $self->send ("toggleextendedtext 4"); # signs
      $self->send ("toggleextendedtext 5"); # monuments
      #$self->send ("toggleextendedtext 6"); # scripted dialogs (yeah)
      $self->send ("toggleextendedtext 7"); # motd
   }

   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_eof {
   my ($self) = @_;

   delete $self->{w};
   close delete $self->{fh};

   for my $tag (sort { $b <=> $a } %{ $self->{container} || {} }) {
      $self->_del_items (@{ $self->{container}{$tag} });
      $self->container_clear ($tag);
   }

   $self->eof;
}

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

   $self->addme_success ($data);
}

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

   $self->addme_failure ($data);
}

sub logout {
   my ($self) = @_;

   $self->{fh} or return;

   $self->feed_eof;
}

sub destroy {
   my ($self) = @_;

   $self->logout;

   %$self = ();
}

=back

=head2 METHODS THAT CAN/MUST BE OVERWRITTEN

=over 4

=item $self->addme_success

=item $self->addme_failure

=item $self->eof

=cut

sub addme_success { }
sub addme_failure { }
sub eof           { }

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, $flags, @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->drawextinfo ($color, $type, $subtype, $message)

=item $conn->drawinfo ($color, $text)

=cut

sub drawextinfo { }

sub drawinfo { }

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

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

   my ($color, $type, $subtype, $message) = split /\s+/, $data, 4;

   $self->drawextinfo ($color, $type, $subtype, $message);
}

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

      $weight = unpack "l", pack "L", $weight; # weight can be -1

      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,
      };

      if (my $prev = $self->{item}{$tag}) {
         $self->_del_items ($prev);
         $self->item_delete ($prev);
      }

      $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 "CN", substr $data, 0, 5, "";

   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 "l", pack "L", 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);
}

=item $conn->image_info ($numfaces, $chksum, [...image-sets])

=cut

sub image_info { }

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/^image_info\s+//) {
      $self->image_info (split /\n/, $data);

   } 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.42
Committed:	Thu May 25 02:38:17 2006 UTC (18 years ago) by root
Branch:	MAIN
Changes since 1.41:	+11 -0 lines
Log Message:	support image_info reply