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.75 by root, Mon May 29 21:10:47 2006 UTC vs.
Revision 1.91 by root, Wed Jun 7 06:28:28 2006 UTC

… …
24use utf8; 24use utf8;
25 25
26use Carp (); 26use Carp ();
27use AnyEvent (); 27use AnyEvent ();
28use BerkeleyDB; 28use BerkeleyDB;
29use Pod::POM ();
30use Storable (); # finally
31
32package CFClient::PodToPango;
33
34use base Pod::POM::View::Text;
35
36our $VERSION = 1; # bump if resultant formatting changes
37
38our $indent = 0;
39
40*view_seq_code =
41*view_seq_bold = sub { "<b>$_[1]</b>" };
42*view_seq_italic = sub { "<i>$_[1]</i>" };
43*view_seq_space =
44*view_seq_link =
45*view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
46
47sub view_seq_text {
48 my $text = $_[1];
49 $text =~ s/\s+/ /g;
50 CFClient::UI::Label::escape ($text)
51}
52
53sub view_item {
54 ("\t" x ($indent / 4))
55 . $_[1]->title->present ($_[0])
56 . "\n\n"
57 . $_[1]->content->present ($_[0])
58}
59
60sub view_verbatim {
61 (join "",
62 map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
63 split /\n/, CFClient::UI::Label::escape ($_[1]))
64 . "\n"
65}
66
67sub view_textblock {
68 ("\t" x ($indent / 2)) . "$_[1]\n\n"
69}
70
71sub view_head1 {
72 "\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
73 . $_[1]->content->present ($_[0])
74};
75
76sub view_head2 {
77 "\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
78 . $_[1]->content->present ($_[0])
79};
80
81sub view_head3 {
82 "\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
83 . $_[1]->content->present ($_[0])
84};
85
86sub view_over {
87 local $indent = $indent + $_[1]->indent;
88 $_[1]->content->present ($_[0])
89}
90
91package CFClient::Database;
92
93our @ISA = BerkeleyDB::Btree::;
94
95sub get($$) {
96 my $data;
97
98 $_[0]->db_get ($_[1], $data) == 0
99 ? $data
100 : ()
101}
102
103my %DB_SYNC;
104
105sub put($$$) {
106 my ($db, $key, $data) = @_;
107
108 $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
109
110 $db->db_put ($key => $data)
111}
112
113package CFClient;
29 114
30sub find_rcfile($) { 115sub find_rcfile($) {
31 my $path; 116 my $path;
32 117
33 for (grep !ref, @INC) { 118 for (grep !ref, @INC) {
… …
68 } 153 }
69 154
70 close CFG; 155 close CFG;
71} 156}
72 157
158our $DB_ENV;
159
160{
161 use strict;
162
73mkdir "$Crossfire::VARDIR/cfplus", 0777; 163 mkdir "$Crossfire::VARDIR/cfplus", 0777;
164 my $recover = $BerkeleyDB::db_version >= 4.4
165 ? eval "DB_REGISTER | DB_RECOVER"
166 : 0;
74 167
75our $DB_ENV = new BerkeleyDB::Env 168 $DB_ENV = new BerkeleyDB::Env
76 -Home => "$Crossfire::VARDIR/cfplus", 169 -Home => "$Crossfire::VARDIR/cfplus",
77 -Cachesize => 1_000_000, 170 -Cachesize => 1_000_000,
78 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt", 171 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
79# -ErrPrefix => "DATABASE", 172# -ErrPrefix => "DATABASE",
80 -Verbose => 1, 173 -Verbose => 1,
81 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN, 174 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover,
175 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
82 or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error"; 176 or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
177}
83 178
84sub db_table($) { 179sub db_table($) {
85 my ($table) = @_; 180 my ($table) = @_;
86 181
87 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 182 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
88 183
89 new CFClient::Database 184 new CFClient::Database
90 -Env => $DB_ENV, 185 -Env => $DB_ENV,
91 -Filename => $table, 186 -Filename => $table,
92# -Filename => "database", 187# -Filename => "database",
93# -Subname => $table, 188# -Subname => $table,
94 -Property => DB_CHKSUM, 189 -Property => DB_CHKSUM,
95 -Flags => DB_CREATE | DB_UPGRADE, 190 -Flags => DB_CREATE | DB_UPGRADE,
96 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"; 191 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
192}
193
194my $pod_cache = db_table "pod_cache";
195
196sub load_pod($$$$) {
197 my ($path, $filtertype, $filterversion, $filtercb) = @_;
198
199 stat $path
200 or die "$path: $!";
201
202 my $phash = join ",", $filterversion, $CFClient::PodToPango::VERSION, (stat _)[7,9];
203
204 my ($chash, $pom) = eval { @{ Storable::thaw $pod_cache->get ("$path/$filtertype") } };
205
206 return $pom if $chash eq $phash;
207
208 my $pod = do {
209 local $/;
210 open my $pod, "<:utf8", $_[0]
211 or die "$_[0]: $!";
212 <$pod>
213 };
214
215 #utf8::downgrade $pod;
216
217 $pom = $filtercb-> (Pod::POM->new->parse_text ($pod));
218
219 $pod_cache->put ("$path/$filtertype" => Storable::nfreeze [$phash, $pom]);
220
221 $pom
97} 222}
98 223
99sub pod_to_pango($) { 224sub pod_to_pango($) {
100 my ($pom) = @_; 225 my ($pom) = @_;
101 226
… …
109 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "], 234 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "],
110 split /\n/, $pom->present ("CFClient::PodToPango") 235 split /\n/, $pom->present ("CFClient::PodToPango")
111 ] 236 ]
112} 237}
113 238
114package CFClient::PodToPango;
115
116use base Pod::POM::View::Text;
117
118our $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
127sub view_seq_text {
128 my $text = $_[1];
129 $text =~ s/\s+/ /g;
130 CFClient::UI::Label::escape ($text)
131}
132
133sub view_item {
134 ("\t" x ($indent / 4))
135 . $_[1]->title->present ($_[0])
136 . "\n"
137 . $_[1]->content->present ($_[0])
138}
139
140sub 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
147sub view_textblock {
148 ("\t" x ($indent / 2)) . "$_[1]\n\n"
149}
150
151sub 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
156sub view_head2 {
157 "\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
158 . $_[1]->content->present ($_[0])
159};
160
161sub view_head3 {
162 "\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
163 . $_[1]->content->present ($_[0])
164};
165
166sub view_over {
167 local $indent = $indent + $_[1]->indent;
168 $_[1]->content->present ($_[0])
169}
170
171package CFClient::Database;
172
173our @ISA = BerkeleyDB::Btree::;
174
175sub get($$) {
176 my $data;
177
178 $_[0]->db_get ($_[1], $data) == 0
179 ? $data
180 : ()
181}
182
183my %DB_SYNC;
184
185sub 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
193package CFClient::Item; 239package CFClient::Item;
194 240
195use strict; 241use strict;
196use Crossfire::Protocol::Constants; 242use Crossfire::Protocol::Constants;
243
244my $last_enter_count = 1;
197 245
198sub desc_string { 246sub desc_string {
199 my ($self) = @_; 247 my ($self) = @_;
200 248
201 my $desc = 249 my $desc =
… …
227 my $weight = ($self->{nrof} || 1) * $self->{weight}; 275 my $weight = ($self->{nrof} || 1) * $self->{weight};
228 276
229 $weight < 0 ? "?" : $weight * 0.001 277 $weight < 0 ? "?" : $weight * 0.001
230} 278}
231 279
280sub do_n_dialog {
281 my ($cb) = @_;
282
283 my $w = new CFClient::UI::FancyFrame;
284 $w->add (my $vb = new CFClient::UI::VBox x => "center", y => "center");
285 $vb->add (new CFClient::UI::Label text => "Enter item count:");
286 $vb->add (my $entry = new CFClient::UI::Entry
287 text => $last_enter_count,
288 on_activate => sub {
289 my ($entry) = @_;
290 $last_enter_count = $entry->get_text;
291 $cb->($last_enter_count);
292 $w->hide;
293 $w = undef;
294 }
295 );
296 $entry->focus_in;
297 $w->show;
298
299}
300
232sub update_widgets { 301sub update_widgets {
233 my ($self) = @_; 302 my ($self) = @_;
234 303
235 my $button_cb = sub { 304 my $button_cb = sub {
236 my (undef, $ev, $x, $y) = @_; 305 my (undef, $ev, $x, $y) = @_;
237 306
307 my $targ = $::CONN->{player}{tag};
308
309 if ($self->{container} == $::CONN->{player}{tag}) {
310 $targ = $::CONN->{open_container};
311 }
312
238 if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) { 313 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"); 314 $::CONN->send ("move $targ $self->{tag} 0")
315 if $targ || !($self->{flags} & F_LOCKED);
316 } elsif (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 2) {
317 $self->{flags} & F_LOCKED
318 ? $::CONN->send ("lock " . pack "CN", 0, $self->{tag})
319 : $::CONN->send ("lock " . pack "CN", 1, $self->{tag})
246 } elsif ($ev->{button} == 1) { 320 } elsif ($ev->{button} == 1) {
247 $::CONN->send ("examine $self->{tag}"); 321 $::CONN->send ("examine $self->{tag}");
248 } elsif ($ev->{button} == 2) { 322 } elsif ($ev->{button} == 2) {
249 $::CONN->send ("apply $self->{tag}"); 323 $::CONN->send ("apply $self->{tag}");
250 } elsif ($ev->{button} == 3) { 324 } elsif ($ev->{button} == 3) {
… …
258 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }], 332 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
259 ) 333 )
260 : ( 334 : (
261 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }], 335 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
262 ["drop", sub { $::CONN->send ("move $::CONN->{open_container} $self->{tag} 0") }], 336 ["drop", sub { $::CONN->send ("move $::CONN->{open_container} $self->{tag} 0") }],
337 ["move n",
338 sub {
339 do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
340 }
341 ]
263 ) 342 )
264 ), 343 ),
265 ); 344 );
266 345
267 CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev); 346 CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
… …
272 351
273 my $tooltip_std = "<small>" 352 my $tooltip_std = "<small>"
274 . "Left click - examine item\n" 353 . "Left click - examine item\n"
275 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n" 354 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
276 . "Middle click - apply\n" 355 . "Middle click - apply\n"
356 . "Shift-Middle click - lock/unlock\n"
277 . "Right click - further options" 357 . "Right click - further options"
278 . "</small>\n"; 358 . "</small>\n";
279 359
280 $self->{face_widget} ||= new CFClient::UI::Face 360 $self->{face_widget} ||= new CFClient::UI::Face
281 can_events => 1, 361 can_events => 1,
… …
320 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ") 400 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
321 . "\n\n$tooltip_std" 401 . "\n\n$tooltip_std"
322 ); 402 );
323} 403}
324 404
325package CFClient::Recorder; 405package CFClient::Binder;
326
327our $RECORD_WINDOW;
328
329my $CMDBOX;
330my $CURRENT_CMDS;
331my $REC_BTN;
332 406
333my @ALLOWED_MODIFIER_KEYS = ( 407my @ALLOWED_MODIFIER_KEYS = (
334 (CFClient::SDLK_LSHIFT) => "LSHIFT", 408 CFClient::SDLK_LSHIFT,
335 (CFClient::SDLK_LCTRL ) => "LCTRL", 409 CFClient::SDLK_LCTRL ,
336 (CFClient::SDLK_LALT ) => "LALT", 410 CFClient::SDLK_LALT ,
337 (CFClient::SDLK_LMETA ) => "LMETA", 411 CFClient::SDLK_LMETA ,
338 412
339 (CFClient::SDLK_RSHIFT) => "RSHIFT", 413 CFClient::SDLK_RSHIFT,
340 (CFClient::SDLK_RCTRL ) => "RCTRL", 414 CFClient::SDLK_RCTRL ,
341 (CFClient::SDLK_RALT ) => "RALT", 415 CFClient::SDLK_RALT ,
342 (CFClient::SDLK_RMETA ) => "RMETA", 416 CFClient::SDLK_RMETA ,
343); 417);
344 418
345my %ALLOWED_MODIFIERS = ( 419my %ALLOWED_MODIFIERS = (
346 (CFClient::KMOD_LSHIFT) => "LSHIFT", 420 CFClient::KMOD_LSHIFT => "LSHIFT",
347 (CFClient::KMOD_LCTRL ) => "LCTRL", 421 CFClient::KMOD_LCTRL => "LCTRL",
348 (CFClient::KMOD_LALT ) => "LALT", 422 CFClient::KMOD_LALT => "LALT",
349 (CFClient::KMOD_LMETA ) => "LMETA", 423 CFClient::KMOD_LMETA => "LMETA",
350 424
351 (CFClient::KMOD_RSHIFT) => "RSHIFT", 425 CFClient::KMOD_RSHIFT => "RSHIFT",
352 (CFClient::KMOD_RCTRL ) => "RCTRL", 426 CFClient::KMOD_RCTRL => "RCTRL",
353 (CFClient::KMOD_RALT ) => "RALT", 427 CFClient::KMOD_RALT => "RALT",
354 (CFClient::KMOD_RMETA ) => "RMETA", 428 CFClient::KMOD_RMETA => "RMETA",
355); 429);
356 430
357my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/; 431my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/;
358my @DIRECT_BIND_KEYS = ( 432my @DIRECT_BIND_KEYS = (
359 CFClient::SDLK_F1, 433 CFClient::SDLK_F1,
… …
372 CFClient::SDLK_F14, 446 CFClient::SDLK_F14,
373 CFClient::SDLK_F15, 447 CFClient::SDLK_F15,
374); 448);
375 449
376# this binding dialog asks for a key-combo to be pressed 450# this binding dialog asks for a key-combo to be pressed
377# and if successful it binds the modifier+symbol to the 451# and if successful it calls the $cb with $mod and $sym as args.
378# supplied actions in $cmd.
379# (Bindings are stored in $::CFG->{bindings}->{$mod}->{$sym})
380sub open_binding_dialog { 452sub open_binding_dialog {
381 my ($cmd) = @_; 453 my ($cb) = @_;
382 454
383 my $w = new CFClient::UI::FancyFrame 455 my $w = new CFClient::UI::FancyFrame
384 title => "Bind Action"; 456 title => "Bind Action",
457 x => "center",
458 y => "center";
385 459
386 $w->add (my $vb = new CFClient::UI::VBox); 460 $w->add (my $vb = new CFClient::UI::VBox);
387 $vb->add (new CFClient::UI::Label 461 $vb->add (new CFClient::UI::Label
388 text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key." 462 text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
389 ."You can only bind 0-9 and F1-F15 without modifiers." 463 ."You can only bind 0-9 and F1-F15 without modifiers."
… …
412 return; 486 return;
413 } 487 }
414 488
415 $entry->focus_out; 489 $entry->focus_out;
416 490
417 $::CFG->{bindings}->{$mod}->{$sym} = $cmd; 491 $cb->($mod, $sym);
418 $::STATUSBOX->add ("Bound actions to '".keycombo_to_name ($mod, $sym)."'. Don't forget 'Save Config'!");
419 492
420 $w->destroy 493 $w->destroy
421 }); 494 });
422 495
423 $entry->focus_in; 496 $entry->focus_in;
424 $w->center;
425 $w->show; 497 $w->show;
426} 498}
427 499
428sub keycombo_to_name { 500sub keycombo_to_name {
429 my ($mod, $sym) = @_; 501 my ($mod, $sym) = @_;
430 502
431 my $mods = join '+', 503 my $mods = join '+',
432 map { $ALLOWED_MODIFIERS{$_} } 504 map { $ALLOWED_MODIFIERS{$_} }
433 grep { $_ & $mod } 505 grep { ($_ + 0) & ($mod + 0) }
434 keys %ALLOWED_MODIFIERS; 506 keys %ALLOWED_MODIFIERS;
435 $mods .= "+" if $mods ne ''; 507 $mods .= "+" if $mods ne '';
436 508
437 return $mods . CFClient::SDL_GetKeyName ($sym); 509 return $mods . CFClient::SDL_GetKeyName ($sym);
438} 510}
439 511
440sub clear_command_list {
441 $CMDBOX->clear () if $CMDBOX;
442}
443
444sub 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
473sub 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
486sub 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
502sub 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
5361; 5121;
537 513
538=back 514=back
539 515
540=head1 AUTHOR 516=head1 AUTHOR

Diff Legend

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