ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC/Protocol.pm
Revision: 1.1
Committed: Fri May 26 18:56:14 2006 UTC (18 years ago) by root
Branch: MAIN
Log Message:
unbundled conn:: into CFClient::Protocol (not well-tested)

File Contents

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