ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC/Protocol.pm
Revision: 1.21
Committed: Mon Jun 5 21:10:04 2006 UTC (18 years ago) by root
Branch: MAIN
Changes since 1.20: +34 -21 lines
Log Message:
cache data created by parsing pods, as even loading a POM object with storable is extremely slow

File Contents

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