ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC.pm
Revision: 1.115
Committed: Tue Aug 15 06:30:05 2006 UTC (17 years, 8 months ago) by elmex
Branch: MAIN
Changes since 1.114: +2 -1 lines
Log Message:
improved rename a little bit.

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