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.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.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
62 s/</&lt;/g; 69 s/</&lt;/g;
63 70
64 $_ 71 $_
65} 72}
66 73
67package CFPlus::Database; 74sub socketpipe() {
75 socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
76 or die "cannot establish bidirectional pipe: $!\n";
68 77
69our @ISA = BerkeleyDB::Btree::; 78 ($fh1, $fh2)
70
71sub get($$) {
72 my $data;
73
74 $_[0]->db_get ($_[1], $data) == 0
75 ? $data
76 : ()
77} 79}
78 80
79my %DB_SYNC; 81sub background(&;&) {
82 my ($bg, $cb) = @_;
80 83
81sub put($$$) { 84 my ($fh_r, $fh_w) = DC::socketpipe;
82 my ($db, $key, $data) = @_;
83 85
84 my $hkey = $db + 0; 86 my $pid = fork;
85 Scalar::Util::weaken $db; 87
86 $DB_SYNC{$hkey} ||= AnyEvent->timer (after => 5, cb => sub { 88 if (defined $pid && !$pid) {
87 delete $DB_SYNC{$hkey}; 89 local $SIG{__DIE__};
88 $db->db_sync if $db; 90
91 open STDOUT, ">&", $fh_w;
92 open STDERR, ">&", $fh_w;
93 close $fh_r;
94 close $fh_w;
95
96 $| = 1;
97
98 eval { $bg->() };
99
100 if ($@) {
101 my $msg = $@;
102 $msg =~ s/\n+/\n/;
103 warn "FATAL: $msg";
104 DC::_exit 1;
105 }
106
107 # win32 is fucked up, of course. exit will clean stuff up,
108 # which destroys our database etc. _exit will exit ALL
109 # forked processes, because of the dreaded fork emulation.
110 DC::_exit 0;
111 }
112
113 close $fh_w;
114
115 my $buffer;
116
117 my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
118 unless (sysread $fh_r, $buffer, 4096, length $buffer) {
119 undef $w;
120 $cb->();
121 return;
122 }
123
124 while ($buffer =~ s/^(.*)\n//) {
125 my $line = $1;
126 $line =~ s/\s+$//;
127 utf8::decode $line;
128 if ($line =~ /^\x{e877}json_msg (.*)$/s) {
129 $cb->(JSON::XS->new->allow_nonref->decode ($1));
130 } else {
131 ::message ({
132 markup => "background($pid): " . DC::asxml $line,
133 });
134 }
135 }
89 }); 136 });
90
91 $db->db_put ($key => $data)
92} 137}
93 138
139sub background_msg {
140 my ($msg) = @_;
141
142 $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
143 $msg =~ s/\n//g;
144 utf8::encode $msg;
145 print $msg, "\n";
146}
147
94package 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}
95 157
96sub find_rcfile($) { 158sub find_rcfile($) {
97 my $path; 159 my $path;
98 160
99 for (grep !ref, @INC) { 161 for (@RC_THEME) {
100 $path = "$_/CFPlus/resources/$_[0]"; 162 $path = "$RC_BASE/$_/$_[0]";
101 return $path if -r $path; 163 return $path if -r $path;
102 } 164 }
103 165
104 die "FATAL: can't find required file $_[0]\n"; 166 die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\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} 167}
112 168
113sub read_cfg { 169sub read_cfg {
114 my ($file) = @_; 170 my ($file) = @_;
115 171
117 or return; 173 or return;
118 174
119 local $/; 175 local $/;
120 my $CFG = <$fh>; 176 my $CFG = <$fh>;
121 177
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; 178 $::CFG = decode_json $CFG;
128 } else {
129 $::CFG = eval $CFG; ## todo comaptibility cruft
130 }
131} 179}
132 180
133sub write_cfg { 181sub write_cfg {
134 my ($file) = @_; 182 my $file = "$Deliantra::VARDIR/client.cf";
135 183
136 $::CFG->{VERSION} = $::VERSION; 184 $::CFG->{VERSION} = $::VERSION;
137 185
138 open my $fh, ">:utf8", $file 186 open my $fh, ">:utf8", $file
139 or return; 187 or return;
140 print $fh to_json $::CFG; 188 print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
141} 189}
142 190
143sub http_proxy { 191sub http_proxy {
144 my @proxy = win32_proxy_info; 192 my @proxy = win32_proxy_info;
145 193
157 or return; 205 or return;
158 206
159 $ENV{http_proxy} = $proxy; 207 $ENV{http_proxy} = $proxy;
160} 208}
161 209
162our $DB_ENV; 210sub lwp_useragent {
163our $DB_STATE; 211 require LWP::UserAgent;
212
213 DC::set_proxy;
164 214
165sub db_table($) { 215 my $ua = LWP::UserAgent->new (
216 agent => "deliantra $VERSION",
217 keep_alive => 1,
218 env_proxy => 1,
219 timeout => 30,
220 );
221}
222
223sub lwp_check($) {
166 my ($table) = @_; 224 my ($res) = @_;
167 225
168 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 226 $res->is_error
227 and die $res->status_line;
169 228
170 new CFPlus::Database 229 $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} 230}
179 231
180{ 232sub fh_nonblocking($$) {
181 use strict; 233 my ($fh, $nb) = @_;
182 234
183 mkdir "$Crossfire::VARDIR/cfplus", 0777; 235 if ($^O eq "MSWin32") {
184 my $recover = $BerkeleyDB::db_version >= 4.4 236 $nb = (! ! $nb) + 0;
185 ? eval "DB_REGISTER | DB_RECOVER" 237 ioctl $fh, 0x8004667e, \$nb; # FIONBIO
186 : 0; 238 } else {
187 239 fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
188 $DB_ENV = new BerkeleyDB::Env 240 }
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} 241}
200 242
201package CFPlus::Layout; 243package DC::Layout;
202 244
203$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { 245$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
204 reset_glyph_cache; 246 glyph_cache_restore;
205}; 247};
206 248
207package CFPlus::Item; 249$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
208 250 glyph_cache_backup;
209use strict; 251};
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 252
4181; 2531;
419 254
420=back 255=back
421 256

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines