ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC.pm
Revision: 1.76
Committed: Mon May 29 21:20:15 2006 UTC (17 years, 11 months ago) by root
Branch: MAIN
Changes since 1.75: +14 -9 lines
Log Message:
update bdb open flags

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