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.76 by root, Mon May 29 21:20:15 2006 UTC vs.
Revision 1.93 by root, Sun Jun 18 17:13: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; 159our $DB_ENV;
74 160
75{ 161{
76 use strict; 162 use strict;
77 163
164 mkdir "$Crossfire::VARDIR/cfplus", 0777;
165 my $recover = $BerkeleyDB::db_version >= 4.4
166 ? eval "DB_REGISTER | DB_RECOVER"
167 : 0;
168
78 our $DB_ENV = new BerkeleyDB::Env 169 $DB_ENV = new BerkeleyDB::Env
79 -Home => "$Crossfire::VARDIR/cfplus", 170 -Home => "$Crossfire::VARDIR/cfplus",
80 -Cachesize => 1_000_000, 171 -Cachesize => 1_000_000,
81 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt", 172 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
82# -ErrPrefix => "DATABASE", 173# -ErrPrefix => "DATABASE",
83 -Verbose => 1, 174 -Verbose => 1,
84 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN, 175 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover,
85 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE | DB_TXN_WRITE_NOSYNC, 176 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
86 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";
87} 178}
88 179
89sub db_table($) { 180sub db_table($) {
90 my ($table) = @_; 181 my ($table) = @_;
… …
99 -Property => DB_CHKSUM, 190 -Property => DB_CHKSUM,
100 -Flags => DB_CREATE | DB_UPGRADE, 191 -Flags => DB_CREATE | DB_UPGRADE,
101 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error" 192 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
102} 193}
103 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
104sub pod_to_pango($) { 225sub pod_to_pango($) {
105 my ($pom) = @_; 226 my ($pom) = @_;
106 227
107 $pom->present ("CFClient::PodToPango") 228 $pom->present ("CFClient::PodToPango")
108} 229}
… …
114 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "], 235 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "],
115 split /\n/, $pom->present ("CFClient::PodToPango") 236 split /\n/, $pom->present ("CFClient::PodToPango")
116 ] 237 ]
117} 238}
118 239
119package CFClient::PodToPango;
120
121use base Pod::POM::View::Text;
122
123our $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
132sub view_seq_text {
133 my $text = $_[1];
134 $text =~ s/\s+/ /g;
135 CFClient::UI::Label::escape ($text)
136}
137
138sub view_item {
139 ("\t" x ($indent / 4))
140 . $_[1]->title->present ($_[0])
141 . "\n"
142 . $_[1]->content->present ($_[0])
143}
144
145sub 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
152sub view_textblock {
153 ("\t" x ($indent / 2)) . "$_[1]\n\n"
154}
155
156sub 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
161sub view_head2 {
162 "\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
163 . $_[1]->content->present ($_[0])
164};
165
166sub view_head3 {
167 "\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
168 . $_[1]->content->present ($_[0])
169};
170
171sub view_over {
172 local $indent = $indent + $_[1]->indent;
173 $_[1]->content->present ($_[0])
174}
175
176package CFClient::Database;
177
178our @ISA = BerkeleyDB::Btree::;
179
180sub get($$) {
181 my $data;
182
183 $_[0]->db_get ($_[1], $data) == 0
184 ? $data
185 : ()
186}
187
188my %DB_SYNC;
189
190sub 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
198package CFClient::Item; 240package CFClient::Item;
199 241
200use strict; 242use strict;
201use Crossfire::Protocol::Constants; 243use Crossfire::Protocol::Constants;
244
245my $last_enter_count = 1;
202 246
203sub desc_string { 247sub desc_string {
204 my ($self) = @_; 248 my ($self) = @_;
205 249
206 my $desc = 250 my $desc =
… …
232 my $weight = ($self->{nrof} || 1) * $self->{weight}; 276 my $weight = ($self->{nrof} || 1) * $self->{weight};
233 277
234 $weight < 0 ? "?" : $weight * 0.001 278 $weight < 0 ? "?" : $weight * 0.001
235} 279}
236 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
237sub update_widgets { 302sub update_widgets {
238 my ($self) = @_; 303 my ($self) = @_;
239 304
305 # necessary to avoid cyclic references
306 Scalar::Util::weaken $self;
307
240 my $button_cb = sub { 308 my $button_cb = sub {
241 my (undef, $ev, $x, $y) = @_; 309 my (undef, $ev, $x, $y) = @_;
242 310
311 my $targ = $::CONN->{player}{tag};
312
313 if ($self->{container} == $::CONN->{player}{tag}) {
314 $targ = $::CONN->{open_container};
315 }
316
243 if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) { 317 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"); 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})
251 } elsif ($ev->{button} == 1) { 324 } elsif ($ev->{button} == 1) {
252 $::CONN->send ("examine $self->{tag}"); 325 $::CONN->send ("examine $self->{tag}");
253 } elsif ($ev->{button} == 2) { 326 } elsif ($ev->{button} == 2) {
254 $::CONN->send ("apply $self->{tag}"); 327 $::CONN->send ("apply $self->{tag}");
255 } elsif ($ev->{button} == 3) { 328 } elsif ($ev->{button} == 3) {
… …
263 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }], 336 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
264 ) 337 )
265 : ( 338 : (
266 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }], 339 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
267 ["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 ]
268 ) 346 )
269 ), 347 ),
270 ); 348 );
271 349
272 CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev); 350 CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
… …
277 355
278 my $tooltip_std = "<small>" 356 my $tooltip_std = "<small>"
279 . "Left click - examine item\n" 357 . "Left click - examine item\n"
280 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n" 358 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
281 . "Middle click - apply\n" 359 . "Middle click - apply\n"
360 . "Shift-Middle click - lock/unlock\n"
282 . "Right click - further options" 361 . "Right click - further options"
283 . "</small>\n"; 362 . "</small>\n";
284 363
285 $self->{face_widget} ||= new CFClient::UI::Face 364 $self->{face_widget} ||= new CFClient::UI::Face
286 can_events => 1, 365 can_events => 1,
… …
325 . ($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. ")
326 . "\n\n$tooltip_std" 405 . "\n\n$tooltip_std"
327 ); 406 );
328} 407}
329 408
330package CFClient::Recorder; 409package CFClient::Binder;
331
332our $RECORD_WINDOW;
333
334my $CMDBOX;
335my $CURRENT_CMDS;
336my $REC_BTN;
337 410
338my @ALLOWED_MODIFIER_KEYS = ( 411my @ALLOWED_MODIFIER_KEYS = (
339 (CFClient::SDLK_LSHIFT) => "LSHIFT", 412 CFClient::SDLK_LSHIFT,
340 (CFClient::SDLK_LCTRL ) => "LCTRL", 413 CFClient::SDLK_LCTRL ,
341 (CFClient::SDLK_LALT ) => "LALT", 414 CFClient::SDLK_LALT ,
342 (CFClient::SDLK_LMETA ) => "LMETA", 415 CFClient::SDLK_LMETA ,
343 416
344 (CFClient::SDLK_RSHIFT) => "RSHIFT", 417 CFClient::SDLK_RSHIFT,
345 (CFClient::SDLK_RCTRL ) => "RCTRL", 418 CFClient::SDLK_RCTRL ,
346 (CFClient::SDLK_RALT ) => "RALT", 419 CFClient::SDLK_RALT ,
347 (CFClient::SDLK_RMETA ) => "RMETA", 420 CFClient::SDLK_RMETA ,
348); 421);
349 422
350my %ALLOWED_MODIFIERS = ( 423my %ALLOWED_MODIFIERS = (
351 (CFClient::KMOD_LSHIFT) => "LSHIFT", 424 CFClient::KMOD_LSHIFT => "LSHIFT",
352 (CFClient::KMOD_LCTRL ) => "LCTRL", 425 CFClient::KMOD_LCTRL => "LCTRL",
353 (CFClient::KMOD_LALT ) => "LALT", 426 CFClient::KMOD_LALT => "LALT",
354 (CFClient::KMOD_LMETA ) => "LMETA", 427 CFClient::KMOD_LMETA => "LMETA",
355 428
356 (CFClient::KMOD_RSHIFT) => "RSHIFT", 429 CFClient::KMOD_RSHIFT => "RSHIFT",
357 (CFClient::KMOD_RCTRL ) => "RCTRL", 430 CFClient::KMOD_RCTRL => "RCTRL",
358 (CFClient::KMOD_RALT ) => "RALT", 431 CFClient::KMOD_RALT => "RALT",
359 (CFClient::KMOD_RMETA ) => "RMETA", 432 CFClient::KMOD_RMETA => "RMETA",
360); 433);
361 434
362my %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/;
363my @DIRECT_BIND_KEYS = ( 436my @DIRECT_BIND_KEYS = (
364 CFClient::SDLK_F1, 437 CFClient::SDLK_F1,
… …
377 CFClient::SDLK_F14, 450 CFClient::SDLK_F14,
378 CFClient::SDLK_F15, 451 CFClient::SDLK_F15,
379); 452);
380 453
381# this binding dialog asks for a key-combo to be pressed 454# this binding dialog asks for a key-combo to be pressed
382# and if successful it binds the modifier+symbol to the 455# and if successful it calls the $cb with $mod and $sym as args.
383# supplied actions in $cmd.
384# (Bindings are stored in $::CFG->{bindings}->{$mod}->{$sym})
385sub open_binding_dialog { 456sub open_binding_dialog {
386 my ($cmd) = @_; 457 my ($cb) = @_;
387 458
388 my $w = new CFClient::UI::FancyFrame 459 my $w = new CFClient::UI::FancyFrame
389 title => "Bind Action"; 460 title => "Bind Action",
461 x => "center",
462 y => "center";
390 463
391 $w->add (my $vb = new CFClient::UI::VBox); 464 $w->add (my $vb = new CFClient::UI::VBox);
392 $vb->add (new CFClient::UI::Label 465 $vb->add (new CFClient::UI::Label
393 text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key." 466 text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
394 ."You can only bind 0-9 and F1-F15 without modifiers." 467 ."You can only bind 0-9 and F1-F15 without modifiers."
… …
415 ." directly without modifier! It would damage the completer handling." 488 ." directly without modifier! It would damage the completer handling."
416 ); 489 );
417 return; 490 return;
418 } 491 }
419 492
420 $entry->focus_out; 493 $entry->grab_focus;
421 494
422 $::CFG->{bindings}->{$mod}->{$sym} = $cmd; 495 $cb->($mod, $sym);
423 $::STATUSBOX->add ("Bound actions to '".keycombo_to_name ($mod, $sym)."'. Don't forget 'Save Config'!");
424 496
425 $w->destroy 497 $w->destroy
426 }); 498 });
427 499
428 $entry->focus_in; 500 $entry->grab_focus;
429 $w->center;
430 $w->show; 501 $w->show;
431} 502}
432 503
433sub keycombo_to_name { 504sub keycombo_to_name {
434 my ($mod, $sym) = @_; 505 my ($mod, $sym) = @_;
435 506
436 my $mods = join '+', 507 my $mods = join '+',
437 map { $ALLOWED_MODIFIERS{$_} } 508 map { $ALLOWED_MODIFIERS{$_} }
438 grep { $_ & $mod } 509 grep { ($_ + 0) & ($mod + 0) }
439 keys %ALLOWED_MODIFIERS; 510 keys %ALLOWED_MODIFIERS;
440 $mods .= "+" if $mods ne ''; 511 $mods .= "+" if $mods ne '';
441 512
442 return $mods . CFClient::SDL_GetKeyName ($sym); 513 return $mods . CFClient::SDL_GetKeyName ($sym);
443} 514}
444 515
445sub clear_command_list {
446 $CMDBOX->clear () if $CMDBOX;
447}
448
449sub 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
478sub 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
491sub 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
507sub 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
5411; 5161;
542 517
543=back 518=back
544 519
545=head1 AUTHOR 520=head1 AUTHOR

Diff Legend

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