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

Diff Legend

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