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.70 by root, Fri May 26 18:28:23 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;
241
242use strict;
243use Crossfire::Protocol::Constants;
244
245my $last_enter_count = 1;
194 246
195sub desc_string { 247sub desc_string {
196 my ($self) = @_; 248 my ($self) = @_;
197 249
198 my $desc = 250 my $desc =
199 $self->{nrof} < 2 251 $self->{nrof} < 2
200 ? $self->{name} 252 ? $self->{name}
201 : "$self->{nrof} × $self->{name_pl}"; 253 : "$self->{nrof} × $self->{name_pl}";
202 254
203 $self->{flags} & Crossfire::Protocol::F_OPEN 255 $self->{flags} & F_OPEN
204 and $desc .= " (open)"; 256 and $desc .= " (open)";
205 $self->{flags} & Crossfire::Protocol::F_APPLIED 257 $self->{flags} & F_APPLIED
206 and $desc .= " (applied)"; 258 and $desc .= " (applied)";
207 $self->{flags} & Crossfire::Protocol::F_UNPAID 259 $self->{flags} & F_UNPAID
208 and $desc .= " (unpaid)"; 260 and $desc .= " (unpaid)";
209 $self->{flags} & Crossfire::Protocol::F_MAGIC 261 $self->{flags} & F_MAGIC
210 and $desc .= " (magic)"; 262 and $desc .= " (magic)";
211 $self->{flags} & Crossfire::Protocol::F_CURSED 263 $self->{flags} & F_CURSED
212 and $desc .= " (cursed)"; 264 and $desc .= " (cursed)";
213 $self->{flags} & Crossfire::Protocol::F_DAMNED 265 $self->{flags} & F_DAMNED
214 and $desc .= " (damned)"; 266 and $desc .= " (damned)";
215 $self->{flags} & Crossfire::Protocol::F_LOCKED 267 $self->{flags} & F_LOCKED
216 and $desc .= " *"; 268 and $desc .= " *";
217 269
218 $desc 270 $desc
219} 271}
220 272
224 my $weight = ($self->{nrof} || 1) * $self->{weight}; 276 my $weight = ($self->{nrof} || 1) * $self->{weight};
225 277
226 $weight < 0 ? "?" : $weight * 0.001 278 $weight < 0 ? "?" : $weight * 0.001
227} 279}
228 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
229sub update_widgets { 302sub update_widgets {
230 my ($self) = @_; 303 my ($self) = @_;
231 304
305 # necessary to avoid cyclic references
306 Scalar::Util::weaken $self;
307
232 my $button_cb = sub { 308 my $button_cb = sub {
233 my (undef, $ev, $x, $y) = @_; 309 my (undef, $ev, $x, $y) = @_;
234 310
311 my $targ = $::CONN->{player}{tag};
312
313 if ($self->{container} == $::CONN->{player}{tag}) {
314 $targ = $::CONN->{open_container};
315 }
316
235 if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) { 317 if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
236 my $targ = $::CONN->{player}{tag};
237
238 if ($self->{container} == $::CONN->{player}{tag}) {
239 $targ = $::CONN->{open_container};
240 }
241
242 $::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})
243 } elsif ($ev->{button} == 1) { 324 } elsif ($ev->{button} == 1) {
244 $::CONN->send ("examine $self->{tag}"); 325 $::CONN->send ("examine $self->{tag}");
245 } elsif ($ev->{button} == 2) { 326 } elsif ($ev->{button} == 2) {
246 $::CONN->send ("apply $self->{tag}"); 327 $::CONN->send ("apply $self->{tag}");
247 } elsif ($ev->{button} == 3) { 328 } elsif ($ev->{button} == 3) {
248 my @menu_items = ( 329 my @menu_items = (
249 ["examine", sub { $::CONN->send ("examine $self->{tag}") }], 330 ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
250 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }], 331 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
251 ["apply", sub { $::CONN->send ("apply $self->{tag}") }], 332 ["apply", sub { $::CONN->send ("apply $self->{tag}") }],
252 ( 333 (
253 $self->{flags} & Crossfire::Protocol::F_LOCKED 334 $self->{flags} & F_LOCKED
254 ? ( 335 ? (
255 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }], 336 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
256 ) 337 )
257 : ( 338 : (
258 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }], 339 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
259 ["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 ]
260 ) 346 )
261 ), 347 ),
262 ); 348 );
263 349
264 CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev); 350 CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
269 355
270 my $tooltip_std = "<small>" 356 my $tooltip_std = "<small>"
271 . "Left click - examine item\n" 357 . "Left click - examine item\n"
272 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n" 358 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
273 . "Middle click - apply\n" 359 . "Middle click - apply\n"
360 . "Shift-Middle click - lock/unlock\n"
274 . "Right click - further options" 361 . "Right click - further options"
275 . "</small>\n"; 362 . "</small>\n";
276 363
277 $self->{face_widget} ||= new CFClient::UI::Face 364 $self->{face_widget} ||= new CFClient::UI::Face
278 can_events => 1, 365 can_events => 1,
279 can_hover => 1, 366 can_hover => 1,
280 anim => $self->{anim}, 367 anim => $self->{anim},
281 animspeed => $self->{animspeed}, # TODO# must be set at creation time 368 animspeed => $self->{animspeed}, # TODO# must be set at creation time
282 connect_button_down => $button_cb, 369 on_button_down => $button_cb,
283 ; 370 ;
284 $self->{face_widget}{face} = $self->{face}; 371 $self->{face_widget}{face} = $self->{face};
285 $self->{face_widget}{anim} = $self->{anim}; 372 $self->{face_widget}{anim} = $self->{anim};
286 $self->{face_widget}{animspeed} = $self->{animspeed}; 373 $self->{face_widget}{animspeed} = $self->{animspeed};
287 $self->{face_widget}->set_tooltip ( 374 $self->{face_widget}->set_tooltip (
294 $self->{desc_widget} ||= new CFClient::UI::Label 381 $self->{desc_widget} ||= new CFClient::UI::Label
295 can_events => 1, 382 can_events => 1,
296 can_hover => 1, 383 can_hover => 1,
297 ellipsise => 2, 384 ellipsise => 2,
298 align => -1, 385 align => -1,
299 connect_button_down => $button_cb, 386 on_button_down => $button_cb,
300 ; 387 ;
301 my $desc = CFClient::Item::desc_string $self; 388 my $desc = CFClient::Item::desc_string $self;
302 $self->{desc_widget}->set_text ($desc); 389 $self->{desc_widget}->set_text ($desc);
303 $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std"); 390 $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
304 391
305 $self->{weight_widget} ||= new CFClient::UI::Label 392 $self->{weight_widget} ||= new CFClient::UI::Label
306 can_events => 1, 393 can_events => 1,
307 can_hover => 1, 394 can_hover => 1,
308 ellipsise => 0, 395 ellipsise => 0,
309 align => 0, 396 align => 0,
310 connect_button_down => $button_cb, 397 on_button_down => $button_cb,
311 ; 398 ;
312 $self->{weight_widget}->set_text (CFClient::Item::weight_string $self); 399 $self->{weight_widget}->set_text (CFClient::Item::weight_string $self);
313 400
314 $self->{weight_widget}->set_tooltip ( 401 $self->{weight_widget}->set_tooltip (
315 "<b>Weight</b>.\n" 402 "<b>Weight</b>.\n"
317 . ($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. ")
318 . "\n\n$tooltip_std" 405 . "\n\n$tooltip_std"
319 ); 406 );
320} 407}
321 408
409package CFClient::Binder;
410
411my @ALLOWED_MODIFIER_KEYS = (
412 CFClient::SDLK_LSHIFT,
413 CFClient::SDLK_LCTRL ,
414 CFClient::SDLK_LALT ,
415 CFClient::SDLK_LMETA ,
416
417 CFClient::SDLK_RSHIFT,
418 CFClient::SDLK_RCTRL ,
419 CFClient::SDLK_RALT ,
420 CFClient::SDLK_RMETA ,
421);
422
423my %ALLOWED_MODIFIERS = (
424 CFClient::KMOD_LSHIFT => "LSHIFT",
425 CFClient::KMOD_LCTRL => "LCTRL",
426 CFClient::KMOD_LALT => "LALT",
427 CFClient::KMOD_LMETA => "LMETA",
428
429 CFClient::KMOD_RSHIFT => "RSHIFT",
430 CFClient::KMOD_RCTRL => "RCTRL",
431 CFClient::KMOD_RALT => "RALT",
432 CFClient::KMOD_RMETA => "RMETA",
433);
434
435my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/;
436my @DIRECT_BIND_KEYS = (
437 CFClient::SDLK_F1,
438 CFClient::SDLK_F2,
439 CFClient::SDLK_F3,
440 CFClient::SDLK_F4,
441 CFClient::SDLK_F5,
442 CFClient::SDLK_F6,
443 CFClient::SDLK_F7,
444 CFClient::SDLK_F8,
445 CFClient::SDLK_F9,
446 CFClient::SDLK_F10,
447 CFClient::SDLK_F11,
448 CFClient::SDLK_F12,
449 CFClient::SDLK_F13,
450 CFClient::SDLK_F14,
451 CFClient::SDLK_F15,
452);
453
454# this binding dialog asks for a key-combo to be pressed
455# and if successful it calls the $cb with $mod and $sym as args.
456sub open_binding_dialog {
457 my ($cb) = @_;
458
459 my $w = new CFClient::UI::FancyFrame
460 title => "Bind Action",
461 x => "center",
462 y => "center";
463
464 $w->add (my $vb = new CFClient::UI::VBox);
465 $vb->add (new CFClient::UI::Label
466 text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
467 ."You can only bind 0-9 and F1-F15 without modifiers."
468 );
469 $vb->add (my $entry = new CFClient::UI::Entry
470 text => "",
471 on_key_down => sub {
472 my ($entry, $ev) = @_;
473
474 my $mod = $ev->{mod};
475 my $sym = $ev->{sym};
476
477 # XXX: This seems a little bit hackisch to me, but i have to ignore them
478 if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) {
479 return;
480 }
481
482 if ($mod == CFClient::KMOD_NONE
483 and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})}
484 and not grep { $sym == $_ } @DIRECT_BIND_KEYS)
485 {
486 $::STATUSBOX->add (
487 "Can't bind key ".CFClient::SDL_GetKeyName ($sym)
488 ." directly without modifier! It would damage the completer handling."
489 );
490 return;
491 }
492
493 $entry->grab_focus;
494
495 $cb->($mod, $sym);
496
497 $w->destroy
498 });
499
500 $entry->grab_focus;
501 $w->show;
502}
503
504sub keycombo_to_name {
505 my ($mod, $sym) = @_;
506
507 my $mods = join '+',
508 map { $ALLOWED_MODIFIERS{$_} }
509 grep { ($_ + 0) & ($mod + 0) }
510 keys %ALLOWED_MODIFIERS;
511 $mods .= "+" if $mods ne '';
512
513 return $mods . CFClient::SDL_GetKeyName ($sym);
514}
515
3221; 5161;
323 517
324=back 518=back
325 519
326=head1 AUTHOR 520=head1 AUTHOR

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines