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.73 by elmex, Mon May 29 19:30:27 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
159our $DB_ENV;
160
161{
162 use strict;
163
73mkdir "$Crossfire::VARDIR/pclient", 0777; 164 mkdir "$Crossfire::VARDIR/cfplus", 0777;
165 my $recover = $BerkeleyDB::db_version >= 4.4
166 ? eval "DB_REGISTER | DB_RECOVER"
167 : 0;
74 168
75our $DB_ENV = new BerkeleyDB::Env 169 $DB_ENV = new BerkeleyDB::Env
76 -Home => "$Crossfire::VARDIR/pclient", 170 -Home => "$Crossfire::VARDIR/cfplus",
77 -Cachesize => 1_000_000, 171 -Cachesize => 1_000_000,
78 -ErrFile => "$Crossfire::VARDIR/pclient/errorlog.txt", 172 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
79# -ErrPrefix => "DATABASE", 173# -ErrPrefix => "DATABASE",
80 -Verbose => 1, 174 -Verbose => 1,
81 -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,
176 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
82 or die "unable to create/open database home $Crossfire::VARDIR/pclient: $BerkeleyDB::Error"; 177 or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
178}
83 179
84sub db_table($) { 180sub db_table($) {
85 my ($table) = @_; 181 my ($table) = @_;
86 182
87 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 183 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
88 184
89 new CFClient::Database 185 new CFClient::Database
90 -Env => $DB_ENV, 186 -Env => $DB_ENV,
91 -Filename => $table, 187 -Filename => $table,
92# -Filename => "database", 188# -Filename => "database",
93# -Subname => $table, 189# -Subname => $table,
94 -Property => DB_CHKSUM, 190 -Property => DB_CHKSUM,
95 -Flags => DB_CREATE | DB_UPGRADE, 191 -Flags => DB_CREATE | DB_UPGRADE,
96 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"; 192 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
193}
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
97} 223}
98 224
99sub pod_to_pango($) { 225sub pod_to_pango($) {
100 my ($pom) = @_; 226 my ($pom) = @_;
101 227
… …
109 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "], 235 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "],
110 split /\n/, $pom->present ("CFClient::PodToPango") 236 split /\n/, $pom->present ("CFClient::PodToPango")
111 ] 237 ]
112} 238}
113 239
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; 240package CFClient::Item;
194 241
195use strict; 242use strict;
196use Crossfire::Protocol::Constants; 243use Crossfire::Protocol::Constants;
244
245my $last_enter_count = 1;
197 246
198sub desc_string { 247sub desc_string {
199 my ($self) = @_; 248 my ($self) = @_;
200 249
201 my $desc = 250 my $desc =
… …
227 my $weight = ($self->{nrof} || 1) * $self->{weight}; 276 my $weight = ($self->{nrof} || 1) * $self->{weight};
228 277
229 $weight < 0 ? "?" : $weight * 0.001 278 $weight < 0 ? "?" : $weight * 0.001
230} 279}
231 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
232sub update_widgets { 302sub update_widgets {
233 my ($self) = @_; 303 my ($self) = @_;
234 304
305 # necessary to avoid cyclic references
306 Scalar::Util::weaken $self;
307
235 my $button_cb = sub { 308 my $button_cb = sub {
236 my (undef, $ev, $x, $y) = @_; 309 my (undef, $ev, $x, $y) = @_;
237 310
311 my $targ = $::CONN->{player}{tag};
312
313 if ($self->{container} == $::CONN->{player}{tag}) {
314 $targ = $::CONN->{open_container};
315 }
316
238 if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) { 317 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"); 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})
246 } elsif ($ev->{button} == 1) { 324 } elsif ($ev->{button} == 1) {
247 $::CONN->send ("examine $self->{tag}"); 325 $::CONN->send ("examine $self->{tag}");
248 } elsif ($ev->{button} == 2) { 326 } elsif ($ev->{button} == 2) {
249 $::CONN->send ("apply $self->{tag}"); 327 $::CONN->send ("apply $self->{tag}");
250 } elsif ($ev->{button} == 3) { 328 } elsif ($ev->{button} == 3) {
… …
258 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }], 336 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
259 ) 337 )
260 : ( 338 : (
261 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }], 339 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
262 ["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 ]
263 ) 346 )
264 ), 347 ),
265 ); 348 );
266 349
267 CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev); 350 CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
… …
272 355
273 my $tooltip_std = "<small>" 356 my $tooltip_std = "<small>"
274 . "Left click - examine item\n" 357 . "Left click - examine item\n"
275 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n" 358 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
276 . "Middle click - apply\n" 359 . "Middle click - apply\n"
360 . "Shift-Middle click - lock/unlock\n"
277 . "Right click - further options" 361 . "Right click - further options"
278 . "</small>\n"; 362 . "</small>\n";
279 363
280 $self->{face_widget} ||= new CFClient::UI::Face 364 $self->{face_widget} ||= new CFClient::UI::Face
281 can_events => 1, 365 can_events => 1,
… …
320 . ($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. ")
321 . "\n\n$tooltip_std" 405 . "\n\n$tooltip_std"
322 ); 406 );
323} 407}
324 408
325package CFClient::Recorder; 409package CFClient::Binder;
326
327our $RECORD_WINDOW;
328
329my $CMDBOX;
330my $CURRENT_CMDS;
331my $REC_BTN;
332 410
333my @ALLOWED_MODIFIER_KEYS = ( 411my @ALLOWED_MODIFIER_KEYS = (
334 (CFClient::SDLK_LSHIFT) => "LSHIFT", 412 CFClient::SDLK_LSHIFT,
335 (CFClient::SDLK_LCTRL ) => "LCTRL", 413 CFClient::SDLK_LCTRL ,
336 (CFClient::SDLK_LALT ) => "LALT", 414 CFClient::SDLK_LALT ,
337 (CFClient::SDLK_LMETA ) => "LMETA", 415 CFClient::SDLK_LMETA ,
338 416
339 (CFClient::SDLK_RSHIFT) => "RSHIFT", 417 CFClient::SDLK_RSHIFT,
340 (CFClient::SDLK_RCTRL ) => "RCTRL", 418 CFClient::SDLK_RCTRL ,
341 (CFClient::SDLK_RALT ) => "RALT", 419 CFClient::SDLK_RALT ,
342 (CFClient::SDLK_RMETA ) => "RMETA", 420 CFClient::SDLK_RMETA ,
343); 421);
344 422
345my %ALLOWED_MODIFIERS = ( 423my %ALLOWED_MODIFIERS = (
346 (CFClient::KMOD_LSHIFT) => "LSHIFT", 424 CFClient::KMOD_LSHIFT => "LSHIFT",
347 (CFClient::KMOD_LCTRL ) => "LCTRL", 425 CFClient::KMOD_LCTRL => "LCTRL",
348 (CFClient::KMOD_LALT ) => "LALT", 426 CFClient::KMOD_LALT => "LALT",
349 (CFClient::KMOD_LMETA ) => "LMETA", 427 CFClient::KMOD_LMETA => "LMETA",
350 428
351 (CFClient::KMOD_RSHIFT) => "RSHIFT", 429 CFClient::KMOD_RSHIFT => "RSHIFT",
352 (CFClient::KMOD_RCTRL ) => "RCTRL", 430 CFClient::KMOD_RCTRL => "RCTRL",
353 (CFClient::KMOD_RALT ) => "RALT", 431 CFClient::KMOD_RALT => "RALT",
354 (CFClient::KMOD_RMETA ) => "RMETA", 432 CFClient::KMOD_RMETA => "RMETA",
355); 433);
356 434
357my %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/;
358my @DIRECT_BIND_KEYS = ( 436my @DIRECT_BIND_KEYS = (
359 CFClient::SDLK_F1, 437 CFClient::SDLK_F1,
… …
372 CFClient::SDLK_F14, 450 CFClient::SDLK_F14,
373 CFClient::SDLK_F15, 451 CFClient::SDLK_F15,
374); 452);
375 453
376# this binding dialog asks for a key-combo to be pressed 454# this binding dialog asks for a key-combo to be pressed
377# and if successful it binds the modifier+symbol to the 455# 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 { 456sub open_binding_dialog {
381 my ($cmd) = @_; 457 my ($cb) = @_;
382 458
383 my $w = new CFClient::UI::FancyFrame 459 my $w = new CFClient::UI::FancyFrame
384 title => "Bind Action"; 460 title => "Bind Action",
461 x => "center",
462 y => "center";
385 463
386 $w->add (my $vb = new CFClient::UI::VBox); 464 $w->add (my $vb = new CFClient::UI::VBox);
387 $vb->add (new CFClient::UI::Label 465 $vb->add (new CFClient::UI::Label
388 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."
389 ."You can only bind 0-9 and F1-F15 without modifiers." 467 ."You can only bind 0-9 and F1-F15 without modifiers."
… …
410 ." directly without modifier! It would damage the completer handling." 488 ." directly without modifier! It would damage the completer handling."
411 ); 489 );
412 return; 490 return;
413 } 491 }
414 492
415 $entry->focus_out; 493 $entry->grab_focus;
416 494
417 $::CFG->{bindings}->{$mod}->{$sym} = $cmd; 495 $cb->($mod, $sym);
418 $::STATUSBOX->add ("Bound actions to '".keycombo_to_name ($mod, $sym)."'. Don't forget Save Layout!");
419 496
420 $w->destroy 497 $w->destroy
421 }); 498 });
422 499
423 $entry->focus_in; 500 $entry->grab_focus;
424 $w->center;
425 $w->show; 501 $w->show;
426} 502}
427 503
428sub keycombo_to_name { 504sub keycombo_to_name {
429 my ($mod, $sym) = @_; 505 my ($mod, $sym) = @_;
430 506
431 my $mods = join '+', 507 my $mods = join '+',
432 map { $ALLOWED_MODIFIERS{$_} } 508 map { $ALLOWED_MODIFIERS{$_} }
433 grep { $_ & $mod } 509 grep { ($_ + 0) & ($mod + 0) }
434 keys %ALLOWED_MODIFIERS; 510 keys %ALLOWED_MODIFIERS;
435 $mods .= "+" if $mods ne ''; 511 $mods .= "+" if $mods ne '';
436 512
437 return $mods . CFClient::SDL_GetKeyName ($sym); 513 return $mods . CFClient::SDL_GetKeyName ($sym);
438} 514}
439 515
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 => "del",
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+INS Starts the recorder, INS 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; 5161;
537 517
538=back 518=back
539 519
540=head1 AUTHOR 520=head1 AUTHOR

Diff Legend

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