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.172 by root, Sun Jan 13 08:47:00 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.9964';
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 $SIG{__DIE__} = sub { 84 local $SIG{__DIE__};
83 my $msg = $_[0];
84 $msg =~ s/\n+/\n/;
85 warn "FATAL: $msg";
86 CFPlus::_exit 99;
87 };
88 85
89 open STDOUT, ">&", $fh_w; 86 open STDOUT, ">&", $fh_w;
90 open STDERR, ">&", $fh_w; 87 open STDERR, ">&", $fh_w;
91 close $fh_r; 88 close $fh_r;
92 close $fh_w; 89 close $fh_w;
93 90
94 $| = 1; 91 $| = 1;
95 92
96 $cb->(); 93 eval { $bg->() };
94
95 if ($@) {
96 my $msg = $@;
97 $msg =~ s/\n+/\n/;
98 warn "FATAL: $msg";
99 DC::_exit 1;
100 }
97 101
98 # win32 is fucked up, of course. exit will clean stuff up, 102 # win32 is fucked up, of course. exit will clean stuff up,
99 # which destroys our database etc. _exit will exit ALL 103 # which destroys our database etc. _exit will exit ALL
100 # forked processes, because of the dreaded fork emulation. 104 # forked processes, because of the dreaded fork emulation.
101 CFPlus::_exit 0; 105 DC::_exit 0;
102 } 106 }
103 107
104 close $fh_w; 108 close $fh_w;
105 109
106 my $buffer; 110 my $buffer;
107 111
108 Event->io (fd => $fh_r, poll => 'r', cb => sub { 112 my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
109 unless (sysread $fh_r, $buffer, 4096, length $buffer) { 113 unless (sysread $fh_r, $buffer, 4096, length $buffer) {
110 $_[0]->w->cancel; 114 undef $w;
111 $buffer .= "done\n"; 115 $cb->();
116 return;
112 } 117 }
113 118
114 while ($buffer =~ s/^(.*)\n//) { 119 while ($buffer =~ s/^(.*)\n//) {
115 my $line = $1; 120 my $line = $1;
121 $line =~ s/\s+$//;
116 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 {
117 ::message ({ 126 ::message ({
118 markup => "editor($pid): " . CFPlus::asxml $line, 127 markup => "background($pid): " . DC::asxml $line,
128 });
119 }); 129 }
120 } 130 }
121 }); 131 });
122} 132}
123 133
124package CFPlus::Database; 134sub background_msg {
135 my ($msg) = @_;
125 136
126our @ISA = BerkeleyDB::Btree::; 137 $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
127 138 $msg =~ s/\n//g;
128sub get($$) { 139 utf8::encode $msg;
129 my $data; 140 print $msg, "\n";
130
131 $_[0]->db_get ($_[1], $data) == 0
132 ? $data
133 : ()
134} 141}
135 142
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; 143package DC;
152 144
153sub find_rcfile($) { 145sub find_rcfile($) {
154 my $path; 146 my $path;
155 147
156 for (grep !ref, @INC) { 148 for (grep !ref, @INC) {
157 $path = "$_/CFPlus/resources/$_[0]"; 149 $path = "$_/Deliantra/Client/private/resources/$_[0]";
158 return $path if -r $path; 150 return $path if -r $path;
159 } 151 }
160 152
161 die "FATAL: can't find required file $_[0]\n"; 153 die "FATAL: can't find required file $_[0]\n";
162}
163
164BEGIN {
165 use Crossfire::Protocol::Base ();
166 *to_json = \&Crossfire::Protocol::Base::to_json;
167 *from_json = \&Crossfire::Protocol::Base::from_json;
168} 154}
169 155
170sub read_cfg { 156sub read_cfg {
171 my ($file) = @_; 157 my ($file) = @_;
172 158
… …
174 or return; 160 or return;
175 161
176 local $/; 162 local $/;
177 my $CFG = <$fh>; 163 my $CFG = <$fh>;
178 164
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; 165 $::CFG = decode_json $CFG;
185 } else {
186 $::CFG = eval $CFG; ## todo comaptibility cruft
187 }
188} 166}
189 167
190sub write_cfg { 168sub write_cfg {
191 my ($file) = @_; 169 my ($file) = @_;
192 170
193 $::CFG->{VERSION} = $::VERSION; 171 $::CFG->{VERSION} = $::VERSION;
194 172
195 open my $fh, ">:utf8", $file 173 open my $fh, ">:utf8", $file
196 or return; 174 or return;
197 print $fh to_json $::CFG; 175 print $fh encode_json $::CFG;
198} 176}
199 177
200sub http_proxy { 178sub http_proxy {
201 my @proxy = win32_proxy_info; 179 my @proxy = win32_proxy_info;
202 180
… …
214 or return; 192 or return;
215 193
216 $ENV{http_proxy} = $proxy; 194 $ENV{http_proxy} = $proxy;
217} 195}
218 196
219our $DB_ENV; 197sub lwp_useragent {
220our $DB_STATE; 198 require LWP::UserAgent;
199
200 DC::set_proxy;
221 201
222sub 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($) {
223 my ($table) = @_; 211 my ($res) = @_;
224 212
225 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 213 $res->is_error
214 and die $res->status_line;
226 215
227 new CFPlus::Database 216 $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} 217}
236 218
237{ 219sub fh_nonblocking($$) {
238 use strict; 220 my ($fh, $nb) = @_;
239 221
240 mkdir "$Crossfire::VARDIR/cfplus", 0777; 222 if ($^O eq "MSWin32") {
241 my $recover = $BerkeleyDB::db_version >= 4.4 223 $nb = (! ! $nb) + 0;
242 ? eval "DB_REGISTER | DB_RECOVER" 224 ioctl $fh, 0x8004667e, \$nb; # FIONBIO
243 : 0; 225 } else {
226 fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
227 }
244 228
245 $DB_ENV = new BerkeleyDB::Env
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} 229}
257 230
258package CFPlus::Layout; 231package DC::Layout;
259 232
260$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { 233$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
261 reset_glyph_cache; 234 glyph_cache_restore;
262}; 235};
263 236
264package CFPlus::Item; 237$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
265 238 glyph_cache_backup;
266use strict; 239};
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 240
4751; 2411;
476 242
477=back 243=back
478 244

Diff Legend

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