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

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 ($face, $len, $data) = unpack "NNa*", $data;

   $self->{face}[$face]{image} = $data;

   $self->face_update ($face, $self->{face}[$face]);

   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->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.2
Committed:	Thu Apr 6 20:04:55 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.1:	+8 -0 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
107	sub feed_drawinfo {
108	my ($self, $data) = @_;
109	# warn "<$data>\n";
110	}
111
112	sub feed_delinv {
113	my ($self, $data) = @_;
114	}
115
116	sub feed_item2 {
117	my ($self, $data) = @_;
118	}
119
120	sub feed_map1a {
121	my ($self, $data) = @_;
122
123	my $map = $self->{map} \|\|= [];
124
125	my @dirty;
126	my ($coord, $x, $y, $darkness, $fa, $fb, $fc, $cell);
127
128	while (length $data) {
129	$coord = unpack "n", substr $data, 0, 2, "";
130
131	$x = ($coord >> 10) & 63;
132	$y = ($coord >> 4) & 63;
133
134	$cell = $map->[$x][$y] \|\|= [];
135
136	$cell->[3] = unpack "C", substr $data, 0, 1, ""
137	if $coord & 8;
138	$cell->[0] = unpack "n", substr $data, 0, 2, ""
139	if $coord & 4;
140	$cell->[1] = unpack "n", substr $data, 0, 2, ""
141	if $coord & 2;
142	$cell->[2] = unpack "n", substr $data, 0, 2, ""
143	if $coord & 1;
144
145	@$cell = ()
146	unless $coord & 15;
147
148	push @dirty, [$x, $y];
149	}
150
151	$self->map_update (\@dirty);
152	}
153
154	sub feed_map_scroll {
155	my ($self, $data) = @_;
156
157	my ($dx, $dy) = split / /, $data;
158
159	my $map = $self->{map} \|\|= [];
160
161	$self->{mapx} += $dx;
162	$self->{mapy} += $dy;
163
164	if ($dx > 0) {
165	unshift @$_, ([]) x $dx for @$map;
166	} elsif ($dx < 0) {
167	splice @$_, 0, -$dx, () for @$map;
168	}
169
170	if ($dy > 0) {
171	unshift @$map, ([]) x $dy;
172	} elsif ($dy < 0) {
173	splice @$map, 0, -$dy, ();
174	}
175
176	$self->map_scroll ($dx, $dy);
177	}
178
179	sub feed_newmap {
180	my ($self) = @_;
181
182	$self->{map} = [];
183	$self->{mapx} = 0;
184	$self->{mapy} = 0;
185
186	$self->map_clear;
187	}
188
189	sub feed_image {
190	my ($self, $data) = @_;
191
192	my ($face, $len, $data) = unpack "NNa*", $data;
193
194	$self->{face}[$face]{image} = $data;
195
196	$self->face_update ($face, $self->{face}[$face]);
197
198	for my $x (0..$self->{mapw} - 1) {
199	for my $y (0..$self->{maph} - 1) {
200	push @dirty, [$x, $y]
201	if grep $_ == $num, @{$self->{map}[$x][$y] \|\| []};
202	}
203	}
204	$self->map_update (\@dirty);
205	}
206
207	=item $conn->map_clear [OVERWRITE]
208
209	Called whenever the map is to be erased completely.
210
211	=cut
212
213	sub map_clear { }
214
215	=item $conn->map_update ([ [x,y], [x,y], ...]) [OVERWRITE]
216
217	Called with a list of x\|y coordinate pairs (as arrayrefs) for cells that
218	have been updated and need refreshing.
219
220	=cut
221
222	sub map_update { }
223
224	=item $conn->map_scroll ($dx, $dy) [OVERWRITE]
225
226	Called whenever the map has been scrolled.
227
228	=cut
229
230	sub map_scroll { }
231
232	=item $conn->face_update ($facenum, $face) [OVERWRITE]
233
234	Called with the face number of face structure whenever a face image has
235	changed.
236
237	=cut
238
239	sub face_update { }
240
241	=item $conn->send ($data)
242
243	Send a single packet/line to the server.
244
245	=cut
246
247	sub send {
248	my ($self, $data) = @_;
249
250	$data = pack "na*", length $data, $data;
251
252	syswrite $self->{fh}, $data;
253	}
254
255	=back
256
257	=head1 AUTHOR
258
259	Marc Lehmann <schmorp@schmorp.de>
260	http://home.schmorp.de/
261
262	Robin Redeker <elmex@ta-sa.org>
263	http://www.ta-sa.org/
264
265	=cut
266
267	1