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.122 by root, Sun Oct 1 14:48:50 2006 UTC vs.
Revision 1.163 by root, Tue Dec 25 09:38:33 2007 UTC

15package CFPlus; 15package CFPlus;
16 16
17use Carp (); 17use Carp ();
18 18
19BEGIN { 19BEGIN {
20 $VERSION = '0.52'; 20 $VERSION = '0.9960';
21 21
22 use XSLoader; 22 use XSLoader;
23 XSLoader::load "CFPlus", $VERSION; 23 XSLoader::load "CFPlus", $VERSION;
24} 24}
25 25
26BEGIN {
27 $SIG{__DIE__} = sub {
28 return if CFPlus::in_destruct;
29 #CFPlus::fatal $_[0];#d#
30 CFPlus::error Carp::longmess $_[0];#d#
31 die;#d#
32 };
33}
34
35use utf8; 26use utf8;
36 27
37use AnyEvent (); 28use AnyEvent ();
38use BerkeleyDB;
39use Pod::POM (); 29use Pod::POM ();
40use Scalar::Util (); 30use File::Path ();
41use Storable (); # finally 31use Storable (); # finally
32use Fcntl ();
33use JSON::XS qw(encode_json decode_json);
42 34
43=item guard { BLOCK } 35=item guard { BLOCK }
44 36
45Returns an object that executes the given block as soon as it is destroyed. 37Returns an object that executes the given block as soon as it is destroyed.
46 38
50 bless \(my $cb = $_[0]), "CFPlus::Guard" 42 bless \(my $cb = $_[0]), "CFPlus::Guard"
51} 43}
52 44
53sub CFPlus::Guard::DESTROY { 45sub CFPlus::Guard::DESTROY {
54 ${$_[0]}->() 46 ${$_[0]}->()
47}
48
49=item shorten $string[, $maxlength]
50
51=cut
52
53sub shorten($;$) {
54 my ($str, $len) = @_;
55 substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
56 $str
55} 57}
56 58
57sub asxml($) { 59sub asxml($) {
58 local $_ = $_[0]; 60 local $_ = $_[0];
59 61
62 s/</&lt;/g; 64 s/</&lt;/g;
63 65
64 $_ 66 $_
65} 67}
66 68
67package CFPlus::Database; 69sub socketpipe() {
70 socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
71 or die "cannot establish bidirectional pipe: $!\n";
68 72
69our @ISA = BerkeleyDB::Btree::; 73 ($fh1, $fh2)
70
71sub get($$) {
72 my $data;
73
74 $_[0]->db_get ($_[1], $data) == 0
75 ? $data
76 : ()
77} 74}
78 75
79my %DB_SYNC; 76sub background(&;&) {
77 my ($bg, $cb) = @_;
80 78
81sub put($$$) { 79 my ($fh_r, $fh_w) = CFPlus::socketpipe;
82 my ($db, $key, $data) = @_;
83 80
84 my $hkey = $db + 0; 81 my $pid = fork;
85 Scalar::Util::weaken $db; 82
86 $DB_SYNC{$hkey} ||= AnyEvent->timer (after => 5, cb => sub { 83 if (defined $pid && !$pid) {
87 delete $DB_SYNC{$hkey}; 84 local $SIG{__DIE__};
88 $db->db_sync if $db; 85
86 open STDOUT, ">&", $fh_w;
87 open STDERR, ">&", $fh_w;
88 close $fh_r;
89 close $fh_w;
90
91 $| = 1;
92
93 eval { $bg->() };
94
95 if ($@) {
96 my $msg = $@;
97 $msg =~ s/\n+/\n/;
98 warn "FATAL: $msg";
99 CFPlus::_exit 1;
100 }
101
102 # win32 is fucked up, of course. exit will clean stuff up,
103 # which destroys our database etc. _exit will exit ALL
104 # forked processes, because of the dreaded fork emulation.
105 CFPlus::_exit 0;
106 }
107
108 close $fh_w;
109
110 my $buffer;
111
112 my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
113 unless (sysread $fh_r, $buffer, 4096, length $buffer) {
114 undef $w;
115 $cb->();
116 return;
117 }
118
119 while ($buffer =~ s/^(.*)\n//) {
120 my $line = $1;
121 $line =~ s/\s+$//;
122 utf8::decode $line;
123 if ($line =~ /^\x{e877}json_msg (.*)$/s) {
124 $cb->(JSON::XS->new->allow_nonref->decode ($1));
125 } else {
126 ::message ({
127 markup => "background($pid): " . CFPlus::asxml $line,
128 });
129 }
130 }
89 }); 131 });
132}
90 133
91 $db->db_put ($key => $data) 134sub background_msg {
135 my ($msg) = @_;
136
137 $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
138 $msg =~ s/\n//g;
139 utf8::encode $msg;
140 print $msg, "\n";
92} 141}
93 142
94package CFPlus; 143package CFPlus;
95 144
96sub find_rcfile($) { 145sub find_rcfile($) {
100 $path = "$_/CFPlus/resources/$_[0]"; 149 $path = "$_/CFPlus/resources/$_[0]";
101 return $path if -r $path; 150 return $path if -r $path;
102 } 151 }
103 152
104 die "FATAL: can't find required file $_[0]\n"; 153 die "FATAL: can't find required file $_[0]\n";
105}
106
107BEGIN {
108 use Crossfire::Protocol::Base ();
109 *to_json = \&Crossfire::Protocol::Base::to_json;
110 *from_json = \&Crossfire::Protocol::Base::from_json;
111} 154}
112 155
113sub read_cfg { 156sub read_cfg {
114 my ($file) = @_; 157 my ($file) = @_;
115 158
122 if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove 165 if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove
123 require YAML; 166 require YAML;
124 utf8::decode $CFG; 167 utf8::decode $CFG;
125 $::CFG = YAML::Load ($CFG); 168 $::CFG = YAML::Load ($CFG);
126 } elsif ($CFG =~ /^\{/) { 169 } elsif ($CFG =~ /^\{/) {
127 $::CFG = from_json $CFG; 170 $::CFG = decode_json $CFG;
128 } else { 171 } else {
129 $::CFG = eval $CFG; ## todo comaptibility cruft 172 $::CFG = eval $CFG; ## todo comaptibility cruft
130 } 173 }
131} 174}
132 175
135 178
136 $::CFG->{VERSION} = $::VERSION; 179 $::CFG->{VERSION} = $::VERSION;
137 180
138 open my $fh, ">:utf8", $file 181 open my $fh, ">:utf8", $file
139 or return; 182 or return;
140 print $fh to_json $::CFG; 183 print $fh encode_json $::CFG;
141} 184}
142 185
143sub http_proxy { 186sub http_proxy {
144 my @proxy = win32_proxy_info; 187 my @proxy = win32_proxy_info;
145 188
157 or return; 200 or return;
158 201
159 $ENV{http_proxy} = $proxy; 202 $ENV{http_proxy} = $proxy;
160} 203}
161 204
162our $DB_ENV; 205sub lwp_useragent {
163our $DB_STATE; 206 require LWP::UserAgent;
207
208 CFPlus::set_proxy;
164 209
165sub db_table($) { 210 my $ua = LWP::UserAgent->new (
211 agent => "cfplus $VERSION",
212 keep_alive => 1,
213 env_proxy => 1,
214 timeout => 30,
215 );
216}
217
218sub lwp_check($) {
166 my ($table) = @_; 219 my ($res) = @_;
167 220
168 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 221 $res->is_error
222 and die $res->status_line;
169 223
170 new CFPlus::Database 224 $res
171 -Env => $DB_ENV,
172 -Filename => $table,
173# -Filename => "database",
174# -Subname => $table,
175 -Property => DB_CHKSUM,
176 -Flags => DB_CREATE | DB_UPGRADE,
177 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
178} 225}
179 226
180{ 227sub fh_nonblocking($$) {
181 use strict; 228 my ($fh, $nb) = @_;
182 229
183 mkdir "$Crossfire::VARDIR/cfplus", 0777; 230 if ($^O eq "MSWin32") {
184 my $recover = $BerkeleyDB::db_version >= 4.4 231 $nb = (! ! $nb) + 0;
185 ? eval "DB_REGISTER | DB_RECOVER" 232 ioctl $fh, 0x8004667e, \$nb; # FIONBIO
186 : 0; 233 } else {
234 fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
235 }
187 236
188 $DB_ENV = new BerkeleyDB::Env
189 -Home => "$Crossfire::VARDIR/cfplus",
190 -Cachesize => 1_000_000,
191 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
192# -ErrPrefix => "DATABASE",
193 -Verbose => 1,
194 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover,
195 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
196 or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
197
198 $DB_STATE = db_table "state";
199} 237}
200 238
201package CFPlus::Layout; 239package CFPlus::Layout;
202 240
203$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { 241$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {
204 reset_glyph_cache; 242 reset_glyph_cache;
205}; 243};
206 244
207package CFPlus::Item;
208
209use strict;
210use Crossfire::Protocol::Constants;
211
212my $last_enter_count = 1;
213
214sub desc_string {
215 my ($self) = @_;
216
217 my $desc =
218 $self->{nrof} < 2
219 ? $self->{name}
220 : "$self->{nrof} × $self->{name_pl}";
221
222 $self->{flags} & F_OPEN
223 and $desc .= " (open)";
224 $self->{flags} & F_APPLIED
225 and $desc .= " (applied)";
226 $self->{flags} & F_UNPAID
227 and $desc .= " (unpaid)";
228 $self->{flags} & F_MAGIC
229 and $desc .= " (magic)";
230 $self->{flags} & F_CURSED
231 and $desc .= " (cursed)";
232 $self->{flags} & F_DAMNED
233 and $desc .= " (damned)";
234 $self->{flags} & F_LOCKED
235 and $desc .= " *";
236
237 $desc
238}
239
240sub weight_string {
241 my ($self) = @_;
242
243 my $weight = ($self->{nrof} || 1) * $self->{weight};
244
245 $weight < 0 ? "?" : $weight * 0.001
246}
247
248sub do_n_dialog {
249 my ($cb) = @_;
250
251 my $w = new CFPlus::UI::Toplevel
252 on_delete => sub { $_[0]->destroy; 1 },
253 has_close_button => 1,
254 ;
255
256 $w->add (my $vb = new CFPlus::UI::VBox x => "center", y => "center");
257 $vb->add (new CFPlus::UI::Label text => "Enter item count:");
258 $vb->add (my $entry = new CFPlus::UI::Entry
259 text => $last_enter_count,
260 on_activate => sub {
261 my ($entry) = @_;
262 $last_enter_count = $entry->get_text;
263 $cb->($last_enter_count);
264 $w->hide;
265 $w->destroy;
266
267 0
268 },
269 on_escape => sub { $w->destroy; 1 },
270 );
271 $entry->grab_focus;
272 $w->show;
273}
274
275sub update_widgets {
276 my ($self) = @_;
277
278 # necessary to avoid cyclic references
279 Scalar::Util::weaken $self;
280
281 my $button_cb = sub {
282 my (undef, $ev, $x, $y) = @_;
283
284 my $targ = $::CONN->{player}{tag};
285
286 if ($self->{container} == $::CONN->{player}{tag}) {
287 $targ = $::CONN->{open_container};
288 }
289
290 if (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 1) {
291 $::CONN->send ("move $targ $self->{tag} 0")
292 if $targ || !($self->{flags} & F_LOCKED);
293 } elsif (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 2) {
294 $self->{flags} & F_LOCKED
295 ? $::CONN->send ("lock " . pack "CN", 0, $self->{tag})
296 : $::CONN->send ("lock " . pack "CN", 1, $self->{tag})
297 } elsif ($ev->{button} == 1) {
298 $::CONN->send ("examine $self->{tag}");
299 } elsif ($ev->{button} == 2) {
300 $::CONN->send ("apply $self->{tag}");
301 } elsif ($ev->{button} == 3) {
302 my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
303 if ($self->{container} == $::CONN->{open_container}) {
304 $move_prefix = "take";
305 }
306
307 my @menu_items = (
308 ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
309 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
310 ["ignite/thaw", # first try of an easier use of flint&steel
311 sub {
312 $::CONN->send ("mark ". pack "N", $self->{tag});
313 $::CONN->send ("command apply flint and steel");
314 }
315 ],
316 ["inscribe", # first try of an easier use of flint&steel
317 sub {
318 &::open_string_query ("Text to inscribe", sub {
319 my ($entry, $txt) = @_;
320 $::CONN->send ("mark ". pack "N", $self->{tag});
321 $::CONN->send ("command use_skill inscription $txt");
322 });
323 }
324 ],
325 ["rename", # first try of an easier use of flint&steel
326 sub {
327 &::open_string_query ("Rename item to:", sub {
328 my ($entry, $txt) = @_;
329 $::CONN->send ("mark ". pack "N", $self->{tag});
330 $::CONN->send ("command rename to <$txt>");
331 }, $self->{name},
332 "If you input no name or erase the current custom name, the custom name will be unset");
333 }
334 ],
335 ["apply", sub { $::CONN->send ("apply $self->{tag}") }],
336 (
337 $self->{flags} & F_LOCKED
338 ? (
339 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
340 )
341 : (
342 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
343 ["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }],
344 ["$move_prefix &lt;n&gt;",
345 sub {
346 do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
347 }
348 ]
349 )
350 ),
351 );
352
353 CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
354 }
355
356 1
357 };
358
359 my $tooltip_std = "<small>"
360 . "Left click - examine item\n"
361 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
362 . "Middle click - apply\n"
363 . "Shift-Middle click - lock/unlock\n"
364 . "Right click - further options"
365 . "</small>\n";
366
367 my $bg = $self->{flags} & F_CURSED ? [1 , 0 , 0, 0.5]
368 : $self->{flags} & F_MAGIC ? [0.2, 0.2, 1, 0.5]
369 : undef;
370
371 $self->{face_widget} ||= new CFPlus::UI::Face
372 can_events => 1,
373 can_hover => 1,
374 anim => $self->{anim},
375 animspeed => $self->{animspeed}, # TODO# must be set at creation time
376 on_button_down => $button_cb,
377 ;
378 $self->{face_widget}{bg} = $bg;
379 $self->{face_widget}{face} = $self->{face};
380 $self->{face_widget}{anim} = $self->{anim};
381 $self->{face_widget}{animspeed} = $self->{animspeed};
382 $self->{face_widget}->set_tooltip (
383 "<b>Face/Animation.</b>\n"
384 . "Item uses face #$self->{face}. "
385 . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
386 . "\n\n$tooltip_std"
387 );
388
389 $self->{desc_widget} ||= new CFPlus::UI::Label
390 can_events => 1,
391 can_hover => 1,
392 ellipsise => 2,
393 align => -1,
394 on_button_down => $button_cb,
395 ;
396 my $desc = CFPlus::Item::desc_string $self;
397 $self->{desc_widget}{bg} = $bg;
398 $self->{desc_widget}->set_text ($desc);
399 $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
400
401 $self->{weight_widget} ||= new CFPlus::UI::Label
402 can_events => 1,
403 can_hover => 1,
404 ellipsise => 0,
405 align => 0,
406 on_button_down => $button_cb,
407 ;
408 $self->{weight_widget}{bg} = $bg;
409 $self->{weight_widget}->set_text (CFPlus::Item::weight_string $self);
410 $self->{weight_widget}->set_tooltip (
411 "<b>Weight</b>.\n"
412 . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
413 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
414 . "\n\n$tooltip_std"
415 );
416}
417
4181; 2451;
419 246
420=back 247=back
421 248
422=head1 AUTHOR 249=head1 AUTHOR

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines