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 *
#	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	=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
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	}
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	my ($num, $len, $data) = unpack "NNa*", $data;
200
201	$self->{face}[$num]{image} = $data;
202	$self->face_update ($num, $self->{face}[$num]);
203
204	my @dirty;
205
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	}
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	=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	=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