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;

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

   if (my $data = $self->face_find ($face)) {
      $face->{image} = $data;
      $self->face_update ($face);
   } 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 ($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 ($face) [OVERWRITE]

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

=cut

sub face_update { }

=item $conn->face_find ($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.5
Committed:	Fri Apr 7 19:26:54 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.4:	+7 -7 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	my $face = $self->{face}[$num] = { name => $name, chksum => $chksum };
105
106	if (my $data = $self->face_find ($face)) {
107	$face->{image} = $data;
108	$self->face_update ($face);
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] = $coord & 8
144	? unpack "C", substr $data, 0, 1, ""
145	: 255;
146
147	$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	my ($num, $len, $data) = unpack "NNa*", $data;
202
203	$self->{face}[$num]{image} = $data;
204	$self->face_update ($self->{face}[$num]);
205
206	my @dirty;
207
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	}
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 ($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	=item $conn->face_find ($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	=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