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.133 by root, Wed Dec 6 00:15:12 2006 UTC vs.
Revision 1.188 by root, Tue Sep 2 16:27:34 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
21our $VERSION;
22
19BEGIN { 23BEGIN {
20 $VERSION = '0.97'; 24 $VERSION = '0.9975';
21 25
22 use XSLoader; 26 use XSLoader;
23 XSLoader::load "CFPlus", $VERSION; 27 XSLoader::load "Deliantra::Client", $VERSION;
24} 28}
25 29
26use utf8; 30use utf8;
31use strict qw(vars subs);
27 32
28use AnyEvent (); 33use AnyEvent ();
29use BerkeleyDB;
30use Pod::POM (); 34use Pod::POM ();
31use Scalar::Util (); 35use File::Path ();
32use Storable (); # finally 36use Storable (); # finally
33 37use Fcntl ();
34BEGIN { 38use 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 39
40=item guard { BLOCK } 40=item guard { BLOCK }
41 41
42Returns an object that executes the given block as soon as it is destroyed. 42Returns an object that executes the given block as soon as it is destroyed.
43 43
44=cut 44=cut
45 45
46sub guard(&) { 46sub guard(&) {
47 bless \(my $cb = $_[0]), "CFPlus::Guard" 47 bless \(my $cb = $_[0]), "DC::Guard"
48} 48}
49 49
50sub CFPlus::Guard::DESTROY { 50sub DC::Guard::DESTROY {
51 ${$_[0]}->() 51 ${$_[0]}->()
52} 52}
53 53
54=item shorten $string[, $maxlength] 54=item shorten $string[, $maxlength]
55 55
… …
71 $_ 71 $_
72} 72}
73 73
74sub socketpipe() { 74sub socketpipe() {
75 socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 75 socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
76 or die "cannot establish bidiretcional pipe: $!\n"; 76 or die "cannot establish bidirectional pipe: $!\n";
77 77
78 ($fh1, $fh2) 78 ($fh1, $fh2)
79} 79}
80 80
81sub background(&;&) { 81sub background(&;&) {
82 my ($bg, $cb) = @_; 82 my ($bg, $cb) = @_;
83 83
84 my ($fh_r, $fh_w) = CFPlus::socketpipe; 84 my ($fh_r, $fh_w) = DC::socketpipe;
85 85
86 my $pid = fork; 86 my $pid = fork;
87 87
88 if (defined $pid && !$pid) { 88 if (defined $pid && !$pid) {
89 local $SIG{__DIE__}; 89 local $SIG{__DIE__};
… …
99 99
100 if ($@) { 100 if ($@) {
101 my $msg = $@; 101 my $msg = $@;
102 $msg =~ s/\n+/\n/; 102 $msg =~ s/\n+/\n/;
103 warn "FATAL: $msg"; 103 warn "FATAL: $msg";
104 CFPlus::_exit 1; 104 DC::_exit 1;
105 } 105 }
106 106
107 # win32 is fucked up, of course. exit will clean stuff up, 107 # win32 is fucked up, of course. exit will clean stuff up,
108 # which destroys our database etc. _exit will exit ALL 108 # which destroys our database etc. _exit will exit ALL
109 # forked processes, because of the dreaded fork emulation. 109 # forked processes, because of the dreaded fork emulation.
110 CFPlus::_exit 0; 110 DC::_exit 0;
111 } 111 }
112 112
113 close $fh_w; 113 close $fh_w;
114 114
115 my $buffer; 115 my $buffer;
… …
124 while ($buffer =~ s/^(.*)\n//) { 124 while ($buffer =~ s/^(.*)\n//) {
125 my $line = $1; 125 my $line = $1;
126 $line =~ s/\s+$//; 126 $line =~ s/\s+$//;
127 utf8::decode $line; 127 utf8::decode $line;
128 if ($line =~ /^\x{e877}json_msg (.*)$/s) { 128 if ($line =~ /^\x{e877}json_msg (.*)$/s) {
129 $cb->(from_json $1); 129 $cb->(JSON::XS->new->allow_nonref->decode ($1));
130 } else { 130 } else {
131 ::message ({ 131 ::message ({
132 markup => "background($pid): " . CFPlus::asxml $line, 132 markup => "background($pid): " . DC::asxml $line,
133 }); 133 });
134 } 134 }
135 } 135 }
136 }); 136 });
137} 137}
138 138
139sub background_msg { 139sub background_msg {
140 my ($msg) = @_; 140 my ($msg) = @_;
141 141
142 $msg = "\x{e877}json_msg " . to_json $msg; 142 $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
143 $msg =~ s/\n//g; 143 $msg =~ s/\n//g;
144 utf8::encode $msg; 144 utf8::encode $msg;
145 print $msg, "\n"; 145 print $msg, "\n";
146} 146}
147 147
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; 148package DC;
149
150our $RC_THEME = "theme-metal";
151our $RC_BASE;
152
153for (grep !ref, @INC) {
154 $RC_BASE = "$_/Deliantra/Client/private/resources";
155 last if -d $RC_BASE;
156}
176 157
177sub find_rcfile($) { 158sub find_rcfile($) {
178 my $path; 159 my $path;
179 160
180 for (grep !ref, @INC) { 161 $path = "$RC_BASE/$RC_THEME/$_[0]";
181 $path = "$_/CFPlus/resources/$_[0]";
182 return $path if -r $path; 162 return $path if -r $path;
183 }
184 163
164 $path = "$RC_BASE/$_[0]";
165 return $path if -r $path;
166
185 die "FATAL: can't find required file $_[0]\n"; 167 die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
186} 168}
187 169
188sub read_cfg { 170sub read_cfg {
189 my ($file) = @_; 171 my ($file) = @_;
190 172
… …
192 or return; 174 or return;
193 175
194 local $/; 176 local $/;
195 my $CFG = <$fh>; 177 my $CFG = <$fh>;
196 178
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; 179 $::CFG = decode_json $CFG;
203 } else {
204 $::CFG = eval $CFG; ## todo comaptibility cruft
205 }
206} 180}
207 181
208sub write_cfg { 182sub write_cfg {
209 my ($file) = @_; 183 my $file = "$Deliantra::VARDIR/client.cf";
210 184
211 $::CFG->{VERSION} = $::VERSION; 185 $::CFG->{VERSION} = $::VERSION;
212 186
213 open my $fh, ">:utf8", $file 187 open my $fh, ">:utf8", $file
214 or return; 188 or return;
215 print $fh to_json $::CFG; 189 print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
216} 190}
217 191
218sub http_proxy { 192sub http_proxy {
219 my @proxy = win32_proxy_info; 193 my @proxy = win32_proxy_info;
220 194
… …
235} 209}
236 210
237sub lwp_useragent { 211sub lwp_useragent {
238 require LWP::UserAgent; 212 require LWP::UserAgent;
239 213
240 CFPlus::set_proxy; 214 DC::set_proxy;
241 215
242 my $ua = LWP::UserAgent->new ( 216 my $ua = LWP::UserAgent->new (
243 agent => "cfplus $VERSION", 217 agent => "deliantra $VERSION",
244 keep_alive => 1, 218 keep_alive => 1,
245 env_proxy => 1, 219 env_proxy => 1,
246 timeout => 30, 220 timeout => 30,
247 ); 221 );
248} 222}
… …
254 and die $res->status_line; 228 and die $res->status_line;
255 229
256 $res 230 $res
257} 231}
258 232
259our $DB_ENV; 233sub fh_nonblocking($$) {
260our $DB_STATE;
261
262sub db_table($) {
263 my ($table) = @_; 234 my ($fh, $nb) = @_;
264 235
265 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 236 if ($^O eq "MSWin32") {
266 237 $nb = (! ! $nb) + 0;
267 new CFPlus::Database 238 ioctl $fh, 0x8004667e, \$nb; # FIONBIO
268 -Env => $DB_ENV, 239 } else {
269 -Filename => $table, 240 fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
270# -Filename => "database", 241 }
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} 242}
276 243
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 => "$Crossfire::VARDIR/cfplus/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; 244package DC::Layout;
301 245
302$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { 246$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
303 reset_glyph_cache; 247 glyph_cache_restore;
304}; 248};
305 249
306package CFPlus::Item; 250$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
307 251 glyph_cache_backup;
308use strict; 252};
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 253
5201; 2541;
521 255
522=back 256=back
523 257

Diff Legend

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