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.126 by root, Tue Nov 7 22:41:27 2006 UTC vs.
Revision 1.198 by root, Fri Dec 12 15:06: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
19our $VERSION;
20
19BEGIN { 21BEGIN {
20 $VERSION = '0.95'; 22 $VERSION = '2.01';
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;
29use strict qw(vars subs);
36 30
37use AnyEvent (); 31use AnyEvent ();
38use BerkeleyDB;
39use Pod::POM (); 32use Pod::POM ();
40use Scalar::Util (); 33use File::Path ();
41use Storable (); # finally 34use Storable (); # finally
35use Fcntl ();
36use JSON::XS qw(encode_json decode_json);
42 37
43=item guard { BLOCK } 38=item guard { BLOCK }
44 39
45Returns an object that executes the given block as soon as it is destroyed. 40Returns an object that executes the given block as soon as it is destroyed.
46 41
47=cut 42=cut
48 43
49sub guard(&) { 44sub guard(&) {
50 bless \(my $cb = $_[0]), "CFPlus::Guard" 45 bless \(my $cb = $_[0]), "DC::Guard"
51} 46}
52 47
53sub CFPlus::Guard::DESTROY { 48sub DC::Guard::DESTROY {
54 ${$_[0]}->() 49 ${$_[0]}->()
50}
51
52=item shorten $string[, $maxlength]
53
54=cut
55
56sub shorten($;$) {
57 my ($str, $len) = @_;
58 substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
59 $str
55} 60}
56 61
57sub asxml($) { 62sub asxml($) {
58 local $_ = $_[0]; 63 local $_ = $_[0];
59 64
… …
63 68
64 $_ 69 $_
65} 70}
66 71
67sub socketpipe() { 72sub socketpipe() {
68 socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 73 socketpair my $fh1, my $fh2, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC
69 or die "cannot establish bidiretcional pipe: $!\n"; 74 or die "cannot establish bidirectional pipe: $!\n";
70 75
71 ($fh1, $fh2) 76 ($fh1, $fh2)
72} 77}
73 78
74sub background(&) { 79sub background(&;&) {
75 my ($cb) = @_; 80 my ($bg, $cb) = @_;
76 81
77 my ($fh_r, $fh_w) = CFPlus::socketpipe; 82 my ($fh_r, $fh_w) = DC::socketpipe;
78 83
79 my $pid = fork; 84 my $pid = fork;
80 85
81 if (defined $pid && !$pid) { 86 if (defined $pid && !$pid) {
82 local $SIG{__DIE__}; 87 local $SIG{__DIE__};
… …
86 close $fh_r; 91 close $fh_r;
87 close $fh_w; 92 close $fh_w;
88 93
89 $| = 1; 94 $| = 1;
90 95
91 eval { $cb->() }; 96 eval { $bg->() };
92 97
93 if ($@) { 98 if ($@) {
94 my $msg = $@; 99 my $msg = $@;
95 $msg =~ s/\n+/\n/; 100 $msg =~ s/\n+/\n/;
96 warn "FATAL: $msg"; 101 warn "FATAL: $msg";
97 CFPlus::_exit 1; 102 DC::_exit 1;
98 } 103 }
99 104
100 # win32 is fucked up, of course. exit will clean stuff up, 105 # win32 is fucked up, of course. exit will clean stuff up,
101 # which destroys our database etc. _exit will exit ALL 106 # which destroys our database etc. _exit will exit ALL
102 # forked processes, because of the dreaded fork emulation. 107 # forked processes, because of the dreaded fork emulation.
103 CFPlus::_exit 0; 108 DC::_exit 0;
104 } 109 }
105 110
106 close $fh_w; 111 close $fh_w;
107 112
108 my $buffer; 113 my $buffer;
109 114
110 my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub { 115 my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
111 unless (sysread $fh_r, $buffer, 4096, length $buffer) { 116 unless (sysread $fh_r, $buffer, 4096, length $buffer) {
112 undef $w; 117 undef $w;
113 $buffer .= "done\n"; 118 $cb->();
119 return;
114 } 120 }
115 121
116 while ($buffer =~ s/^(.*)\n//) { 122 while ($buffer =~ s/^(.*)\n//) {
117 my $line = $1; 123 my $line = $1;
118 $line =~ s/\s+$//; 124 $line =~ s/\s+$//;
119 utf8::decode $line; 125 utf8::decode $line;
126 if ($line =~ /^\x{e877}json_msg (.*)$/s) {
127 $cb->(JSON::XS->new->allow_nonref->decode ($1));
128 } else {
120 ::message ({ 129 ::message ({
121 markup => "editor($pid): " . CFPlus::asxml $line, 130 markup => "background($pid): " . DC::asxml $line,
131 });
122 }); 132 }
123 } 133 }
124 }); 134 });
125} 135}
126 136
127package CFPlus::Database; 137sub background_msg {
138 my ($msg) = @_;
128 139
129our @ISA = BerkeleyDB::Btree::; 140 $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
130 141 $msg =~ s/\n//g;
131sub get($$) { 142 utf8::encode $msg;
132 my $data; 143 print $msg, "\n";
133
134 $_[0]->db_get ($_[1], $data) == 0
135 ? $data
136 : ()
137} 144}
138 145
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; 146package DC;
147
148our $RC_THEME;
149our %THEME;
150our @RC_PATH;
151our $RC_BASE;
152
153for (grep !ref, @INC) {
154 $RC_BASE = "$_/Deliantra/Client/private/resources";
155 last if -d $RC_BASE;
156}
155 157
156sub find_rcfile($) { 158sub find_rcfile($) {
157 my $path; 159 my $path;
158 160
159 for (grep !ref, @INC) { 161 for (@RC_PATH, "") {
160 $path = "$_/CFPlus/resources/$_[0]"; 162 $path = "$RC_BASE/$_/$_[0]";
161 return $path if -r $path; 163 return $path if -r $path;
162 } 164 }
163 165
164 die "FATAL: can't find required file $_[0]\n"; 166 die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
165} 167}
166 168
167BEGIN { 169sub load_json($) {
168 use Crossfire::Protocol::Base (); 170 my ($file) = @_;
169 *to_json = \&Crossfire::Protocol::Base::to_json; 171
170 *from_json = \&Crossfire::Protocol::Base::from_json; 172 open my $fh, $file
173 or return;
174
175 local $/;
176 JSON::XS->new->utf8->relaxed->decode (<$fh>)
177}
178
179sub set_theme($) {
180 return if $RC_THEME eq $_[0];
181 $RC_THEME = $_[0];
182
183 # kind of hacky, find the main theme file, then load all theme files and merge them
184
185 %THEME = ();
186 @RC_PATH = "theme-$RC_THEME";
187
188 my $theme = load_json find_rcfile "theme.json"
189 or die "FATAL: theme resource file not found";
190
191 @RC_PATH = @{ $theme->{path} } if $theme->{path};
192
193 for (@RC_PATH, "") {
194 my $theme = load_json "$RC_BASE/$_/theme.json"
195 or next;
196
197 %THEME = ( %$theme, %THEME );
198 }
171} 199}
172 200
173sub read_cfg { 201sub read_cfg {
174 my ($file) = @_; 202 my ($file) = @_;
175 203
176 open my $fh, $file 204 $::CFG = load_json $file;
177 or return;
178
179 local $/;
180 my $CFG = <$fh>;
181
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;
188 } else {
189 $::CFG = eval $CFG; ## todo comaptibility cruft
190 }
191} 205}
192 206
193sub write_cfg { 207sub write_cfg {
194 my ($file) = @_; 208 my $file = "$Deliantra::VARDIR/client.cf";
195 209
196 $::CFG->{VERSION} = $::VERSION; 210 $::CFG->{VERSION} = $::VERSION;
197 211
198 open my $fh, ">:utf8", $file 212 open my $fh, ">:utf8", $file
199 or return; 213 or return;
200 print $fh to_json $::CFG; 214 print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
201} 215}
202 216
203sub http_proxy { 217sub http_proxy {
204 my @proxy = win32_proxy_info; 218 my @proxy = win32_proxy_info;
205 219
… …
217 or return; 231 or return;
218 232
219 $ENV{http_proxy} = $proxy; 233 $ENV{http_proxy} = $proxy;
220} 234}
221 235
222our $DB_ENV; 236sub lwp_useragent {
223our $DB_STATE; 237 require LWP::UserAgent;
238
239 DC::set_proxy;
224 240
225sub db_table($) { 241 my $ua = LWP::UserAgent->new (
242 agent => "deliantra $VERSION",
243 keep_alive => 1,
244 env_proxy => 1,
245 timeout => 30,
246 );
247}
248
249sub lwp_check($) {
226 my ($table) = @_; 250 my ($res) = @_;
227 251
228 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 252 $res->is_error
253 and die $res->status_line;
229 254
230 new CFPlus::Database 255 $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} 256}
239 257
240{ 258sub fh_nonblocking($$) {
241 use strict; 259 my ($fh, $nb) = @_;
242 260
243 mkdir "$Crossfire::VARDIR/cfplus", 0777; 261 if ($^O eq "MSWin32") {
244 my $recover = $BerkeleyDB::db_version >= 4.4 262 $nb = (! ! $nb) + 0;
245 ? eval "DB_REGISTER | DB_RECOVER" 263 ioctl $fh, 0x8004667e, \$nb; # FIONBIO
246 : 0; 264 } else {
247 265 fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
248 $DB_ENV = new BerkeleyDB::Env 266 }
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} 267}
260 268
261package CFPlus::Layout; 269package DC::Layout;
262 270
263$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { 271$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
264 reset_glyph_cache; 272 glyph_cache_restore;
265}; 273};
266 274
267package CFPlus::Item; 275$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
268 276 glyph_cache_backup;
269use strict; 277};
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 278
4781; 2791;
479 280
480=back 281=back
481 282

Diff Legend

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