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;

=item new Crossfire::Rptocol host => ..., port => ...

=cut

sub new {
   my $class = shift;
   my $self = bless { @_ }, $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) {
         if (2 <= length $buf) {
            my $len = unpack "n", $buf;
            if ($len + 2 <= length $buf) {
               substr $buf, 0, 2, "";
               $self->feed (substr $buf, 0, $len, "");
            }
         }
      } else {
         delete $self->{w};
         close $self->{fh};
      }
   });

   $self->send ("version 1023 1027 perlclient");
   $self->send ("setup sound 1 exp 1 map1acmd 1 itemcmd 2 darkness 1 mapsize 63x63 newmapcmd 1 facecache 1 extendedMapInfos 1 extendedTextInfos 1");
   $self->send ("addme");

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

   ($self->{mapw}, $self->{maph}) = split /x/, $self->{setup}{mapsize};

   $self->feed_newmap;
}

sub feed_query {
   my ($self, $data) = @_;
   warn "Q<$data>\n";
}

sub feed_stats {
   my ($self, $data) = @_;
#   warn "S<$data>\n";
}

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

   my ($num, $chksum, $name) = unpack "nNa*", $data;

   $self->{face}[$num] = { name => $name, chksum => $chksum };

   if (my $data = $self->face_find ($name, $chksum)) {
      $self->{face}[$num]{image} = $data;
      $self->face_update ($num, $self->{face}[$num]);
   } else {
      $self->send ("askface $num");
   }
}

sub feed_drawinfo {
   my ($self, $data) = @_;
#   warn "<$data>\n";
}

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

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

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

   my $map = $self->{map} ||= [];

   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;
      $y = ($coord >>  4) & 63;

      $cell = $map->[$x][$y] ||= [];

      $cell->[3] = $coord & 8
                 ? unpack "C", substr $data, 0, 1, ""
                 : 255;

      $cell->[0] = unpack "n", substr $data, 0, 2, ""
         if $coord & 4;
      $cell->[1] = unpack "n", substr $data, 0, 2, ""
         if $coord & 2;
      $cell->[2] = unpack "n", substr $data, 0, 2, ""
         if $coord & 1;

      @$cell = ()
         unless $coord & 15;

      push @dirty, [$x, $y];
   }

   $self->map_update (\@dirty);
}

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

   my ($dx, $dy) = split / /, $data;

   my $map = $self->{map} ||= [];

   $self->{mapx} += $dx;
   $self->{mapy} += $dy;

   if ($dx > 0) {
      unshift @$_, ([]) x $dx for @$map;
   } elsif ($dx < 0) {
      splice @$_, 0, -$dx, () for @$map;
   }

   if ($dy > 0) {
      unshift @$map, ([]) x $dy;
   } elsif ($dy < 0) {
      splice @$map, 0, -$dy, ();
   }

   $self->map_scroll ($dx, $dy);
}

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

   $self->{map}  = [];
   $self->{mapx} = 0;
   $self->{mapy} = 0;

   $self->map_clear;
}

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

   my ($num, $len, $data) = unpack "NNa*", $data;

   $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->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, $face) [OVERWRITE]

Called with the face number of face structure whenever a face image has
changed.

=cut

sub face_update { }

=item $conn->face_find ($facenum, $face) [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;
}

=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.4
Committed:	Fri Apr 7 13:53:37 2006 UTC (18 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.3:	+4 -2 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			Crossfire::Protocol - client protocol module
4
5			=head1 SYNOPSIS
6
7			use base Crossfire::Protocol; # you have to subclass
8
9			=head1 DESCRIPTION
10
11			Base class to implement a corssfire client.
12
13			=over 4
14
15			=cut
16
17			package Crossfire::Protocol;
18
19			our $VERSION = '0.1';
20
21			use strict;
22
23			use AnyEvent;
24			use IO::Socket::INET;
25
26			=item new Crossfire::Rptocol host => ..., port => ...
27
28			=cut
29
30			sub new {
31			my $class = shift;
32			my $self = bless { @_ }, $class;
33
34			$self->{fh} = new IO::Socket::INET PeerHost => $self->{host}, PeerPort => $self->{port}
35			or die "$self->{host}:$self->{port}: $!";
36			$self->{fh}->blocking (0); # stupid nonblock default
37
38			my $buf;
39
40			$self->{w} = AnyEvent->io (fh => $self->{fh}, poll => 'r', cb => sub {
41			if (sysread $self->{fh}, $buf, 16384, length $buf) {
42			if (2 <= length $buf) {
43			my $len = unpack "n", $buf;
44			if ($len + 2 <= length $buf) {
45			substr $buf, 0, 2, "";
46			$self->feed (substr $buf, 0, $len, "");
47			}
48			}
49			} else {
50			delete $self->{w};
51			close $self->{fh};
52			}
53			});
54
55			$self->send ("version 1023 1027 perlclient");
56			$self->send ("setup sound 1 exp 1 map1acmd 1 itemcmd 2 darkness 1 mapsize 63x63 newmapcmd 1 facecache 1 extendedMapInfos 1 extendedTextInfos 1");
57			$self->send ("addme");
58
59			$self
60			}
61
62			sub feed {
63			my ($self, $data) = @_;
64
65			$data =~ s/^(\S+)\s//
66			or return;
67
68			my $command = "feed_$1";
69
70			$self->$command ($data);
71			}
72
73			sub feed_version {
74			my ($self, $version) = @_;
75			}
76
77			sub feed_setup {
78			my ($self, $data) = @_;
79
80			$data =~ s/^ +//;
81
82			$self->{setup} = { split / +/, $data };
83
84			($self->{mapw}, $self->{maph}) = split /x/, $self->{setup}{mapsize};
85
86			$self->feed_newmap;
87			}
88
89			sub feed_query {
90			my ($self, $data) = @_;
91			warn "Q<$data>\n";
92			}
93
94			sub feed_stats {
95			my ($self, $data) = @_;
96			# warn "S<$data>\n";
97			}
98
99			sub feed_face1 {
100			my ($self, $data) = @_;
101
102			my ($num, $chksum, $name) = unpack "nNa*", $data;
103
104			$self->{face}[$num] = { name => $name, chksum => $chksum };
105	root	1.3
106			if (my $data = $self->face_find ($name, $chksum)) {
107			$self->{face}[$num]{image} = $data;
108			$self->face_update ($num, $self->{face}[$num]);
109			} else {
110			$self->send ("askface $num");
111			}
112	root	1.1	}
113
114			sub feed_drawinfo {
115			my ($self, $data) = @_;
116			# warn "<$data>\n";
117			}
118
119			sub feed_delinv {
120			my ($self, $data) = @_;
121			}
122
123			sub feed_item2 {
124			my ($self, $data) = @_;
125			}
126
127			sub feed_map1a {
128			my ($self, $data) = @_;
129
130			my $map = $self->{map} \|\|= [];
131
132			my @dirty;
133			my ($coord, $x, $y, $darkness, $fa, $fb, $fc, $cell);
134
135			while (length $data) {
136			$coord = unpack "n", substr $data, 0, 2, "";
137
138			$x = ($coord >> 10) & 63;
139			$y = ($coord >> 4) & 63;
140
141			$cell = $map->[$x][$y] \|\|= [];
142
143	root	1.4	$cell->[3] = $coord & 8
144			? unpack "C", substr $data, 0, 1, ""
145			: 255;
146
147	root	1.1	$cell->[0] = unpack "n", substr $data, 0, 2, ""
148			if $coord & 4;
149			$cell->[1] = unpack "n", substr $data, 0, 2, ""
150			if $coord & 2;
151			$cell->[2] = unpack "n", substr $data, 0, 2, ""
152			if $coord & 1;
153
154			@$cell = ()
155			unless $coord & 15;
156
157			push @dirty, [$x, $y];
158			}
159
160			$self->map_update (\@dirty);
161			}
162
163			sub feed_map_scroll {
164			my ($self, $data) = @_;
165
166			my ($dx, $dy) = split / /, $data;
167
168			my $map = $self->{map} \|\|= [];
169
170			$self->{mapx} += $dx;
171			$self->{mapy} += $dy;
172
173			if ($dx > 0) {
174			unshift @$_, ([]) x $dx for @$map;
175			} elsif ($dx < 0) {
176			splice @$_, 0, -$dx, () for @$map;
177			}
178
179			if ($dy > 0) {
180			unshift @$map, ([]) x $dy;
181			} elsif ($dy < 0) {
182			splice @$map, 0, -$dy, ();
183			}
184
185			$self->map_scroll ($dx, $dy);
186			}
187
188			sub feed_newmap {
189			my ($self) = @_;
190
191			$self->{map} = [];
192			$self->{mapx} = 0;
193			$self->{mapy} = 0;
194
195			$self->map_clear;
196			}
197
198			sub feed_image {
199			my ($self, $data) = @_;
200
201	root	1.3	my ($num, $len, $data) = unpack "NNa*", $data;
202	root	1.1
203	root	1.3	$self->{face}[$num]{image} = $data;
204			$self->face_update ($num, $self->{face}[$num]);
205	root	1.1
206	root	1.3	my @dirty;
207	root	1.2
208			for my $x (0..$self->{mapw} - 1) {
209			for my $y (0..$self->{maph} - 1) {
210			push @dirty, [$x, $y]
211			if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
212			}
213			}
214			$self->map_update (\@dirty);
215	root	1.1	}
216
217			=item $conn->map_clear [OVERWRITE]
218
219			Called whenever the map is to be erased completely.
220
221			=cut
222
223			sub map_clear { }
224
225			=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
226
227			Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
228			have been updated and need refreshing.
229
230			=cut
231
232			sub map_update { }
233
234			=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
235
236			Called whenever the map has been scrolled.
237
238			=cut
239
240			sub map_scroll { }
241
242			=item $conn->face_update ($facenum, $face) [OVERWRITE]
243
244			Called with the face number of face structure whenever a face image has
245			changed.
246
247			=cut
248
249			sub face_update { }
250
251	root	1.3	=item $conn->face_find ($facenum, $face) [OVERWRITE]
252
253			Find and return the png image for the given face, or the empty list if no
254			face could be found, in which case it will be requested from the server.
255
256			=cut
257
258			sub face_find { }
259
260	root	1.1	=item $conn->send ($data)
261
262			Send a single packet/line to the server.
263
264			=cut
265
266			sub send {
267			my ($self, $data) = @_;
268
269			$data = pack "na*", length $data, $data;
270
271			syswrite $self->{fh}, $data;
272			}
273
274			=back
275
276			=head1 AUTHOR
277
278			Marc Lehmann <schmorp@schmorp.de>
279			http://home.schmorp.de/
280
281			Robin Redeker <elmex@ta-sa.org>
282			http://www.ta-sa.org/
283
284			=cut
285
286			1