ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC/Protocol.pm
Revision: 1.2
Committed: Fri May 26 19:14:33 2006 UTC (18 years ago) by root
Branch: MAIN
Changes since 1.1: +9 -7 lines
Log Message:
fixes after reorganisation

File Contents

# Content
1 package CFClient::Protocol;
2
3 use utf8;
4 use strict;
5
6 use Crossfire::Protocol::Constants;
7
8 use CFClient::UI;
9
10 use base 'Crossfire::Protocol::Base';
11
12 sub new {
13 my $class = shift;
14
15 my $self = $class->SUPER::new (@_);
16
17 $self->{map_widget}->clr_commands;
18
19 my $parser = new Pod::POM;
20 my $pod = $parser->parse_file (CFClient::find_rcfile "pod/command_help.pod");
21
22 for my $head2 ($pod->head1->[-2]->head2) {
23 $head2->title =~ /^(\S+) (?:\s+ \( ([^\)]*) \) )?/x
24 or next;
25
26 my $cmd = $1;
27 my @args = split /\|/, $2;
28 @args = (".*") unless @args;
29
30 my $text = CFClient::pod_to_pango $head2->content;
31
32 for my $arg (@args) {
33 $arg = $arg eq ".*" ? "" : " $arg";
34
35 $self->{map_widget}->add_command ("$cmd$arg", $text);
36 }
37 }
38
39 $self->{noface} = new_from_file CFClient::Texture
40 CFClient::find_rcfile "noface.png", minify => 1, mipmap => 1;
41
42 $self->{open_container} = 0;
43
44 # "global"
45 $self->{tilecache} = CFClient::db_table "tilecache";
46 $self->{facemap} = CFClient::db_table "facemap";
47
48 # per server
49 $self->{mapcache} = CFClient::db_table "mapcache_$self->{host}_$self->{port}";
50
51 $self
52 }
53
54 sub stats_update {
55 my ($self, $stats) = @_;
56
57 if (my $exp = $stats->{CS_STAT_EXP64}) {
58 my $diff = $exp - $self->{prev_exp};
59 $self->{statusbox}->add ("$diff experience gained", group => "experience $diff", fg => [0.5, 1, 0.5, 0.8], timeout => 5)
60 if exists $self->{prev_exp} && $diff;
61 $self->{prev_exp} = $exp;
62 }
63
64 ::update_stats_window ($stats);
65 }
66
67 sub user_send {
68 my ($self, $command) = @_;
69
70 $self->send_command ($command);
71 ::status $command;
72 }
73
74 sub map_scroll {
75 my ($self, $dx, $dy) = @_;
76
77 $self->{map}->scroll ($dx, $dy);
78 }
79
80 sub feed_map1a {
81 my ($self, $data) = @_;
82
83 $self->{map}->map1a_update ($data);
84 $self->{map_widget}->update;
85 }
86
87 sub flush_map {
88 my ($self) = @_;
89
90 my $map_info = delete $self->{map_info}
91 or return;
92
93 my ($hash, $x, $y, $w, $h) = @$map_info;
94
95 my $data = $self->{map}->get_rect ($x, $y, $w, $h);
96 $self->{mapcache}->put ($hash => Compress::LZF::compress $data);
97 #warn sprintf "SAVEmap[%s] length %d\n", $hash, length $data;#d#
98 }
99
100 sub map_clear {
101 my ($self) = @_;
102
103 $self->flush_map;
104 delete $self->{neigh_map};
105
106 $self->{map}->clear;
107 }
108
109
110 sub load_map($$$) {
111 my ($self, $hash, $x, $y) = @_;
112
113 if (defined (my $data = $self->{mapcache}->get ($hash))) {
114 $data = Compress::LZF::decompress $data;
115 #warn sprintf "LOADmap[%s,%d,%d] length %d\n", $hash, $x, $y, length $data;#d#
116 for my $id ($self->{map}->set_rect ($x, $y, $data)) {
117 my $data = $self->{tilecache}->get ($id)
118 or next;
119
120 $self->set_texture ($id => $data);
121 }
122 }
123 }
124
125 # hardcode /world/world_xxx_xxx map names, the savings are enourmous,
126 # (server resource,s latency, bandwidth), so this hack is warranted.
127 # the right fix is to make real tiled maps with an overview file
128 sub send_mapinfo {
129 my ($self, $data, $cb) = @_;
130
131 if ($self->{map_info}[0] =~ m%^/world/world_(\d\d\d)_(\d\d\d)$%) {
132 my ($wx, $wy) = ($1, $2);
133
134 if ($data =~ /^spatial ([1-4]+)$/) {
135 my @dx = (0, 0, 1, 0, -1);
136 my @dy = (0, -1, 0, 1, 0);
137 my ($dx, $dy);
138
139 for (split //, $1) {
140 $dx += $dx[$_];
141 $dy += $dy[$_];
142 }
143
144 $cb->(spatial => 15,
145 $self->{map_info}[1] - $self->{map}->ox + $dx * 50,
146 $self->{map_info}[2] - $self->{map}->oy + $dy * 50,
147 50, 50,
148 sprintf "/world/world_%03d_%03d", $wx + $dx, $wy + $dy
149 );
150
151 return;
152 }
153 }
154
155 $self->SUPER::send_mapinfo ($data, $cb);
156 }
157
158 # this method does a "flood fill" into every tile direction
159 # it assumes that tiles are arranged in a rectangular grid,
160 # i.e. a map is the same as the left of the right map etc.
161 # failure to comply are harmless and result in display errors
162 # at worst.
163 sub flood_fill {
164 my ($self, $block, $gx, $gy, $path, $hash, $flags) = @_;
165
166 # the server does not allow map paths > 6
167 return if 7 <= length $path;
168
169 my ($x0, $y0, $x1, $y1) = @{$self->{neigh_rect}};
170
171 for (
172 [1, 3, 0, -1],
173 [2, 4, 1, 0],
174 [3, 1, 0, 1],
175 [4, 2, -1, 0],
176 ) {
177 my ($tile, $tile2, $dx, $dy) = @$_;
178
179 next if $block & (1 << $tile);
180 my $block = $block | (1 << $tile2);
181
182 my $gx = $gx + $dx;
183 my $gy = $gy + $dy;
184
185 next unless $flags & (1 << ($tile - 1));
186 next if $self->{neigh_grid}{$gx, $gy}++;
187
188 my $neigh = $self->{neigh_map}{$hash} ||= [];
189 if (my $info = $neigh->[$tile]) {
190 my ($flags, $x, $y, $w, $h, $hash) = @$info;
191
192 $self->flood_fill ($block, $gx, $gy, "$path$tile", $hash, $flags)
193 if $x >= $x0 && $x + $w < $x1 && $y >= $y0 && $y + $h < $y1;
194
195 } else {
196 $self->send_mapinfo ("spatial $path$tile", sub {
197 my ($mode, $flags, $x, $y, $w, $h, $hash) = @_;
198
199 return if $mode ne "spatial";
200
201 $x += $self->{map}->ox;
202 $y += $self->{map}->oy;
203
204 $self->load_map ($hash, $x, $y)
205 unless $self->{neigh_map}{$hash}[5]++;#d#
206
207 $neigh->[$tile] = [$flags, $x, $y, $w, $h, $hash];
208
209 $self->flood_fill ($block, $gx, $gy, "$path$tile", $hash, $flags)
210 if $x >= $x0 && $x + $w < $x1 && $y >= $y0 && $y + $h < $y1;
211 });
212 }
213 }
214 }
215
216 sub map_change {
217 my ($self, $mode, $flags, $x, $y, $w, $h, $hash) = @_;
218
219 $self->flush_map;
220
221 my ($ox, $oy) = ($::MAP->ox, $::MAP->oy);
222
223 my $mapmapw = $self->{mapmap}->{w};
224 my $mapmaph = $self->{mapmap}->{h};
225
226 $self->{neigh_rect} = [
227 $ox - $mapmapw * 0.5, $oy - $mapmapw * 0.5,
228 $ox + $mapmapw * 0.5 + $w, $oy + $mapmapw * 0.5 + $h,
229 ];
230
231 delete $self->{neigh_grid};
232
233 $x += $ox;
234 $y += $oy;
235
236 $self->{map_info} = [$hash, $x, $y, $w, $h];
237
238 (my $map = $hash) =~ s/^.*?\/([^\/]+)$/\1/;
239 $::STATWIDS->{map}->set_text ("Map: " . $map);
240
241 $self->load_map ($hash, $x, $y);
242 $self->flood_fill (0, 0, 0, "", $hash, $flags);
243 }
244
245 sub face_find {
246 my ($self, $facenum, $face) = @_;
247
248 my $hash = "$face->{chksum},$face->{name}";
249
250 my $id = $self->{facemap}->get ($hash);
251
252 unless ($id) {
253 # create new id for face
254 # I love transactions
255 for (1..100) {
256 my $txn = $CFClient::DB_ENV->txn_begin;
257 my $status = $self->{facemap}->db_get (id => $id, BerkeleyDB::DB_RMW);
258 if ($status == 0 || $status == BerkeleyDB::DB_NOTFOUND) {
259 $id = ($id || 16) + 1;
260 if ($self->{facemap}->put (id => $id) == 0
261 && $self->{facemap}->put ($hash => $id) == 0) {
262 $txn->txn_commit;
263
264 goto gotid;
265 }
266 }
267 $txn->abort;
268 }
269
270 CFClient::fatal "maximum number of transaction retries reached - database problems?";
271 }
272
273 gotid:
274 $face->{id} = $id;
275 $self->{map}->set_face ($facenum => $id);
276 $self->{faceid}[$facenum] = $id;#d#
277
278 my $face = $self->{tilecache}->get ($id);
279
280 if ($face) {
281 #$self->face_prefetch;
282 $face
283 } else {
284 my $tex = $self->{noface};
285 $self->{map}->set_texture ($id, @$tex{qw(name w h s t)}, @{$tex->{minified}});
286 undef
287 };
288 }
289
290 sub face_update {
291 my ($self, $facenum, $face) = @_;
292
293 $self->{tilecache}->put ($face->{id} => $face->{image}); #TODO: try to avoid duplicate writes
294
295 $self->set_texture ($face->{id} => delete $face->{image});
296 }
297
298 sub set_texture {
299 my ($self, $id, $data) = @_;
300
301 $self->{texture}[$id] ||= do {
302 my $tex =
303 new_from_image CFClient::Texture
304 $data, minify => 1, mipmap => 1;
305
306 $self->{map}->set_texture ($id, @$tex{qw(name w h s t)}, @{$tex->{minified}});
307 $self->{map_widget}->update;
308
309 $tex
310 };
311 }
312
313 sub sound_play {
314 my ($self, $x, $y, $soundnum, $type) = @_;
315
316 $self->{sound_play}->($x, $y, $soundnum, $type);
317 }
318
319 my $LAST_QUERY; # server is stupid, stupid, stupid
320
321 sub query {
322 my ($self, $flags, $prompt) = @_;
323
324 $prompt = $LAST_QUERY unless length $prompt;
325 $LAST_QUERY = $prompt;
326
327 my $dialog = new CFClient::UI::FancyFrame
328 title => "Query",
329 child => my $vbox = new CFClient::UI::VBox;
330
331 $vbox->add (new CFClient::UI::Label
332 max_w => $::WIDTH * 0.4,
333 ellipsise => 0,
334 text => $prompt);
335
336 if ($flags & CS_QUERY_YESNO) {
337 $vbox->add (my $hbox = new CFClient::UI::HBox);
338 $hbox->add (new CFClient::UI::Button
339 text => "No",
340 connect_activate => sub {
341 $self->send ("reply n");
342 $dialog->destroy;
343 $self->{map_widget}->focus_in;
344 }
345 );
346 $hbox->add (new CFClient::UI::Button
347 text => "Yes",
348 connect_activate => sub {
349 $self->send ("reply y");
350 $dialog->destroy;
351 },
352 );
353
354 $dialog->focus_in;
355
356 } elsif ($flags & CS_QUERY_SINGLECHAR) {
357 $dialog->{tooltip} = "Press a key (click on the entry to make sure it has keyboard focus)";
358 $vbox->add (my $entry = new CFClient::UI::Entry
359 connect_changed => sub {
360 $self->send ("reply $_[1]");
361 $dialog->destroy;
362 },
363 );
364
365 $entry->focus_in;
366
367 } else {
368 $dialog->{tooltip} = "Enter the reply and press return (click on the entry to make sure it has keyboard focus)";
369
370 $vbox->add (my $entry = new CFClient::UI::Entry
371 $flags & CS_QUERY_HIDEINPUT ? (hiddenchar => "*") : (),
372 connect_activate => sub {
373 $self->send ("reply $_[1]");
374 $dialog->destroy;
375 },
376 );
377
378 $entry->focus_in;
379 }
380
381 $dialog->show_centered;
382 }
383
384 sub drawinfo {
385 my ($self, $color, $text) = @_;
386
387 my @color = (
388 [1.00, 1.00, 1.00], #[0.00, 0.00, 0.00],
389 [1.00, 1.00, 1.00],
390 [0.50, 0.50, 1.00], #[0.00, 0.00, 0.55]
391 [1.00, 0.00, 0.00],
392 [1.00, 0.54, 0.00],
393 [0.11, 0.56, 1.00],
394 [0.93, 0.46, 0.00],
395 [0.18, 0.54, 0.34],
396 [0.56, 0.73, 0.56],
397 [0.80, 0.80, 0.80],
398 [0.55, 0.41, 0.13],
399 [0.99, 0.77, 0.26],
400 [0.74, 0.65, 0.41],
401 );
402
403 my $time = sprintf "%02d:%02d:%02d", (localtime time)[2,1,0];
404
405 $text = CFClient::UI::Label::escape $text;
406 $text =~ s/\[b\](.*?)\[\/b\]/<b>\1<\/b>/g;
407 $text =~ s/\[color=(.*?)\](.*?)\[\/color\]/<span foreground='\1'>\2<\/span>/g;
408
409 $self->{logview}->add_paragraph ($color[$color],
410 join "\n", map "$time $_", split /\n/, $text);
411
412 $self->{statusbox}->add ($text,
413 group => $text,
414 fg => $color[$color],
415 timeout => 10,
416 tooltip_font => $::FONT_FIXED,
417 );
418 }
419
420 sub drawextinfo {
421 my ($self, $color, $type, $subtype, $message) = @_;
422
423 $self->drawinfo ($color, $message);
424 }
425
426 sub spell_add {
427 my ($self, $spell) = @_;
428
429 # TODO
430 # create a widget dynamically, using spell face (CF::Protocol downloads them)
431 $self->{map_widget}->add_command ("invoke $spell->{name}", CFClient::UI::Label::escape $spell->{message});
432 $self->{map_widget}->add_command ("cast $spell->{name}", CFClient::UI::Label::escape $spell->{message});
433 }
434
435 sub spell_delete {
436 my ($self, $spell) = @_;
437 }
438
439 sub addme_success {
440 my ($self) = @_;
441
442 $self->send ("command output-sync $::CFG->{output_sync}");
443 $self->send ("command output-count $::CFG->{output_count}");
444
445 my $parser = new Pod::POM;
446 my $pod = $parser->parse_file (CFClient::find_rcfile "pod/skill_help.pod");
447
448 my %skill_tooltip;
449
450 for my $head2 ($pod->head1->[-2]->head2) {
451 $skill_tooltip{$head2->title} = CFClient::pod_to_pango $head2->content;
452 }
453
454 for my $skill (values %{$self->{skill_info}}) {
455 $self->{map_widget}->add_command ("ready_skill $skill",
456 (CFClient::UI::Label::escape "Ready the skill '$skill'\n\n")
457 . $skill_tooltip{$skill});
458 $self->{map_widget}->add_command ("use_skill $skill",
459 (CFClient::UI::Label::escape "Immediately use the skill '$skill'\n\n")
460 . $skill_tooltip{$skill});
461 }
462 }
463
464 sub eof {
465 my ($self) = @_;
466
467 $self->{map_widget}->clr_commands;
468
469 ::stop_game ();
470 }
471
472 sub image_info {
473 my ($self, $numfaces) = @_;
474
475 $self->{num_faces} = $numfaces;
476 $self->{face_prefetch} = [1 .. $numfaces];
477 $self->face_prefetch;
478 }
479
480 sub face_prefetch {
481 my ($self) = @_;
482
483 return unless $::CFG->{face_prefetch};
484
485 if ($self->{num_faces}) {
486 return if @{ $self->{send_queue} || [] };
487 my $todo = @{ $self->{face_prefetch} }
488 or return;
489
490 my ($face) = splice @{ $self->{face_prefetch} }, + rand @{ $self->{face_prefetch} }, 1, ();
491
492 $self->send ("requestinfo image_sums $face $face");
493
494 $self->{statusbox}->add (CFClient::UI::Label::escape "prefetching $todo",
495 group => "prefetch", timeout => 2, fg => [1, 1, 0, 0.5]);
496 } elsif (!exists $self->{num_faces}) {
497 $self->send ("requestinfo image_info");
498
499 $self->{num_faces} = 0;
500
501 $self->{statusbox}->add (CFClient::UI::Label::escape "starting to prefetch",
502 group => "prefetch", timeout => 2, fg => [1, 1, 0, 0.5]);
503 }
504 }
505
506 sub update_floorbox {
507 $CFClient::UI::ROOT->on_refresh ($::FLOORBOX => sub {
508 return unless $::CONN;
509
510 $::FLOORBOX->clear;
511
512 my $row;
513 for (@{ $::CONN->{container}{0} }) {
514 if ($row < 7) {
515 local $_->{face_widget}; # hack to force recreation of widget
516 local $_->{desc_widget}; # hack to force recreation of widget
517 CFClient::Item::update_widgets $_;
518
519 $::FLOORBOX->add (0, $row, $_->{face_widget});
520 $::FLOORBOX->add (1, $row, $_->{desc_widget});
521
522 $row++;
523 } else {
524 $::FLOORBOX->add (1, $row, new CFClient::UI::Label text => "More...");
525 last;
526 }
527 }
528 });
529
530 $::WANT_REFRESH++;
531 }
532
533 sub set_opencont {
534 my ($conn, $tag, $name) = @_;
535 $conn->{open_container} = $tag;
536 $::INVR_LBL->set_text ($name);
537 $::INVR->set_items ($conn->{container}{$tag});
538 }
539
540 sub update_container {
541 my ($tag) = @_;
542
543 $::INVR->set_items ($::CONN->{container}{$::CONN->{open_container}})
544 if $tag == $::CONN->{open_container};
545 }
546
547 sub container_add {
548 my ($self, $tag, $items) = @_;
549
550 #d# print "container_add: container $tag ($self->{player}{tag})\n";
551
552 if ($tag == 0) {
553 update_floorbox;
554 update_container (0);
555 } elsif ($tag == $self->{player}{tag}) {
556 $::INV->set_items ($self->{container}{$self->{player}{tag}})
557 } else {
558 update_container ($tag);
559 }
560
561 # $self-<{player}{tag} => player inv
562 #use PApp::Util; warn PApp::Util::dumpval $self->{container}{$self->{player}{tag}};
563 }
564
565 sub container_clear {
566 my ($self, $tag) = @_;
567
568 #d# print "container_clear: container $tag ($self->{player}{tag})\n";
569
570 if ($tag == 0) {
571 update_floorbox;
572 update_container (0);
573 } elsif ($tag == $self->{player}{tag}) {
574 $::INV->set_items ($self->{container}{$tag})
575 }
576
577 # use PApp::Util; warn PApp::Util::dumpval $self->{container}{0};
578 }
579
580 sub item_delete {
581 my ($self, @items) = @_;
582
583 for (@items) {
584 #d# print "item_delete: $_->{tag} from $_->{container} ($self->{player}{tag})\n";
585
586 if ($_->{container} == 0) {
587 update_floorbox;
588 update_container ($_->{tag});
589 } elsif ($_->{container} == $self->{player}{tag}) {
590 $::INV->set_items ($self->{container}{$self->{player}{tag}})
591 } else {
592 update_container ($_->{tag});
593 }
594 }
595 }
596
597 sub item_update {
598 my ($self, $item) = @_;
599
600 #d# print "item_update: $item->{tag} in $item->{container} ($self->{player}{tag}) ($::CONN->{open_container})\n";
601
602 if ($item->{tag} == $self->{player}{tag}) {
603 $::STATWIDS->{weight}->set_text (sprintf "Weight: %.1fkg", $item->{weight} / 1000);
604 return;
605 }
606
607 CFClient::Item::update_widgets $item;
608
609 if ($item->{tag} == $::CONN->{open_container} && not ($item->{flags} & F_OPEN)) {
610 set_opencont ($::CONN, 0, "Floor");
611
612 } elsif ($item->{flags} & F_OPEN) {
613 set_opencont ($::CONN, $item->{tag}, CFClient::Item::desc_string $item);
614 } else {
615 if ($item->{container} == 0) {
616 update_floorbox;
617 update_container (0);
618 } elsif ($item->{container} == $self->{player}{tag}) {
619 $::INV->set_items ($self->{container}{$item->{container}})
620 }
621 }
622 }
623
624 1;