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.121 by root, Fri Sep 29 00:56:05 2006 UTC vs.
Revision 1.185 by root, Fri Aug 1 13:50:08 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.9974';
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
143our $DB_ENV; 180sub http_proxy {
144our $DB_STATE; 181 my @proxy = win32_proxy_info;
145 182
146sub db_table($) { 183 if (@proxy) {
184 "http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
185 } elsif (exists $ENV{http_proxy}) {
186 $ENV{http_proxy}
187 } else {
188 ()
189 }
190}
191
192sub set_proxy {
193 my $proxy = http_proxy
194 or return;
195
196 $ENV{http_proxy} = $proxy;
197}
198
199sub lwp_useragent {
200 require LWP::UserAgent;
201
202 DC::set_proxy;
203
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($) {
147 my ($table) = @_; 213 my ($res) = @_;
148 214
149 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 215 $res->is_error
216 and die $res->status_line;
150 217
151 new CFPlus::Database 218 $res
152 -Env => $DB_ENV,
153 -Filename => $table,
154# -Filename => "database",
155# -Subname => $table,
156 -Property => DB_CHKSUM,
157 -Flags => DB_CREATE | DB_UPGRADE,
158 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
159} 219}
160 220
161{ 221sub fh_nonblocking($$) {
162 use strict; 222 my ($fh, $nb) = @_;
163 223
164 mkdir "$Crossfire::VARDIR/cfplus", 0777; 224 if ($^O eq "MSWin32") {
165 my $recover = $BerkeleyDB::db_version >= 4.4 225 $nb = (! ! $nb) + 0;
166 ? eval "DB_REGISTER | DB_RECOVER" 226 ioctl $fh, 0x8004667e, \$nb; # FIONBIO
167 : 0; 227 } else {
168 228 fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
169 $DB_ENV = new BerkeleyDB::Env 229 }
170 -Home => "$Crossfire::VARDIR/cfplus",
171 -Cachesize => 1_000_000,
172 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
173# -ErrPrefix => "DATABASE",
174 -Verbose => 1,
175 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover,
176 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
177 or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
178
179 $DB_STATE = db_table "state";
180} 230}
181 231
182package CFPlus::Layout; 232package DC::Layout;
183 233
184$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { 234$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
185 reset_glyph_cache; 235 glyph_cache_restore;
186}; 236};
187 237
188package CFPlus::Item; 238$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
189 239 glyph_cache_backup;
190use strict; 240};
191use Crossfire::Protocol::Constants;
192
193my $last_enter_count = 1;
194
195sub desc_string {
196 my ($self) = @_;
197
198 my $desc =
199 $self->{nrof} < 2
200 ? $self->{name}
201 : "$self->{nrof} × $self->{name_pl}";
202
203 $self->{flags} & F_OPEN
204 and $desc .= " (open)";
205 $self->{flags} & F_APPLIED
206 and $desc .= " (applied)";
207 $self->{flags} & F_UNPAID
208 and $desc .= " (unpaid)";
209 $self->{flags} & F_MAGIC
210 and $desc .= " (magic)";
211 $self->{flags} & F_CURSED
212 and $desc .= " (cursed)";
213 $self->{flags} & F_DAMNED
214 and $desc .= " (damned)";
215 $self->{flags} & F_LOCKED
216 and $desc .= " *";
217
218 $desc
219}
220
221sub weight_string {
222 my ($self) = @_;
223
224 my $weight = ($self->{nrof} || 1) * $self->{weight};
225
226 $weight < 0 ? "?" : $weight * 0.001
227}
228
229sub do_n_dialog {
230 my ($cb) = @_;
231
232 my $w = new CFPlus::UI::Toplevel
233 on_delete => sub { $_[0]->destroy; 1 },
234 has_close_button => 1,
235 ;
236
237 $w->add (my $vb = new CFPlus::UI::VBox x => "center", y => "center");
238 $vb->add (new CFPlus::UI::Label text => "Enter item count:");
239 $vb->add (my $entry = new CFPlus::UI::Entry
240 text => $last_enter_count,
241 on_activate => sub {
242 my ($entry) = @_;
243 $last_enter_count = $entry->get_text;
244 $cb->($last_enter_count);
245 $w->hide;
246 $w->destroy;
247
248 0
249 },
250 on_escape => sub { $w->destroy; 1 },
251 );
252 $entry->grab_focus;
253 $w->show;
254}
255
256sub update_widgets {
257 my ($self) = @_;
258
259 # necessary to avoid cyclic references
260 Scalar::Util::weaken $self;
261
262 my $button_cb = sub {
263 my (undef, $ev, $x, $y) = @_;
264
265 my $targ = $::CONN->{player}{tag};
266
267 if ($self->{container} == $::CONN->{player}{tag}) {
268 $targ = $::CONN->{open_container};
269 }
270
271 if (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 1) {
272 $::CONN->send ("move $targ $self->{tag} 0")
273 if $targ || !($self->{flags} & F_LOCKED);
274 } elsif (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 2) {
275 $self->{flags} & F_LOCKED
276 ? $::CONN->send ("lock " . pack "CN", 0, $self->{tag})
277 : $::CONN->send ("lock " . pack "CN", 1, $self->{tag})
278 } elsif ($ev->{button} == 1) {
279 $::CONN->send ("examine $self->{tag}");
280 } elsif ($ev->{button} == 2) {
281 $::CONN->send ("apply $self->{tag}");
282 } elsif ($ev->{button} == 3) {
283 my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
284 if ($self->{container} == $::CONN->{open_container}) {
285 $move_prefix = "take";
286 }
287
288 my @menu_items = (
289 ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
290 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
291 ["ignite/thaw", # first try of an easier use of flint&steel
292 sub {
293 $::CONN->send ("mark ". pack "N", $self->{tag});
294 $::CONN->send ("command apply flint and steel");
295 }
296 ],
297 ["inscribe", # first try of an easier use of flint&steel
298 sub {
299 &::open_string_query ("Text to inscribe", sub {
300 my ($entry, $txt) = @_;
301 $::CONN->send ("mark ". pack "N", $self->{tag});
302 $::CONN->send ("command use_skill inscription $txt");
303 });
304 }
305 ],
306 ["rename", # first try of an easier use of flint&steel
307 sub {
308 &::open_string_query ("Rename item to:", sub {
309 my ($entry, $txt) = @_;
310 $::CONN->send ("mark ". pack "N", $self->{tag});
311 $::CONN->send ("command rename to <$txt>");
312 }, $self->{name},
313 "If you input no name or erase the current custom name, the custom name will be unset");
314 }
315 ],
316 ["apply", sub { $::CONN->send ("apply $self->{tag}") }],
317 (
318 $self->{flags} & F_LOCKED
319 ? (
320 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
321 )
322 : (
323 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
324 ["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }],
325 ["$move_prefix &lt;n&gt;",
326 sub {
327 do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
328 }
329 ]
330 )
331 ),
332 );
333
334 CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
335 }
336
337 1
338 };
339
340 my $tooltip_std = "<small>"
341 . "Left click - examine item\n"
342 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
343 . "Middle click - apply\n"
344 . "Shift-Middle click - lock/unlock\n"
345 . "Right click - further options"
346 . "</small>\n";
347
348 my $bg = $self->{flags} & F_CURSED ? [1 , 0 , 0, 0.5]
349 : $self->{flags} & F_MAGIC ? [0.2, 0.2, 1, 0.5]
350 : undef;
351
352 $self->{face_widget} ||= new CFPlus::UI::Face
353 can_events => 1,
354 can_hover => 1,
355 anim => $self->{anim},
356 animspeed => $self->{animspeed}, # TODO# must be set at creation time
357 on_button_down => $button_cb,
358 ;
359 $self->{face_widget}{bg} = $bg;
360 $self->{face_widget}{face} = $self->{face};
361 $self->{face_widget}{anim} = $self->{anim};
362 $self->{face_widget}{animspeed} = $self->{animspeed};
363 $self->{face_widget}->set_tooltip (
364 "<b>Face/Animation.</b>\n"
365 . "Item uses face #$self->{face}. "
366 . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
367 . "\n\n$tooltip_std"
368 );
369
370 $self->{desc_widget} ||= new CFPlus::UI::Label
371 can_events => 1,
372 can_hover => 1,
373 ellipsise => 2,
374 align => -1,
375 on_button_down => $button_cb,
376 ;
377 my $desc = CFPlus::Item::desc_string $self;
378 $self->{desc_widget}{bg} = $bg;
379 $self->{desc_widget}->set_text ($desc);
380 $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
381
382 $self->{weight_widget} ||= new CFPlus::UI::Label
383 can_events => 1,
384 can_hover => 1,
385 ellipsise => 0,
386 align => 0,
387 on_button_down => $button_cb,
388 ;
389 $self->{weight_widget}{bg} = $bg;
390 $self->{weight_widget}->set_text (CFPlus::Item::weight_string $self);
391 $self->{weight_widget}->set_tooltip (
392 "<b>Weight</b>.\n"
393 . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
394 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
395 . "\n\n$tooltip_std"
396 );
397}
398 241
3991; 2421;
400 243
401=back 244=back
402 245

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines