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.134 by root, Thu Dec 7 03:54:47 2006 UTC vs.
Revision 1.186 by root, Tue Aug 19 17:38:29 2008 UTC

1=head1 NAME 1=head1 NAME
2 2
3CFPlus - undocumented utility garbage for our crossfire client 3DC - undocumented utility garbage for our deliantra client
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use CFPlus; 7 use DC;
8 8
9=head1 DESCRIPTION 9=head1 DESCRIPTION
10 10
11=over 4 11=over 4
12 12
13=cut 13=cut
14 14
15package Deliantra::Client; # work around CPAN breakage
16package App::Deliantra; # try to reserve namespace
15package CFPlus; 17package DC;
16 18
17use Carp (); 19use Carp ();
18 20
19BEGIN { 21BEGIN {
20 $VERSION = '0.97'; 22 $VERSION = '0.9975';
21 23
22 use XSLoader; 24 use XSLoader;
23 XSLoader::load "CFPlus", $VERSION; 25 XSLoader::load "Deliantra::Client", $VERSION;
24} 26}
25 27
26use utf8; 28use utf8;
27 29
28use AnyEvent (); 30use AnyEvent ();
29use BerkeleyDB;
30use Pod::POM (); 31use Pod::POM ();
31use Scalar::Util (); 32use File::Path ();
32use Storable (); # finally 33use Storable (); # finally
33 34use Fcntl ();
34BEGIN { 35use JSON::XS qw(encode_json decode_json);
35 use Crossfire::Protocol::Base ();
36 *to_json = \&Crossfire::Protocol::Base::to_json;
37 *from_json = \&Crossfire::Protocol::Base::from_json;
38}
39 36
40=item guard { BLOCK } 37=item guard { BLOCK }
41 38
42Returns an object that executes the given block as soon as it is destroyed. 39Returns an object that executes the given block as soon as it is destroyed.
43 40
44=cut 41=cut
45 42
46sub guard(&) { 43sub guard(&) {
47 bless \(my $cb = $_[0]), "CFPlus::Guard" 44 bless \(my $cb = $_[0]), "DC::Guard"
48} 45}
49 46
50sub CFPlus::Guard::DESTROY { 47sub DC::Guard::DESTROY {
51 ${$_[0]}->() 48 ${$_[0]}->()
52} 49}
53 50
54=item shorten $string[, $maxlength] 51=item shorten $string[, $maxlength]
55 52
… …
71 $_ 68 $_
72} 69}
73 70
74sub socketpipe() { 71sub socketpipe() {
75 socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 72 socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
76 or die "cannot establish bidiretcional pipe: $!\n"; 73 or die "cannot establish bidirectional pipe: $!\n";
77 74
78 ($fh1, $fh2) 75 ($fh1, $fh2)
79} 76}
80 77
81sub background(&;&) { 78sub background(&;&) {
82 my ($bg, $cb) = @_; 79 my ($bg, $cb) = @_;
83 80
84 my ($fh_r, $fh_w) = CFPlus::socketpipe; 81 my ($fh_r, $fh_w) = DC::socketpipe;
85 82
86 my $pid = fork; 83 my $pid = fork;
87 84
88 if (defined $pid && !$pid) { 85 if (defined $pid && !$pid) {
89 local $SIG{__DIE__}; 86 local $SIG{__DIE__};
… …
99 96
100 if ($@) { 97 if ($@) {
101 my $msg = $@; 98 my $msg = $@;
102 $msg =~ s/\n+/\n/; 99 $msg =~ s/\n+/\n/;
103 warn "FATAL: $msg"; 100 warn "FATAL: $msg";
104 CFPlus::_exit 1; 101 DC::_exit 1;
105 } 102 }
106 103
107 # win32 is fucked up, of course. exit will clean stuff up, 104 # win32 is fucked up, of course. exit will clean stuff up,
108 # which destroys our database etc. _exit will exit ALL 105 # which destroys our database etc. _exit will exit ALL
109 # forked processes, because of the dreaded fork emulation. 106 # forked processes, because of the dreaded fork emulation.
110 CFPlus::_exit 0; 107 DC::_exit 0;
111 } 108 }
112 109
113 close $fh_w; 110 close $fh_w;
114 111
115 my $buffer; 112 my $buffer;
… …
124 while ($buffer =~ s/^(.*)\n//) { 121 while ($buffer =~ s/^(.*)\n//) {
125 my $line = $1; 122 my $line = $1;
126 $line =~ s/\s+$//; 123 $line =~ s/\s+$//;
127 utf8::decode $line; 124 utf8::decode $line;
128 if ($line =~ /^\x{e877}json_msg (.*)$/s) { 125 if ($line =~ /^\x{e877}json_msg (.*)$/s) {
129 $cb->(from_json $1); 126 $cb->(JSON::XS->new->allow_nonref->decode ($1));
130 } else { 127 } else {
131 ::message ({ 128 ::message ({
132 markup => "background($pid): " . CFPlus::asxml $line, 129 markup => "background($pid): " . DC::asxml $line,
133 }); 130 });
134 } 131 }
135 } 132 }
136 }); 133 });
137} 134}
138 135
139sub background_msg { 136sub background_msg {
140 my ($msg) = @_; 137 my ($msg) = @_;
141 138
142 $msg = "\x{e877}json_msg " . to_json $msg; 139 $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
143 $msg =~ s/\n//g; 140 $msg =~ s/\n//g;
144 utf8::encode $msg; 141 utf8::encode $msg;
145 print $msg, "\n"; 142 print $msg, "\n";
146} 143}
147 144
148package CFPlus::Database;
149
150our @ISA = BerkeleyDB::Btree::;
151
152sub get($$) {
153 my $data;
154
155 $_[0]->db_get ($_[1], $data) == 0
156 ? $data
157 : ()
158}
159
160my %DB_SYNC;
161
162sub put($$$) {
163 my ($db, $key, $data) = @_;
164
165 my $hkey = $db + 0;
166 Scalar::Util::weaken $db;
167 $DB_SYNC{$hkey} ||= AnyEvent->timer (after => 5, cb => sub {
168 delete $DB_SYNC{$hkey};
169 $db->db_sync if $db;
170 });
171
172 $db->db_put ($key => $data)
173}
174
175package CFPlus; 145package DC;
176 146
177sub find_rcfile($) { 147sub find_rcfile($) {
178 my $path; 148 my $path;
179 149
180 for (grep !ref, @INC) { 150 for (grep !ref, @INC) {
181 $path = "$_/CFPlus/resources/$_[0]"; 151 $path = "$_/Deliantra/Client/private/resources/$_[0]";
182 return $path if -r $path; 152 return $path if -r $path;
183 } 153 }
184 154
185 die "FATAL: can't find required file $_[0]\n"; 155 die "FATAL: can't find required file $_[0]\n";
186} 156}
… …
192 or return; 162 or return;
193 163
194 local $/; 164 local $/;
195 my $CFG = <$fh>; 165 my $CFG = <$fh>;
196 166
197 if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove
198 require YAML;
199 utf8::decode $CFG;
200 $::CFG = YAML::Load ($CFG);
201 } elsif ($CFG =~ /^\{/) {
202 $::CFG = from_json $CFG; 167 $::CFG = decode_json $CFG;
203 } else {
204 $::CFG = eval $CFG; ## todo comaptibility cruft
205 }
206} 168}
207 169
208sub write_cfg { 170sub write_cfg {
209 my ($file) = @_; 171 my $file = "$Deliantra::VARDIR/client.cf";
210 172
211 $::CFG->{VERSION} = $::VERSION; 173 $::CFG->{VERSION} = $::VERSION;
212 174
213 open my $fh, ">:utf8", $file 175 open my $fh, ">:utf8", $file
214 or return; 176 or return;
215 print $fh to_json $::CFG; 177 print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
216} 178}
217 179
218sub http_proxy { 180sub http_proxy {
219 my @proxy = win32_proxy_info; 181 my @proxy = win32_proxy_info;
220 182
… …
235} 197}
236 198
237sub lwp_useragent { 199sub lwp_useragent {
238 require LWP::UserAgent; 200 require LWP::UserAgent;
239 201
240 CFPlus::set_proxy; 202 DC::set_proxy;
241 203
242 my $ua = LWP::UserAgent->new ( 204 my $ua = LWP::UserAgent->new (
243 agent => "cfplus $VERSION", 205 agent => "deliantra $VERSION",
244 keep_alive => 1, 206 keep_alive => 1,
245 env_proxy => 1, 207 env_proxy => 1,
246 timeout => 30, 208 timeout => 30,
247 ); 209 );
248} 210}
… …
254 and die $res->status_line; 216 and die $res->status_line;
255 217
256 $res 218 $res
257} 219}
258 220
259our $DB_ENV; 221sub fh_nonblocking($$) {
260our $DB_STATE;
261
262sub db_table($) {
263 my ($table) = @_; 222 my ($fh, $nb) = @_;
264 223
265 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 224 if ($^O eq "MSWin32") {
266 225 $nb = (! ! $nb) + 0;
267 new CFPlus::Database 226 ioctl $fh, 0x8004667e, \$nb; # FIONBIO
268 -Env => $DB_ENV, 227 } else {
269 -Filename => $table, 228 fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
270# -Filename => "database", 229 }
271# -Subname => $table,
272 -Property => DB_CHKSUM,
273 -Flags => DB_CREATE | DB_UPGRADE,
274 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
275} 230}
276 231
277{
278 use strict;
279
280 my $HOME = "$Crossfire::VARDIR/cfplus-$BerkeleyDB::db_version";
281
282 mkdir $HOME, 0777;
283 my $recover = $BerkeleyDB::db_version >= 4.4
284 ? eval "DB_REGISTER | DB_RECOVER"
285 : 0;
286
287 $DB_ENV = new BerkeleyDB::Env
288 -Home => $HOME,
289 -Cachesize => 1_000_000,
290 -ErrFile => "$HOME/errorlog.txt",
291# -ErrPrefix => "DATABASE",
292 -Verbose => 1,
293 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover,
294 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
295 or die "unable to create/open database home $HOME: $BerkeleyDB::Error";
296
297 $DB_STATE = db_table "state";
298}
299
300package CFPlus::Layout; 232package DC::Layout;
301 233
302$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { 234$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
303 reset_glyph_cache; 235 glyph_cache_restore;
304}; 236};
305 237
306package CFPlus::Item; 238$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
307 239 glyph_cache_backup;
308use strict; 240};
309use Crossfire::Protocol::Constants;
310
311my $last_enter_count = 1;
312
313sub desc_string {
314 my ($self) = @_;
315
316 my $desc =
317 $self->{nrof} < 2
318 ? $self->{name}
319 : "$self->{nrof} × $self->{name_pl}";
320
321 $self->{flags} & F_OPEN
322 and $desc .= " (open)";
323 $self->{flags} & F_APPLIED
324 and $desc .= " (applied)";
325 $self->{flags} & F_UNPAID
326 and $desc .= " (unpaid)";
327 $self->{flags} & F_MAGIC
328 and $desc .= " (magic)";
329 $self->{flags} & F_CURSED
330 and $desc .= " (cursed)";
331 $self->{flags} & F_DAMNED
332 and $desc .= " (damned)";
333 $self->{flags} & F_LOCKED
334 and $desc .= " *";
335
336 $desc
337}
338
339sub weight_string {
340 my ($self) = @_;
341
342 my $weight = ($self->{nrof} || 1) * $self->{weight};
343
344 $weight < 0 ? "?" : $weight * 0.001
345}
346
347sub do_n_dialog {
348 my ($cb) = @_;
349
350 my $w = new CFPlus::UI::Toplevel
351 on_delete => sub { $_[0]->destroy; 1 },
352 has_close_button => 1,
353 ;
354
355 $w->add (my $vb = new CFPlus::UI::VBox x => "center", y => "center");
356 $vb->add (new CFPlus::UI::Label text => "Enter item count:");
357 $vb->add (my $entry = new CFPlus::UI::Entry
358 text => $last_enter_count,
359 on_activate => sub {
360 my ($entry) = @_;
361 $last_enter_count = $entry->get_text;
362 $cb->($last_enter_count);
363 $w->hide;
364 $w->destroy;
365
366 0
367 },
368 on_escape => sub { $w->destroy; 1 },
369 );
370 $entry->grab_focus;
371 $w->show;
372}
373
374sub update_widgets {
375 my ($self) = @_;
376
377 # necessary to avoid cyclic references
378 Scalar::Util::weaken $self;
379
380 my $button_cb = sub {
381 my (undef, $ev, $x, $y) = @_;
382
383 my $targ = $::CONN->{player}{tag};
384
385 if ($self->{container} == $::CONN->{player}{tag}) {
386 $targ = $::CONN->{open_container};
387 }
388
389 if (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 1) {
390 $::CONN->send ("move $targ $self->{tag} 0")
391 if $targ || !($self->{flags} & F_LOCKED);
392 } elsif (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 2) {
393 $self->{flags} & F_LOCKED
394 ? $::CONN->send ("lock " . pack "CN", 0, $self->{tag})
395 : $::CONN->send ("lock " . pack "CN", 1, $self->{tag})
396 } elsif ($ev->{button} == 1) {
397 $::CONN->send ("examine $self->{tag}");
398 } elsif ($ev->{button} == 2) {
399 $::CONN->send ("apply $self->{tag}");
400 } elsif ($ev->{button} == 3) {
401 my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
402 if ($self->{container} == $::CONN->{open_container}) {
403 $move_prefix = "take";
404 }
405
406 my $shortname = CFPlus::shorten $self->{name}, 14;
407
408 my @menu_items = (
409 ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
410 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
411 ["ignite/thaw", # first try of an easier use of flint&steel
412 sub {
413 $::CONN->send ("mark ". pack "N", $self->{tag});
414 $::CONN->send ("command apply flint and steel");
415 }
416 ],
417 ["inscribe", # first try of an easier use of flint&steel
418 sub {
419 &::open_string_query ("Text to inscribe", sub {
420 my ($entry, $txt) = @_;
421 $::CONN->send ("mark ". pack "N", $self->{tag});
422 $::CONN->send ("command use_skill inscription $txt");
423 });
424 }
425 ],
426 ["rename", # first try of an easier use of flint&steel
427 sub {
428 &::open_string_query ("Rename item to:", sub {
429 my ($entry, $txt) = @_;
430 $::CONN->send ("mark ". pack "N", $self->{tag});
431 $::CONN->send ("command rename to <$txt>");
432 }, $self->{name},
433 "If you input no name or erase the current custom name, the custom name will be unset");
434 }
435 ],
436 ["apply", sub { $::CONN->send ("apply $self->{tag}") }],
437 (
438 $self->{flags} & F_LOCKED
439 ? (
440 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
441 )
442 : (
443 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
444 ["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }],
445 ["$move_prefix &lt;n&gt;",
446 sub {
447 do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
448 }
449 ]
450 )
451 ),
452 ["bind <i>apply $shortname</i> to a key" => sub { $::BIND_EDITOR->do_quick_binding (["apply $self->{name}"]) }],
453 );
454
455 CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
456 }
457
458 1
459 };
460
461 my $tooltip_std = "<small>"
462 . "Left click - examine item\n"
463 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
464 . "Middle click - apply\n"
465 . "Shift-Middle click - lock/unlock\n"
466 . "Right click - further options"
467 . "</small>\n";
468
469 my $bg = $self->{flags} & F_CURSED ? [1 , 0 , 0, 0.5]
470 : $self->{flags} & F_MAGIC ? [0.2, 0.2, 1, 0.5]
471 : undef;
472
473 $self->{face_widget} ||= new CFPlus::UI::Face
474 can_events => 1,
475 can_hover => 1,
476 anim => $self->{anim},
477 animspeed => $self->{animspeed}, # TODO# must be set at creation time
478 on_button_down => $button_cb,
479 ;
480 $self->{face_widget}{bg} = $bg;
481 $self->{face_widget}{face} = $self->{face};
482 $self->{face_widget}{anim} = $self->{anim};
483 $self->{face_widget}{animspeed} = $self->{animspeed};
484 $self->{face_widget}->set_tooltip (
485 "<b>Face/Animation.</b>\n"
486 . "Item uses face #$self->{face}. "
487 . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
488 . "\n\n$tooltip_std"
489 );
490
491 $self->{desc_widget} ||= new CFPlus::UI::Label
492 can_events => 1,
493 can_hover => 1,
494 ellipsise => 2,
495 align => -1,
496 on_button_down => $button_cb,
497 ;
498 my $desc = CFPlus::Item::desc_string $self;
499 $self->{desc_widget}{bg} = $bg;
500 $self->{desc_widget}->set_text ($desc);
501 $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
502
503 $self->{weight_widget} ||= new CFPlus::UI::Label
504 can_events => 1,
505 can_hover => 1,
506 ellipsise => 0,
507 align => 0,
508 on_button_down => $button_cb,
509 ;
510 $self->{weight_widget}{bg} = $bg;
511 $self->{weight_widget}->set_text (CFPlus::Item::weight_string $self);
512 $self->{weight_widget}->set_tooltip (
513 "<b>Weight</b>.\n"
514 . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
515 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
516 . "\n\n$tooltip_std"
517 );
518}
519 241
5201; 2421;
521 243
522=back 244=back
523 245

Diff Legend

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