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.190 by root, Tue Sep 2 17:08:44 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-blue", ".");
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 for (@RC_THEME) {
181 $path = "$_/CFPlus/resources/$_[0]"; 162 $path = "$RC_BASE/$_/$_[0]";
182 return $path if -r $path; 163 return $path if -r $path;
183 } 164 }
184 165
185 die "FATAL: can't find required file $_[0]\n"; 166 die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
186} 167}
187 168
188sub read_cfg { 169sub read_cfg {
189 my ($file) = @_; 170 my ($file) = @_;
190 171
… …
192 or return; 173 or return;
193 174
194 local $/; 175 local $/;
195 my $CFG = <$fh>; 176 my $CFG = <$fh>;
196 177
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; 178 $::CFG = decode_json $CFG;
203 } else {
204 $::CFG = eval $CFG; ## todo comaptibility cruft
205 }
206} 179}
207 180
208sub write_cfg { 181sub write_cfg {
209 my ($file) = @_; 182 my $file = "$Deliantra::VARDIR/client.cf";
210 183
211 $::CFG->{VERSION} = $::VERSION; 184 $::CFG->{VERSION} = $::VERSION;
212 185
213 open my $fh, ">:utf8", $file 186 open my $fh, ">:utf8", $file
214 or return; 187 or return;
215 print $fh to_json $::CFG; 188 print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
216} 189}
217 190
218sub http_proxy { 191sub http_proxy {
219 my @proxy = win32_proxy_info; 192 my @proxy = win32_proxy_info;
220 193
… …
235} 208}
236 209
237sub lwp_useragent { 210sub lwp_useragent {
238 require LWP::UserAgent; 211 require LWP::UserAgent;
239 212
240 CFPlus::set_proxy; 213 DC::set_proxy;
241 214
242 my $ua = LWP::UserAgent->new ( 215 my $ua = LWP::UserAgent->new (
243 agent => "cfplus $VERSION", 216 agent => "deliantra $VERSION",
244 keep_alive => 1, 217 keep_alive => 1,
245 env_proxy => 1, 218 env_proxy => 1,
246 timeout => 30, 219 timeout => 30,
247 ); 220 );
248} 221}
… …
254 and die $res->status_line; 227 and die $res->status_line;
255 228
256 $res 229 $res
257} 230}
258 231
259our $DB_ENV; 232sub fh_nonblocking($$) {
260our $DB_STATE;
261
262sub db_table($) {
263 my ($table) = @_; 233 my ($fh, $nb) = @_;
264 234
265 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 235 if ($^O eq "MSWin32") {
266 236 $nb = (! ! $nb) + 0;
267 new CFPlus::Database 237 ioctl $fh, 0x8004667e, \$nb; # FIONBIO
268 -Env => $DB_ENV, 238 } else {
269 -Filename => $table, 239 fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
270# -Filename => "database", 240 }
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} 241}
276 242
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; 243package DC::Layout;
301 244
302$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { 245$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
303 reset_glyph_cache; 246 glyph_cache_restore;
304}; 247};
305 248
306package CFPlus::Item; 249$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
307 250 glyph_cache_backup;
308use strict; 251};
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 252
5201; 2531;
521 254
522=back 255=back
523 256

Diff Legend

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