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

Diff Legend

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