ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC.pm
Revision: 1.75
Committed: Mon May 29 21:10:47 2006 UTC (17 years, 11 months ago) by root
Branch: MAIN
Changes since 1.74: +4 -4 lines
Log Message:
really rename pclient to cfplus

File Contents

# Content
1 =head1 NAME
2
3 CFClient - undocumented utility garbage for our crossfire client
4
5 =head1 SYNOPSIS
6
7 use CFClient;
8
9 =head1 DESCRIPTION
10
11 =over 4
12
13 =cut
14
15 package CFClient;
16
17 BEGIN {
18 $VERSION = '0.1';
19
20 use XSLoader;
21 XSLoader::load "CFClient", $VERSION;
22 }
23
24 use utf8;
25
26 use Carp ();
27 use AnyEvent ();
28 use BerkeleyDB;
29
30 sub find_rcfile($) {
31 my $path;
32
33 for (grep !ref, @INC) {
34 $path = "$_/CFClient/resources/$_[0]";
35 return $path if -r $path;
36 }
37
38 die "FATAL: can't find required file $_[0]\n";
39 }
40
41 sub read_cfg {
42 my ($file) = @_;
43
44 open CFG, $file
45 or return;
46
47 my $CFG;
48
49 local $/;
50 $CFG = eval <CFG>;
51
52 $::CFG = $CFG;
53
54 close CFG;
55 }
56
57 sub write_cfg {
58 my ($file) = @_;
59
60 open CFG, ">$file"
61 or return;
62
63 {
64 require Data::Dumper;
65 local $Data::Dumper::Purity = 1;
66 $::CFG->{VERSION} = $::VERSION;
67 print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]);
68 }
69
70 close CFG;
71 }
72
73 mkdir "$Crossfire::VARDIR/cfplus", 0777;
74
75 our $DB_ENV = new BerkeleyDB::Env
76 -Home => "$Crossfire::VARDIR/cfplus",
77 -Cachesize => 1_000_000,
78 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
79 # -ErrPrefix => "DATABASE",
80 -Verbose => 1,
81 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN,
82 or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
83
84 sub db_table($) {
85 my ($table) = @_;
86
87 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
88
89 new CFClient::Database
90 -Env => $DB_ENV,
91 -Filename => $table,
92 # -Filename => "database",
93 # -Subname => $table,
94 -Property => DB_CHKSUM,
95 -Flags => DB_CREATE | DB_UPGRADE,
96 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error";
97 }
98
99 sub pod_to_pango($) {
100 my ($pom) = @_;
101
102 $pom->present ("CFClient::PodToPango")
103 }
104
105 sub pod_to_pango_list($) {
106 my ($pom) = @_;
107
108 [
109 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "],
110 split /\n/, $pom->present ("CFClient::PodToPango")
111 ]
112 }
113
114 package CFClient::PodToPango;
115
116 use base Pod::POM::View::Text;
117
118 our $indent = 0;
119
120 *view_seq_code =
121 *view_seq_bold = sub { "<b>$_[1]</b>" };
122 *view_seq_italic = sub { "<i>$_[1]</i>" };
123 *view_seq_space =
124 *view_seq_link =
125 *view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
126
127 sub view_seq_text {
128 my $text = $_[1];
129 $text =~ s/\s+/ /g;
130 CFClient::UI::Label::escape ($text)
131 }
132
133 sub view_item {
134 ("\t" x ($indent / 4))
135 . $_[1]->title->present ($_[0])
136 . "\n"
137 . $_[1]->content->present ($_[0])
138 }
139
140 sub view_verbatim {
141 (join "",
142 map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
143 split /\n/, CFClient::UI::Label::escape ($_[1]))
144 . "\n"
145 }
146
147 sub view_textblock {
148 ("\t" x ($indent / 2)) . "$_[1]\n\n"
149 }
150
151 sub view_head1 {
152 "\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
153 . $_[1]->content->present ($_[0])
154 };
155
156 sub view_head2 {
157 "\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
158 . $_[1]->content->present ($_[0])
159 };
160
161 sub view_head3 {
162 "\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
163 . $_[1]->content->present ($_[0])
164 };
165
166 sub view_over {
167 local $indent = $indent + $_[1]->indent;
168 $_[1]->content->present ($_[0])
169 }
170
171 package CFClient::Database;
172
173 our @ISA = BerkeleyDB::Btree::;
174
175 sub get($$) {
176 my $data;
177
178 $_[0]->db_get ($_[1], $data) == 0
179 ? $data
180 : ()
181 }
182
183 my %DB_SYNC;
184
185 sub put($$$) {
186 my ($db, $key, $data) = @_;
187
188 $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
189
190 $db->db_put ($key => $data)
191 }
192
193 package CFClient::Item;
194
195 use strict;
196 use Crossfire::Protocol::Constants;
197
198 sub desc_string {
199 my ($self) = @_;
200
201 my $desc =
202 $self->{nrof} < 2
203 ? $self->{name}
204 : "$self->{nrof} × $self->{name_pl}";
205
206 $self->{flags} & F_OPEN
207 and $desc .= " (open)";
208 $self->{flags} & F_APPLIED
209 and $desc .= " (applied)";
210 $self->{flags} & F_UNPAID
211 and $desc .= " (unpaid)";
212 $self->{flags} & F_MAGIC
213 and $desc .= " (magic)";
214 $self->{flags} & F_CURSED
215 and $desc .= " (cursed)";
216 $self->{flags} & F_DAMNED
217 and $desc .= " (damned)";
218 $self->{flags} & F_LOCKED
219 and $desc .= " *";
220
221 $desc
222 }
223
224 sub weight_string {
225 my ($self) = @_;
226
227 my $weight = ($self->{nrof} || 1) * $self->{weight};
228
229 $weight < 0 ? "?" : $weight * 0.001
230 }
231
232 sub update_widgets {
233 my ($self) = @_;
234
235 my $button_cb = sub {
236 my (undef, $ev, $x, $y) = @_;
237
238 if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
239 my $targ = $::CONN->{player}{tag};
240
241 if ($self->{container} == $::CONN->{player}{tag}) {
242 $targ = $::CONN->{open_container};
243 }
244
245 $::CONN->send ("move $targ $self->{tag} 0");
246 } elsif ($ev->{button} == 1) {
247 $::CONN->send ("examine $self->{tag}");
248 } elsif ($ev->{button} == 2) {
249 $::CONN->send ("apply $self->{tag}");
250 } elsif ($ev->{button} == 3) {
251 my @menu_items = (
252 ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
253 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
254 ["apply", sub { $::CONN->send ("apply $self->{tag}") }],
255 (
256 $self->{flags} & F_LOCKED
257 ? (
258 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
259 )
260 : (
261 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
262 ["drop", sub { $::CONN->send ("move $::CONN->{open_container} $self->{tag} 0") }],
263 )
264 ),
265 );
266
267 CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
268 }
269
270 1
271 };
272
273 my $tooltip_std = "<small>"
274 . "Left click - examine item\n"
275 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
276 . "Middle click - apply\n"
277 . "Right click - further options"
278 . "</small>\n";
279
280 $self->{face_widget} ||= new CFClient::UI::Face
281 can_events => 1,
282 can_hover => 1,
283 anim => $self->{anim},
284 animspeed => $self->{animspeed}, # TODO# must be set at creation time
285 on_button_down => $button_cb,
286 ;
287 $self->{face_widget}{face} = $self->{face};
288 $self->{face_widget}{anim} = $self->{anim};
289 $self->{face_widget}{animspeed} = $self->{animspeed};
290 $self->{face_widget}->set_tooltip (
291 "<b>Face/Animation.</b>\n"
292 . "Item uses face #$self->{face}. "
293 . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
294 . "\n\n$tooltip_std"
295 );
296
297 $self->{desc_widget} ||= new CFClient::UI::Label
298 can_events => 1,
299 can_hover => 1,
300 ellipsise => 2,
301 align => -1,
302 on_button_down => $button_cb,
303 ;
304 my $desc = CFClient::Item::desc_string $self;
305 $self->{desc_widget}->set_text ($desc);
306 $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
307
308 $self->{weight_widget} ||= new CFClient::UI::Label
309 can_events => 1,
310 can_hover => 1,
311 ellipsise => 0,
312 align => 0,
313 on_button_down => $button_cb,
314 ;
315 $self->{weight_widget}->set_text (CFClient::Item::weight_string $self);
316
317 $self->{weight_widget}->set_tooltip (
318 "<b>Weight</b>.\n"
319 . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
320 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
321 . "\n\n$tooltip_std"
322 );
323 }
324
325 package CFClient::Recorder;
326
327 our $RECORD_WINDOW;
328
329 my $CMDBOX;
330 my $CURRENT_CMDS;
331 my $REC_BTN;
332
333 my @ALLOWED_MODIFIER_KEYS = (
334 (CFClient::SDLK_LSHIFT) => "LSHIFT",
335 (CFClient::SDLK_LCTRL ) => "LCTRL",
336 (CFClient::SDLK_LALT ) => "LALT",
337 (CFClient::SDLK_LMETA ) => "LMETA",
338
339 (CFClient::SDLK_RSHIFT) => "RSHIFT",
340 (CFClient::SDLK_RCTRL ) => "RCTRL",
341 (CFClient::SDLK_RALT ) => "RALT",
342 (CFClient::SDLK_RMETA ) => "RMETA",
343 );
344
345 my %ALLOWED_MODIFIERS = (
346 (CFClient::KMOD_LSHIFT) => "LSHIFT",
347 (CFClient::KMOD_LCTRL ) => "LCTRL",
348 (CFClient::KMOD_LALT ) => "LALT",
349 (CFClient::KMOD_LMETA ) => "LMETA",
350
351 (CFClient::KMOD_RSHIFT) => "RSHIFT",
352 (CFClient::KMOD_RCTRL ) => "RCTRL",
353 (CFClient::KMOD_RALT ) => "RALT",
354 (CFClient::KMOD_RMETA ) => "RMETA",
355 );
356
357 my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/;
358 my @DIRECT_BIND_KEYS = (
359 CFClient::SDLK_F1,
360 CFClient::SDLK_F2,
361 CFClient::SDLK_F3,
362 CFClient::SDLK_F4,
363 CFClient::SDLK_F5,
364 CFClient::SDLK_F6,
365 CFClient::SDLK_F7,
366 CFClient::SDLK_F8,
367 CFClient::SDLK_F9,
368 CFClient::SDLK_F10,
369 CFClient::SDLK_F11,
370 CFClient::SDLK_F12,
371 CFClient::SDLK_F13,
372 CFClient::SDLK_F14,
373 CFClient::SDLK_F15,
374 );
375
376 # this binding dialog asks for a key-combo to be pressed
377 # and if successful it binds the modifier+symbol to the
378 # supplied actions in $cmd.
379 # (Bindings are stored in $::CFG->{bindings}->{$mod}->{$sym})
380 sub open_binding_dialog {
381 my ($cmd) = @_;
382
383 my $w = new CFClient::UI::FancyFrame
384 title => "Bind Action";
385
386 $w->add (my $vb = new CFClient::UI::VBox);
387 $vb->add (new CFClient::UI::Label
388 text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
389 ."You can only bind 0-9 and F1-F15 without modifiers."
390 );
391 $vb->add (my $entry = new CFClient::UI::Entry
392 text => "",
393 on_key_down => sub {
394 my ($entry, $ev) = @_;
395
396 my $mod = $ev->{mod};
397 my $sym = $ev->{sym};
398
399 # XXX: This seems a little bit hackisch to me, but i have to ignore them
400 if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) {
401 return;
402 }
403
404 if ($mod == CFClient::KMOD_NONE
405 and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})}
406 and not grep { $sym == $_ } @DIRECT_BIND_KEYS)
407 {
408 $::STATUSBOX->add (
409 "Can't bind key ".CFClient::SDL_GetKeyName ($sym)
410 ." directly without modifier! It would damage the completer handling."
411 );
412 return;
413 }
414
415 $entry->focus_out;
416
417 $::CFG->{bindings}->{$mod}->{$sym} = $cmd;
418 $::STATUSBOX->add ("Bound actions to '".keycombo_to_name ($mod, $sym)."'. Don't forget 'Save Config'!");
419
420 $w->destroy
421 });
422
423 $entry->focus_in;
424 $w->center;
425 $w->show;
426 }
427
428 sub keycombo_to_name {
429 my ($mod, $sym) = @_;
430
431 my $mods = join '+',
432 map { $ALLOWED_MODIFIERS{$_} }
433 grep { $_ & $mod }
434 keys %ALLOWED_MODIFIERS;
435 $mods .= "+" if $mods ne '';
436
437 return $mods . CFClient::SDL_GetKeyName ($sym);
438 }
439
440 sub clear_command_list {
441 $CMDBOX->clear () if $CMDBOX;
442 }
443
444 sub set_command_list {
445 my ($list) = @_;
446
447 return unless $CMDBOX;
448
449 $CMDBOX->clear ();
450 $CURRENT_CMDS = $list;
451
452 my $idx = 0;
453
454 for (@$list) {
455 $CMDBOX->add (my $hb = new CFClient::UI::HBox);
456
457 my $i = $idx;
458 $hb->add (new CFClient::UI::Button
459 text => "delete",
460 tooltip => "Deletes the action from the record",
461 on_activate => sub {
462 $CMDBOX->remove ($hb);
463 $list->[$i] = undef;
464 });
465
466 $hb->add (new CFClient::UI::Label text => $_);
467
468 $idx++
469 }
470 }
471
472 # if $show is 1 the recorder will be shown
473 sub start {
474 my ($show) = @_;
475
476 $RECORD_WINDOW->show if $show;
477
478 $REC_BTN->set_text ("stop recording");
479 $REC_BTN->{recording} = 1;
480 clear_command_list;
481 $::CONN->start_record;
482 }
483
484 # if $autobind is 1 the recorder will be automatically
485 # jump into the binding query and hide the recorder window
486 sub stop {
487 my ($autobind) = @_;
488
489 $REC_BTN->set_text ("start recording");
490 $REC_BTN->{recording} = 0;
491
492 my $rec = $::CONN->stop_record;
493 return unless ref $rec eq 'ARRAY';
494 set_command_list ($rec);
495
496 if ($autobind) {
497 open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
498 $RECORD_WINDOW->hide;
499 }
500 }
501
502 sub make_window {
503 $RECORD_WINDOW = new CFClient::UI::FancyFrame
504 req_y => 1,
505 req_x => -1,
506 title => "Action Recorder";
507
508 $RECORD_WINDOW->add (my $vb = new CFClient::UI::VBox);
509 $vb->add ($REC_BTN = new CFClient::UI::Button
510 text => "start recording",
511 tooltip => "Start/Stops recording of actions."
512 ."(CTRL+Insert Starts the recorder, Insert Stops recorder and binds automatically)"
513 ."All subsequent actions after the recording started will be captured."
514 ."The actions are displayed after the record was stopped."
515 ."To bind the action you have to click on the 'Bind' button",
516 on_activate => sub {
517 my ($btn) = @_;
518
519 unless ($btn->{recording}) {
520 start;
521 } else {
522 stop;
523 }
524 });
525 $vb->add ($CMDBOX = new CFClient::UI::VBox);
526 $vb->add (new CFClient::UI::Button
527 text => "bind",
528 tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
529 on_activate => sub {
530 open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
531 });
532
533 $RECORD_WINDOW
534 }
535
536 1;
537
538 =back
539
540 =head1 AUTHOR
541
542 Marc Lehmann <schmorp@schmorp.de>
543 http://home.schmorp.de/
544
545 =cut
546