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.88 by root, Mon Jun 5 05:31:13 2006 UTC vs.
Revision 1.103 by root, Sun Jul 23 08:58:43 2006 UTC

… …
24use utf8; 24use utf8;
25 25
26use Carp (); 26use Carp ();
27use AnyEvent (); 27use AnyEvent ();
28use BerkeleyDB; 28use BerkeleyDB;
29use Pod::POM; 29use Pod::POM ();
30use Scalar::Util ();
31use Storable (); # finally
32
33our %STAT_TOOLTIP = (
34 Str => "<b>Physical Strength</b>, determines damage dealt with weapons, how much you can carry, and how often you can attack",
35 Dex => "<b>Dexterity</b>, your physical agility. Determines chance of being hit and affects armor class and speed",
36 Con => "<b>Constitution</b>, physical health and toughness. Determines how many healthpoints you can have",
37 Int => "<b>Intelligence</b>, your ability to learn and use skills and incantations (both prayers and magic) and determines how much spell points you can have",
38 Wis => "<b>Wisdom</b>, the ability to learn and use divine magic (prayers). Determines how many grace points you can have",
39 Pow => "<b>Power</b>, your magical potential. Influences the strength of spell effects, and also how much your spell and grace points increase when leveling up",
40 Cha => "<b>Charisma</b>, how well you are received by NPCs. Affects buying and selling prices in shops.",
41
42 Wc => "<b>Weapon Class</b>, effectiveness of melee/missile attacks. Lower is more potent. Current weapon, level and Str are some things which effect the value of Wc. The value of Wc may range between 25 and -72.",
43 Ac => "<b>Armour Class</b>, how protected you are from being hit by any attack. Lower values are better. Ac is based on your race and is modified by the Dex and current armour worn. For characters that cannot wear armour, Ac improves as their level increases.",
44 Dam => "<b>Damage</b>, how much damage your melee/missile attack inflicts. Higher values indicate a greater amount of damage will be inflicted with each attack.",
45 Arm => "<b>Armour</b>, how much damage (from physical attacks) will be subtracted from successful hits made upon you. This value ranges between 0 to 99%. Current armour worn primarily determines Arm value. This is the same as the physical resistance.",
46 Spd => "<b>Speed</b>, how fast you can move. The value of speed may range between nearly 0 (\"very slow\") to higher than 5 (\"lightning fast\"). Base speed is determined from the Dex and modified downward proportionally by the amount of weight carried which exceeds the Max Carry limit. The armour worn also sets the upper limit on speed.",
47 WSp => "<b>Weapon Speed</b>, how many attacks you may make per unit of time (0.120s). Higher values indicate faster attack speed. Current weapon and Dex effect the value of weapon speed.",
48);
49
50=item guard { BLOCK }
51
52Returns an object that executes the given block as soon as it is destroyed.
53
54=cut
55
56sub guard(&) {
57 bless \(my $cb = $_[0]), "CFClient::Guard"
58}
59
60sub CFClient::Guard::DESTROY {
61 ${$_[0]}->()
62}
63
64package CFClient::PodToPango;
65
66use base Pod::POM::View::Text;
67
68our $VERSION = 1; # bump if resultant formatting changes
69
70our $indent = 0;
71
72*view_seq_code =
73*view_seq_bold = sub { "<b>$_[1]</b>" };
74*view_seq_italic = sub { "<i>$_[1]</i>" };
75*view_seq_space =
76*view_seq_link =
77*view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
78
79sub view_seq_text {
80 my $text = $_[1];
81 $text =~ s/\s+/ /g;
82 CFClient::UI::Label::escape ($text)
83}
84
85sub view_item {
86 ("\t" x ($indent / 4))
87 . $_[1]->title->present ($_[0])
88 . "\n\n"
89 . $_[1]->content->present ($_[0])
90}
91
92sub view_verbatim {
93 (join "",
94 map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
95 split /\n/, CFClient::UI::Label::escape ($_[1]))
96 . "\n"
97}
98
99sub view_textblock {
100 ("\t" x ($indent / 2)) . "$_[1]\n\n"
101}
102
103sub view_head1 {
104 "\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
105 . $_[1]->content->present ($_[0])
106};
107
108sub view_head2 {
109 "\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
110 . $_[1]->content->present ($_[0])
111};
112
113sub view_head3 {
114 "\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
115 . $_[1]->content->present ($_[0])
116};
117
118sub view_over {
119 local $indent = $indent + $_[1]->indent;
120 $_[1]->content->present ($_[0])
121}
122
123package CFClient::Database;
124
125our @ISA = BerkeleyDB::Btree::;
126
127sub get($$) {
128 my $data;
129
130 $_[0]->db_get ($_[1], $data) == 0
131 ? $data
132 : ()
133}
134
135my %DB_SYNC;
136
137sub put($$$) {
138 my ($db, $key, $data) = @_;
139
140 $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
141
142 $db->db_put ($key => $data)
143}
144
145package CFClient;
30 146
31sub find_rcfile($) { 147sub find_rcfile($) {
32 my $path; 148 my $path;
33 149
34 for (grep !ref, @INC) { 150 for (grep !ref, @INC) {
… …
67 $::CFG->{VERSION} = $::VERSION; 183 $::CFG->{VERSION} = $::VERSION;
68 print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]); 184 print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]);
69 } 185 }
70 186
71 close CFG; 187 close CFG;
72}
73
74my %POD_CACHE;
75
76sub load_pod($) {
77 $POD_CACHE{$_[0]} ||= do {
78 my $pod = do {
79 local $/;
80 open my $pod, "<:utf8", $_[0]
81 or die "$_[0]: $!";
82 <$pod>
83 };
84
85 Pod::POM->new->parse_text ($pod)
86 }
87} 188}
88 189
89our $DB_ENV; 190our $DB_ENV;
90 191
91{ 192{
… …
120 -Property => DB_CHKSUM, 221 -Property => DB_CHKSUM,
121 -Flags => DB_CREATE | DB_UPGRADE, 222 -Flags => DB_CREATE | DB_UPGRADE,
122 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error" 223 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
123} 224}
124 225
226my $pod_cache = db_table "pod_cache";
227
228sub load_pod($$$$) {
229 my ($path, $filtertype, $filterversion, $filtercb) = @_;
230
231 stat $path
232 or die "$path: $!";
233
234 my $phash = join ",", $filterversion, $CFClient::PodToPango::VERSION, (stat _)[7,9];
235
236 my ($chash, $pom) = eval { @{ Storable::thaw $pod_cache->get ("$path/$filtertype") } };
237
238 return $pom if $chash eq $phash;
239
240 my $pod = do {
241 local $/;
242 open my $pod, "<:utf8", $_[0]
243 or die "$_[0]: $!";
244 <$pod>
245 };
246
247 #utf8::downgrade $pod;
248
249 $pom = $filtercb-> (Pod::POM->new->parse_text ($pod));
250
251 $pod_cache->put ("$path/$filtertype" => Storable::nfreeze [$phash, $pom]);
252
253 $pom
254}
255
125sub pod_to_pango($) { 256sub pod_to_pango($) {
126 my ($pom) = @_; 257 my ($pom) = @_;
127 258
128 $pom->present ("CFClient::PodToPango") 259 $pom->present ("CFClient::PodToPango")
129} 260}
… …
135 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "], 266 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "],
136 split /\n/, $pom->present ("CFClient::PodToPango") 267 split /\n/, $pom->present ("CFClient::PodToPango")
137 ] 268 ]
138} 269}
139 270
140package CFClient::PodToPango; 271package CFClient::Layout;
141 272
142use base Pod::POM::View::Text; 273$CFClient::OpenGL::SHUTDOWN_HOOK{"CFClient::Layout"} = sub {
143 274 reset_glyph_cache;
144our $indent = 0;
145
146*view_seq_code =
147*view_seq_bold = sub { "<b>$_[1]</b>" };
148*view_seq_italic = sub { "<i>$_[1]</i>" };
149*view_seq_space =
150*view_seq_link =
151*view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
152
153sub view_seq_text {
154 my $text = $_[1];
155 $text =~ s/\s+/ /g;
156 CFClient::UI::Label::escape ($text)
157}
158
159sub view_item {
160 ("\t" x ($indent / 4))
161 . $_[1]->title->present ($_[0])
162 . "\n"
163 . $_[1]->content->present ($_[0])
164}
165
166sub view_verbatim {
167 (join "",
168 map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
169 split /\n/, CFClient::UI::Label::escape ($_[1]))
170 . "\n"
171}
172
173sub view_textblock {
174 ("\t" x ($indent / 2)) . "$_[1]\n\n"
175}
176
177sub view_head1 {
178 "\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
179 . $_[1]->content->present ($_[0])
180}; 275};
181
182sub view_head2 {
183 "\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
184 . $_[1]->content->present ($_[0])
185};
186
187sub view_head3 {
188 "\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
189 . $_[1]->content->present ($_[0])
190};
191
192sub view_over {
193 local $indent = $indent + $_[1]->indent;
194 $_[1]->content->present ($_[0])
195}
196
197package CFClient::Database;
198
199our @ISA = BerkeleyDB::Btree::;
200
201sub get($$) {
202 my $data;
203
204 $_[0]->db_get ($_[1], $data) == 0
205 ? $data
206 : ()
207}
208
209my %DB_SYNC;
210
211sub put($$$) {
212 my ($db, $key, $data) = @_;
213
214 $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
215
216 $db->db_put ($key => $data)
217}
218 276
219package CFClient::Item; 277package CFClient::Item;
220 278
221use strict; 279use strict;
222use Crossfire::Protocol::Constants; 280use Crossfire::Protocol::Constants;
… …
258} 316}
259 317
260sub do_n_dialog { 318sub do_n_dialog {
261 my ($cb) = @_; 319 my ($cb) = @_;
262 320
263 my $w = new CFClient::UI::FancyFrame; 321 my $w = new CFClient::UI::FancyFrame
322 on_delete => sub { $_[0]->destroy; 1 },
323 has_close_button => 1,
324 ;
325
264 $w->add (my $vb = new CFClient::UI::VBox x => "center", y => "center"); 326 $w->add (my $vb = new CFClient::UI::VBox x => "center", y => "center");
265 $vb->add (new CFClient::UI::Label text => "Enter item count:"); 327 $vb->add (new CFClient::UI::Label text => "Enter item count:");
266 $vb->add (my $entry = new CFClient::UI::Entry 328 $vb->add (my $entry = new CFClient::UI::Entry
267 text => $last_enter_count, 329 text => $last_enter_count,
268 on_activate => sub { 330 on_activate => sub {
269 my ($entry) = @_; 331 my ($entry) = @_;
270 $last_enter_count = $entry->get_text; 332 $last_enter_count = $entry->get_text;
271 $cb->($last_enter_count); 333 $cb->($last_enter_count);
272 $w->hide; 334 $w->hide;
273 $w = undef; 335 $w->destroy;
336
337 0
274 } 338 },
339 on_escape => sub { $w->destroy; 1 },
275 ); 340 );
276 $entry->focus_in; 341 $entry->grab_focus;
277 $w->show; 342 $w->show;
278
279} 343}
280 344
281sub update_widgets { 345sub update_widgets {
282 my ($self) = @_; 346 my ($self) = @_;
347
348 # necessary to avoid cyclic references
349 Scalar::Util::weaken $self;
283 350
284 my $button_cb = sub { 351 my $button_cb = sub {
285 my (undef, $ev, $x, $y) = @_; 352 my (undef, $ev, $x, $y) = @_;
286 353
287 my $targ = $::CONN->{player}{tag}; 354 my $targ = $::CONN->{player}{tag};
… …
300 } elsif ($ev->{button} == 1) { 367 } elsif ($ev->{button} == 1) {
301 $::CONN->send ("examine $self->{tag}"); 368 $::CONN->send ("examine $self->{tag}");
302 } elsif ($ev->{button} == 2) { 369 } elsif ($ev->{button} == 2) {
303 $::CONN->send ("apply $self->{tag}"); 370 $::CONN->send ("apply $self->{tag}");
304 } elsif ($ev->{button} == 3) { 371 } elsif ($ev->{button} == 3) {
372 my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
373 if ($self->{container} == $::CONN->{open_container}) {
374 $move_prefix = "take";
375 }
376
305 my @menu_items = ( 377 my @menu_items = (
306 ["examine", sub { $::CONN->send ("examine $self->{tag}") }], 378 ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
307 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }], 379 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
380 ["ignite/thaw", # first try of an easier use of flint&steel
381 sub {
382 $::CONN->send ("mark ". pack "N", $self->{tag});
383 $::CONN->send ("command apply flint and steel");
384 }
385 ],
308 ["apply", sub { $::CONN->send ("apply $self->{tag}") }], 386 ["apply", sub { $::CONN->send ("apply $self->{tag}") }],
309 ( 387 (
310 $self->{flags} & F_LOCKED 388 $self->{flags} & F_LOCKED
311 ? ( 389 ? (
312 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }], 390 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
313 ) 391 )
314 : ( 392 : (
315 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }], 393 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
316 ["drop", sub { $::CONN->send ("move $::CONN->{open_container} $self->{tag} 0") }], 394 ["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }],
317 ["move n", 395 ["$move_prefix <n>",
318 sub { 396 sub {
319 do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") }) 397 do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
320 } 398 }
321 ] 399 ]
322 ) 400 )
… …
380 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ") 458 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
381 . "\n\n$tooltip_std" 459 . "\n\n$tooltip_std"
382 ); 460 );
383} 461}
384 462
385package CFClient::Binder;
386
387my @ALLOWED_MODIFIER_KEYS = (
388 CFClient::SDLK_LSHIFT,
389 CFClient::SDLK_LCTRL ,
390 CFClient::SDLK_LALT ,
391 CFClient::SDLK_LMETA ,
392
393 CFClient::SDLK_RSHIFT,
394 CFClient::SDLK_RCTRL ,
395 CFClient::SDLK_RALT ,
396 CFClient::SDLK_RMETA ,
397);
398
399my %ALLOWED_MODIFIERS = (
400 CFClient::KMOD_LSHIFT => "LSHIFT",
401 CFClient::KMOD_LCTRL => "LCTRL",
402 CFClient::KMOD_LALT => "LALT",
403 CFClient::KMOD_LMETA => "LMETA",
404
405 CFClient::KMOD_RSHIFT => "RSHIFT",
406 CFClient::KMOD_RCTRL => "RCTRL",
407 CFClient::KMOD_RALT => "RALT",
408 CFClient::KMOD_RMETA => "RMETA",
409);
410
411my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/;
412my @DIRECT_BIND_KEYS = (
413 CFClient::SDLK_F1,
414 CFClient::SDLK_F2,
415 CFClient::SDLK_F3,
416 CFClient::SDLK_F4,
417 CFClient::SDLK_F5,
418 CFClient::SDLK_F6,
419 CFClient::SDLK_F7,
420 CFClient::SDLK_F8,
421 CFClient::SDLK_F9,
422 CFClient::SDLK_F10,
423 CFClient::SDLK_F11,
424 CFClient::SDLK_F12,
425 CFClient::SDLK_F13,
426 CFClient::SDLK_F14,
427 CFClient::SDLK_F15,
428);
429
430# this binding dialog asks for a key-combo to be pressed
431# and if successful it calls the $cb with $mod and $sym as args.
432sub open_binding_dialog {
433 my ($cb) = @_;
434
435 my $w = new CFClient::UI::FancyFrame
436 title => "Bind Action",
437 x => "center",
438 y => "center";
439
440 $w->add (my $vb = new CFClient::UI::VBox);
441 $vb->add (new CFClient::UI::Label
442 text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
443 ."You can only bind 0-9 and F1-F15 without modifiers."
444 );
445 $vb->add (my $entry = new CFClient::UI::Entry
446 text => "",
447 on_key_down => sub {
448 my ($entry, $ev) = @_;
449
450 my $mod = $ev->{mod};
451 my $sym = $ev->{sym};
452
453 # XXX: This seems a little bit hackisch to me, but i have to ignore them
454 if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) {
455 return;
456 }
457
458 if ($mod == CFClient::KMOD_NONE
459 and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})}
460 and not grep { $sym == $_ } @DIRECT_BIND_KEYS)
461 {
462 $::STATUSBOX->add (
463 "Can't bind key ".CFClient::SDL_GetKeyName ($sym)
464 ." directly without modifier! It would damage the completer handling."
465 );
466 return;
467 }
468
469 $entry->focus_out;
470
471 $cb->($mod, $sym);
472
473 $w->destroy
474 });
475
476 $entry->focus_in;
477 $w->show;
478}
479
480sub keycombo_to_name {
481 my ($mod, $sym) = @_;
482
483 my $mods = join '+',
484 map { $ALLOWED_MODIFIERS{$_} }
485 grep { ($_ + 0) & ($mod + 0) }
486 keys %ALLOWED_MODIFIERS;
487 $mods .= "+" if $mods ne '';
488
489 return $mods . CFClient::SDL_GetKeyName ($sym);
490}
491
492package CFClient::Pickup;
493# some pickup constants
494sub PU_NOTHING { 0x00000000 }
495
496sub PU_DEBUG { 0x10000000 }
497sub PU_INHIBIT { 0x20000000 }
498sub PU_STOP { 0x40000000 }
499sub PU_NEWMODE { 0x80000000 }
500
501sub PU_RATIO { 0x0000000F }
502
503sub PU_FOOD { 0x00000010 }
504sub PU_DRINK { 0x00000020 }
505sub PU_VALUABLES { 0x00000040 }
506sub PU_BOW { 0x00000080 }
507
508sub PU_ARROW { 0x00000100 }
509sub PU_HELMET { 0x00000200 }
510sub PU_SHIELD { 0x00000400 }
511sub PU_ARMOUR { 0x00000800 }
512
513sub PU_BOOTS { 0x00001000 }
514sub PU_GLOVES { 0x00002000 }
515sub PU_CLOAK { 0x00004000 }
516sub PU_KEY { 0x00008000 }
517
518sub PU_MISSILEWEAPON { 0x00010000 }
519sub PU_ALLWEAPON { 0x00020000 }
520sub PU_MAGICAL { 0x00040000 }
521sub PU_POTION { 0x00080000 }
522
523sub PU_SPELLBOOK { 0x00100000 }
524sub PU_SKILLSCROLL { 0x00200000 }
525sub PU_READABLES { 0x00400000 }
526sub PU_MAGIC_DEVICE { 0x00800000 }
527
528sub PU_NOT_CURSED { 0x01000000 }
529
530sub PU_JEWELS { 0x02000000 }
531
532
5331; 4631;
534 464
535=back 465=back
536 466
537=head1 AUTHOR 467=head1 AUTHOR

Diff Legend

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