ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC.pm
Revision: 1.118
Committed: Tue Sep 12 20:48:17 2006 UTC (17 years, 8 months ago) by root
Branch: MAIN
CVS Tags: rel-0_5
Changes since 1.117: +1 -1 lines
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 root 1.1 =head1 NAME
2    
3 root 1.108 CFPlus - undocumented utility garbage for our crossfire client
4 root 1.1
5     =head1 SYNOPSIS
6    
7 root 1.108 use CFPlus;
8 root 1.1
9     =head1 DESCRIPTION
10    
11     =over 4
12    
13     =cut
14    
15 root 1.108 package CFPlus;
16 root 1.1
17     BEGIN {
18 root 1.118 $VERSION = '0.5';
19 root 1.1
20 root 1.2 use XSLoader;
21 root 1.108 XSLoader::load "CFPlus", $VERSION;
22 root 1.1 }
23    
24 root 1.62 use utf8;
25    
26 root 1.43 use Carp ();
27 root 1.52 use AnyEvent ();
28 root 1.34 use BerkeleyDB;
29 root 1.89 use Pod::POM ();
30 root 1.92 use Scalar::Util ();
31 root 1.89 use Storable (); # finally
32    
33 root 1.103 =item guard { BLOCK }
34    
35     Returns an object that executes the given block as soon as it is destroyed.
36    
37     =cut
38    
39     sub guard(&) {
40 root 1.108 bless \(my $cb = $_[0]), "CFPlus::Guard"
41 root 1.103 }
42    
43 root 1.108 sub CFPlus::Guard::DESTROY {
44 root 1.103 ${$_[0]}->()
45     }
46    
47 root 1.105 sub asxml($) {
48     local $_ = $_[0];
49 root 1.89
50 root 1.105 s/&/&/g;
51     s/>/>/g;
52     s/</&lt;/g;
53 root 1.89
54 root 1.105 $_
55 root 1.89 }
56    
57 root 1.108 package CFPlus::Database;
58 root 1.89
59     our @ISA = BerkeleyDB::Btree::;
60    
61     sub get($$) {
62     my $data;
63    
64     $_[0]->db_get ($_[1], $data) == 0
65     ? $data
66     : ()
67     }
68    
69     my %DB_SYNC;
70    
71     sub put($$$) {
72     my ($db, $key, $data) = @_;
73    
74 root 1.117 my $hkey = $db + 0;
75 root 1.116 Scalar::Util::weaken $db;
76 root 1.117 $DB_SYNC{$hkey} ||= AnyEvent->timer (after => 5, cb => sub {
77     delete $DB_SYNC{$hkey};
78 root 1.116 $db->db_sync if $db;
79     });
80 root 1.89
81     $db->db_put ($key => $data)
82     }
83    
84 root 1.108 package CFPlus;
85 root 1.52
86 root 1.5 sub find_rcfile($) {
87     my $path;
88    
89 root 1.46 for (grep !ref, @INC) {
90 root 1.108 $path = "$_/CFPlus/resources/$_[0]";
91 root 1.5 return $path if -r $path;
92     }
93    
94     die "FATAL: can't find required file $_[0]\n";
95     }
96    
97 root 1.110 BEGIN {
98     use Crossfire::Protocol::Base ();
99     *to_json = \&Crossfire::Protocol::Base::to_json;
100     *from_json = \&Crossfire::Protocol::Base::from_json;
101 root 1.107 }
102    
103 root 1.5 sub read_cfg {
104     my ($file) = @_;
105    
106 root 1.107 open my $fh, $file
107 root 1.5 or return;
108    
109     local $/;
110 root 1.107 my $CFG = <$fh>;
111 root 1.5
112 root 1.108 if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove
113     require YAML;
114     utf8::decode $CFG;
115     $::CFG = YAML::Load ($CFG);
116     } elsif ($CFG =~ /^\{/) {
117     $::CFG = from_json $CFG;
118 root 1.107 } else {
119 root 1.108 $::CFG = eval $CFG; ## todo comaptibility cruft
120 root 1.107 }
121 root 1.5 }
122    
123     sub write_cfg {
124     my ($file) = @_;
125    
126 root 1.107 $::CFG->{VERSION} = $::VERSION;
127    
128     open my $fh, ">:utf8", $file
129 root 1.5 or return;
130 root 1.108 print $fh to_json $::CFG;
131 root 1.5 }
132    
133 root 1.77 our $DB_ENV;
134    
135 root 1.76 {
136     use strict;
137    
138 root 1.87 mkdir "$Crossfire::VARDIR/cfplus", 0777;
139 root 1.77 my $recover = $BerkeleyDB::db_version >= 4.4
140     ? eval "DB_REGISTER | DB_RECOVER"
141     : 0;
142    
143     $DB_ENV = new BerkeleyDB::Env
144 root 1.76 -Home => "$Crossfire::VARDIR/cfplus",
145     -Cachesize => 1_000_000,
146     -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
147 root 1.39 # -ErrPrefix => "DATABASE",
148 root 1.76 -Verbose => 1,
149 root 1.77 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover,
150 root 1.78 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
151 root 1.76 or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
152     }
153 root 1.34
154     sub db_table($) {
155 root 1.38 my ($table) = @_;
156    
157     $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
158 root 1.76
159 root 1.108 new CFPlus::Database
160 root 1.34 -Env => $DB_ENV,
161 root 1.38 -Filename => $table,
162     # -Filename => "database",
163     # -Subname => $table,
164 root 1.51 -Property => DB_CHKSUM,
165 root 1.34 -Flags => DB_CREATE | DB_UPGRADE,
166 root 1.76 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
167 root 1.34 }
168    
169 root 1.108 package CFPlus::Layout;
170 root 1.97
171 root 1.108 $CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {
172 root 1.98 reset_glyph_cache;
173 root 1.97 };
174    
175 root 1.108 package CFPlus::Item;
176 root 1.62
177 root 1.71 use strict;
178     use Crossfire::Protocol::Constants;
179    
180 elmex 1.84 my $last_enter_count = 1;
181    
182 root 1.62 sub desc_string {
183     my ($self) = @_;
184    
185     my $desc =
186     $self->{nrof} < 2
187     ? $self->{name}
188     : "$self->{nrof} × $self->{name_pl}";
189    
190 root 1.71 $self->{flags} & F_OPEN
191 root 1.62 and $desc .= " (open)";
192 root 1.71 $self->{flags} & F_APPLIED
193 root 1.62 and $desc .= " (applied)";
194 root 1.71 $self->{flags} & F_UNPAID
195 root 1.62 and $desc .= " (unpaid)";
196 root 1.71 $self->{flags} & F_MAGIC
197 root 1.62 and $desc .= " (magic)";
198 root 1.71 $self->{flags} & F_CURSED
199 root 1.62 and $desc .= " (cursed)";
200 root 1.71 $self->{flags} & F_DAMNED
201 root 1.62 and $desc .= " (damned)";
202 root 1.71 $self->{flags} & F_LOCKED
203 root 1.62 and $desc .= " *";
204    
205     $desc
206     }
207    
208     sub weight_string {
209     my ($self) = @_;
210    
211     my $weight = ($self->{nrof} || 1) * $self->{weight};
212    
213     $weight < 0 ? "?" : $weight * 0.001
214     }
215    
216 elmex 1.84 sub do_n_dialog {
217     my ($cb) = @_;
218    
219 root 1.113 my $w = new CFPlus::UI::Toplevel
220 root 1.100 on_delete => sub { $_[0]->destroy; 1 },
221     has_close_button => 1,
222     ;
223    
224 root 1.108 $w->add (my $vb = new CFPlus::UI::VBox x => "center", y => "center");
225     $vb->add (new CFPlus::UI::Label text => "Enter item count:");
226     $vb->add (my $entry = new CFPlus::UI::Entry
227 elmex 1.84 text => $last_enter_count,
228     on_activate => sub {
229     my ($entry) = @_;
230     $last_enter_count = $entry->get_text;
231     $cb->($last_enter_count);
232     $w->hide;
233 root 1.100 $w->destroy;
234    
235     0
236     },
237     on_escape => sub { $w->destroy; 1 },
238 elmex 1.84 );
239 root 1.93 $entry->grab_focus;
240 elmex 1.84 $w->show;
241     }
242    
243 root 1.62 sub update_widgets {
244     my ($self) = @_;
245    
246 root 1.92 # necessary to avoid cyclic references
247     Scalar::Util::weaken $self;
248    
249 root 1.63 my $button_cb = sub {
250     my (undef, $ev, $x, $y) = @_;
251    
252 elmex 1.84 my $targ = $::CONN->{player}{tag};
253 root 1.63
254 elmex 1.84 if ($self->{container} == $::CONN->{player}{tag}) {
255     $targ = $::CONN->{open_container};
256     }
257 root 1.63
258 root 1.108 if (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 1) {
259 root 1.79 $::CONN->send ("move $targ $self->{tag} 0")
260     if $targ || !($self->{flags} & F_LOCKED);
261 root 1.108 } elsif (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 2) {
262 elmex 1.86 $self->{flags} & F_LOCKED
263     ? $::CONN->send ("lock " . pack "CN", 0, $self->{tag})
264     : $::CONN->send ("lock " . pack "CN", 1, $self->{tag})
265 root 1.63 } elsif ($ev->{button} == 1) {
266     $::CONN->send ("examine $self->{tag}");
267     } elsif ($ev->{button} == 2) {
268     $::CONN->send ("apply $self->{tag}");
269     } elsif ($ev->{button} == 3) {
270 elmex 1.101 my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
271     if ($self->{container} == $::CONN->{open_container}) {
272     $move_prefix = "take";
273     }
274    
275 root 1.63 my @menu_items = (
276     ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
277     ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
278 elmex 1.99 ["ignite/thaw", # first try of an easier use of flint&steel
279     sub {
280     $::CONN->send ("mark ". pack "N", $self->{tag});
281     $::CONN->send ("command apply flint and steel");
282     }
283     ],
284 elmex 1.109 ["inscribe", # first try of an easier use of flint&steel
285     sub {
286     &::open_string_query ("Text to inscribe", sub {
287     my ($entry, $txt) = @_;
288     $::CONN->send ("mark ". pack "N", $self->{tag});
289     $::CONN->send ("command use_skill inscription $txt");
290     });
291     }
292     ],
293 elmex 1.114 ["rename", # first try of an easier use of flint&steel
294     sub {
295     &::open_string_query ("Rename item to:", sub {
296     my ($entry, $txt) = @_;
297     $::CONN->send ("mark ". pack "N", $self->{tag});
298     $::CONN->send ("command rename to <$txt>");
299 elmex 1.115 }, $self->{name},
300     "If you input no name or erase the current custom name, the custom name will be unset");
301 elmex 1.114 }
302     ],
303 root 1.63 ["apply", sub { $::CONN->send ("apply $self->{tag}") }],
304     (
305 root 1.71 $self->{flags} & F_LOCKED
306 root 1.63 ? (
307     ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
308     )
309     : (
310     ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
311 elmex 1.101 ["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }],
312 root 1.104 ["$move_prefix &lt;n&gt;",
313 elmex 1.84 sub {
314     do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
315     }
316     ]
317 root 1.63 )
318     ),
319     );
320    
321 root 1.108 CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
322 root 1.63 }
323    
324     1
325     };
326    
327 root 1.62 my $tooltip_std = "<small>"
328     . "Left click - examine item\n"
329     . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
330     . "Middle click - apply\n"
331 elmex 1.86 . "Shift-Middle click - lock/unlock\n"
332 root 1.62 . "Right click - further options"
333     . "</small>\n";
334    
335 root 1.106 my $bg = $self->{flags} & F_CURSED ? [1 , 0 , 0, 0.5]
336     : $self->{flags} & F_MAGIC ? [0.2, 0.2, 1, 0.5]
337     : undef;
338    
339 root 1.108 $self->{face_widget} ||= new CFPlus::UI::Face
340 root 1.63 can_events => 1,
341     can_hover => 1,
342 root 1.67 anim => $self->{anim},
343 root 1.66 animspeed => $self->{animspeed}, # TODO# must be set at creation time
344 root 1.72 on_button_down => $button_cb,
345 root 1.63 ;
346 root 1.106 $self->{face_widget}{bg} = $bg;
347 root 1.62 $self->{face_widget}{face} = $self->{face};
348     $self->{face_widget}{anim} = $self->{anim};
349 root 1.65 $self->{face_widget}{animspeed} = $self->{animspeed};
350 root 1.62 $self->{face_widget}->set_tooltip (
351     "<b>Face/Animation.</b>\n"
352     . "Item uses face #$self->{face}. "
353     . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
354     . "\n\n$tooltip_std"
355     );
356    
357 root 1.108 $self->{desc_widget} ||= new CFPlus::UI::Label
358 root 1.63 can_events => 1,
359     can_hover => 1,
360     ellipsise => 2,
361 root 1.68 align => -1,
362 root 1.72 on_button_down => $button_cb,
363 root 1.63 ;
364 root 1.108 my $desc = CFPlus::Item::desc_string $self;
365 root 1.106 $self->{desc_widget}{bg} = $bg;
366 root 1.63 $self->{desc_widget}->set_text ($desc);
367     $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
368    
369 root 1.108 $self->{weight_widget} ||= new CFPlus::UI::Label
370 root 1.63 can_events => 1,
371     can_hover => 1,
372     ellipsise => 0,
373 root 1.68 align => 0,
374 root 1.72 on_button_down => $button_cb,
375 root 1.63 ;
376 root 1.106 $self->{weight_widget}{bg} = $bg;
377 root 1.108 $self->{weight_widget}->set_text (CFPlus::Item::weight_string $self);
378 root 1.62 $self->{weight_widget}->set_tooltip (
379     "<b>Weight</b>.\n"
380     . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
381     . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
382     . "\n\n$tooltip_std"
383     );
384     }
385    
386 root 1.1 1;
387    
388     =back
389    
390     =head1 AUTHOR
391    
392     Marc Lehmann <schmorp@schmorp.de>
393     http://home.schmorp.de/
394    
395     =cut
396