ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC.pm
(Generate patch)

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.77 by root, Mon May 29 21:54:15 2006 UTC vs.
Revision 1.94 by elmex, Wed Jun 28 09:45:10 2006 UTC

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

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines