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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines