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] = unpack "C", substr $data, 0, 1, ""
         if $coord & 8;
      $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.3
Committed:	Thu Apr 6 20:15:05 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.2:	+20 -3 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			$cell->[3] = unpack "C", substr $data, 0, 1, ""
144			if $coord & 8;
145			$cell->[0] = unpack "n", substr $data, 0, 2, ""
146			if $coord & 4;
147			$cell->[1] = unpack "n", substr $data, 0, 2, ""
148			if $coord & 2;
149			$cell->[2] = unpack "n", substr $data, 0, 2, ""
150			if $coord & 1;
151
152			@$cell = ()
153			unless $coord & 15;
154
155			push @dirty, [$x, $y];
156			}
157
158			$self->map_update (\@dirty);
159			}
160
161			sub feed_map_scroll {
162			my ($self, $data) = @_;
163
164			my ($dx, $dy) = split / /, $data;
165
166			my $map = $self->{map} \|\|= [];
167
168			$self->{mapx} += $dx;
169			$self->{mapy} += $dy;
170
171			if ($dx > 0) {
172			unshift @$_, ([]) x $dx for @$map;
173			} elsif ($dx < 0) {
174			splice @$_, 0, -$dx, () for @$map;
175			}
176
177			if ($dy > 0) {
178			unshift @$map, ([]) x $dy;
179			} elsif ($dy < 0) {
180			splice @$map, 0, -$dy, ();
181			}
182
183			$self->map_scroll ($dx, $dy);
184			}
185
186			sub feed_newmap {
187			my ($self) = @_;
188
189			$self->{map} = [];
190			$self->{mapx} = 0;
191			$self->{mapy} = 0;
192
193			$self->map_clear;
194			}
195
196			sub feed_image {
197			my ($self, $data) = @_;
198
199	root	1.3	my ($num, $len, $data) = unpack "NNa*", $data;
200	root	1.1
201	root	1.3	$self->{face}[$num]{image} = $data;
202			$self->face_update ($num, $self->{face}[$num]);
203	root	1.1
204	root	1.3	my @dirty;
205	root	1.2
206			for my $x (0..$self->{mapw} - 1) {
207			for my $y (0..$self->{maph} - 1) {
208			push @dirty, [$x, $y]
209			if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
210			}
211			}
212			$self->map_update (\@dirty);
213	root	1.1	}
214
215			=item $conn->map_clear [OVERWRITE]
216
217			Called whenever the map is to be erased completely.
218
219			=cut
220
221			sub map_clear { }
222
223			=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
224
225			Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
226			have been updated and need refreshing.
227
228			=cut
229
230			sub map_update { }
231
232			=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
233
234			Called whenever the map has been scrolled.
235
236			=cut
237
238			sub map_scroll { }
239
240			=item $conn->face_update ($facenum, $face) [OVERWRITE]
241
242			Called with the face number of face structure whenever a face image has
243			changed.
244
245			=cut
246
247			sub face_update { }
248
249	root	1.3	=item $conn->face_find ($facenum, $face) [OVERWRITE]
250
251			Find and return the png image for the given face, or the empty list if no
252			face could be found, in which case it will be requested from the server.
253
254			=cut
255
256			sub face_find { }
257
258	root	1.1	=item $conn->send ($data)
259
260			Send a single packet/line to the server.
261
262			=cut
263
264			sub send {
265			my ($self, $data) = @_;
266
267			$data = pack "na*", length $data, $data;
268
269			syswrite $self->{fh}, $data;
270			}
271
272			=back
273
274			=head1 AUTHOR
275
276			Marc Lehmann <schmorp@schmorp.de>
277			http://home.schmorp.de/
278
279			Robin Redeker <elmex@ta-sa.org>
280			http://www.ta-sa.org/
281
282			=cut
283
284			1