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

Diff Legend

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