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

Diff Legend

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