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.119 by root, Tue Sep 12 20:51:17 2006 UTC vs.
Revision 1.174 by root, Thu Mar 20 22:28:31 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
17use Carp ();
16 18
17BEGIN { 19BEGIN {
18 $VERSION = '0.51'; 20 $VERSION = '0.9966';
19 21
20 use XSLoader; 22 use XSLoader;
21 XSLoader::load "CFPlus", $VERSION; 23 XSLoader::load "Deliantra::Client", $VERSION;
22} 24}
23 25
24use utf8; 26use utf8;
25 27
26use Carp ();
27use AnyEvent (); 28use AnyEvent ();
28use BerkeleyDB;
29use Pod::POM (); 29use Pod::POM ();
30use Scalar::Util (); 30use File::Path ();
31use Storable (); # finally 31use Storable (); # finally
32use Fcntl ();
33use JSON::XS qw(encode_json decode_json);
32 34
33=item guard { BLOCK } 35=item guard { BLOCK }
34 36
35Returns an object that executes the given block as soon as it is destroyed. 37Returns an object that executes the given block as soon as it is destroyed.
36 38
37=cut 39=cut
38 40
39sub guard(&) { 41sub guard(&) {
40 bless \(my $cb = $_[0]), "CFPlus::Guard" 42 bless \(my $cb = $_[0]), "DC::Guard"
41} 43}
42 44
43sub CFPlus::Guard::DESTROY { 45sub DC::Guard::DESTROY {
44 ${$_[0]}->() 46 ${$_[0]}->()
47}
48
49=item shorten $string[, $maxlength]
50
51=cut
52
53sub shorten($;$) {
54 my ($str, $len) = @_;
55 substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
56 $str
45} 57}
46 58
47sub asxml($) { 59sub asxml($) {
48 local $_ = $_[0]; 60 local $_ = $_[0];
49 61
52 s/</&lt;/g; 64 s/</&lt;/g;
53 65
54 $_ 66 $_
55} 67}
56 68
57package CFPlus::Database; 69sub socketpipe() {
70 socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
71 or die "cannot establish bidirectional pipe: $!\n";
58 72
59our @ISA = BerkeleyDB::Btree::; 73 ($fh1, $fh2)
60
61sub get($$) {
62 my $data;
63
64 $_[0]->db_get ($_[1], $data) == 0
65 ? $data
66 : ()
67} 74}
68 75
69my %DB_SYNC; 76sub background(&;&) {
77 my ($bg, $cb) = @_;
70 78
71sub put($$$) { 79 my ($fh_r, $fh_w) = DC::socketpipe;
72 my ($db, $key, $data) = @_;
73 80
74 my $hkey = $db + 0; 81 my $pid = fork;
75 Scalar::Util::weaken $db; 82
76 $DB_SYNC{$hkey} ||= AnyEvent->timer (after => 5, cb => sub { 83 if (defined $pid && !$pid) {
77 delete $DB_SYNC{$hkey}; 84 local $SIG{__DIE__};
78 $db->db_sync if $db; 85
86 open STDOUT, ">&", $fh_w;
87 open STDERR, ">&", $fh_w;
88 close $fh_r;
89 close $fh_w;
90
91 $| = 1;
92
93 eval { $bg->() };
94
95 if ($@) {
96 my $msg = $@;
97 $msg =~ s/\n+/\n/;
98 warn "FATAL: $msg";
99 DC::_exit 1;
100 }
101
102 # win32 is fucked up, of course. exit will clean stuff up,
103 # which destroys our database etc. _exit will exit ALL
104 # forked processes, because of the dreaded fork emulation.
105 DC::_exit 0;
106 }
107
108 close $fh_w;
109
110 my $buffer;
111
112 my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
113 unless (sysread $fh_r, $buffer, 4096, length $buffer) {
114 undef $w;
115 $cb->();
116 return;
117 }
118
119 while ($buffer =~ s/^(.*)\n//) {
120 my $line = $1;
121 $line =~ s/\s+$//;
122 utf8::decode $line;
123 if ($line =~ /^\x{e877}json_msg (.*)$/s) {
124 $cb->(JSON::XS->new->allow_nonref->decode ($1));
125 } else {
126 ::message ({
127 markup => "background($pid): " . DC::asxml $line,
128 });
129 }
130 }
79 }); 131 });
80
81 $db->db_put ($key => $data)
82} 132}
83 133
134sub background_msg {
135 my ($msg) = @_;
136
137 $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
138 $msg =~ s/\n//g;
139 utf8::encode $msg;
140 print $msg, "\n";
141}
142
84package CFPlus; 143package DC;
85 144
86sub find_rcfile($) { 145sub find_rcfile($) {
87 my $path; 146 my $path;
88 147
89 for (grep !ref, @INC) { 148 for (grep !ref, @INC) {
90 $path = "$_/CFPlus/resources/$_[0]"; 149 $path = "$_/Deliantra/Client/private/resources/$_[0]";
91 return $path if -r $path; 150 return $path if -r $path;
92 } 151 }
93 152
94 die "FATAL: can't find required file $_[0]\n"; 153 die "FATAL: can't find required file $_[0]\n";
95}
96
97BEGIN {
98 use Crossfire::Protocol::Base ();
99 *to_json = \&Crossfire::Protocol::Base::to_json;
100 *from_json = \&Crossfire::Protocol::Base::from_json;
101} 154}
102 155
103sub read_cfg { 156sub read_cfg {
104 my ($file) = @_; 157 my ($file) = @_;
105 158
107 or return; 160 or return;
108 161
109 local $/; 162 local $/;
110 my $CFG = <$fh>; 163 my $CFG = <$fh>;
111 164
112 if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove
113 require YAML;
114 utf8::decode $CFG;
115 $::CFG = YAML::Load ($CFG);
116 } elsif ($CFG =~ /^\{/) {
117 $::CFG = from_json $CFG; 165 $::CFG = decode_json $CFG;
118 } else {
119 $::CFG = eval $CFG; ## todo comaptibility cruft
120 }
121} 166}
122 167
123sub write_cfg { 168sub write_cfg {
124 my ($file) = @_; 169 my ($file) = @_;
125 170
126 $::CFG->{VERSION} = $::VERSION; 171 $::CFG->{VERSION} = $::VERSION;
127 172
128 open my $fh, ">:utf8", $file 173 open my $fh, ">:utf8", $file
129 or return; 174 or return;
130 print $fh to_json $::CFG; 175 print $fh encode_json $::CFG;
131} 176}
132 177
133our $DB_ENV; 178sub http_proxy {
179 my @proxy = win32_proxy_info;
134 180
135{ 181 if (@proxy) {
136 use strict; 182 "http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
137 183 } elsif (exists $ENV{http_proxy}) {
138 mkdir "$Crossfire::VARDIR/cfplus", 0777; 184 $ENV{http_proxy}
139 my $recover = $BerkeleyDB::db_version >= 4.4 185 } else {
140 ? eval "DB_REGISTER | DB_RECOVER" 186 ()
141 : 0; 187 }
142
143 $DB_ENV = new BerkeleyDB::Env
144 -Home => "$Crossfire::VARDIR/cfplus",
145 -Cachesize => 1_000_000,
146 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
147# -ErrPrefix => "DATABASE",
148 -Verbose => 1,
149 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover,
150 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
151 or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
152} 188}
153 189
154sub db_table($) { 190sub set_proxy {
191 my $proxy = http_proxy
192 or return;
193
194 $ENV{http_proxy} = $proxy;
195}
196
197sub lwp_useragent {
198 require LWP::UserAgent;
199
200 DC::set_proxy;
201
202 my $ua = LWP::UserAgent->new (
203 agent => "deliantra $VERSION",
204 keep_alive => 1,
205 env_proxy => 1,
206 timeout => 30,
207 );
208}
209
210sub lwp_check($) {
155 my ($table) = @_; 211 my ($res) = @_;
156 212
157 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 213 $res->is_error
214 and die $res->status_line;
158 215
159 new CFPlus::Database 216 $res
160 -Env => $DB_ENV,
161 -Filename => $table,
162# -Filename => "database",
163# -Subname => $table,
164 -Property => DB_CHKSUM,
165 -Flags => DB_CREATE | DB_UPGRADE,
166 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
167} 217}
168 218
219sub fh_nonblocking($$) {
220 my ($fh, $nb) = @_;
221
222 if ($^O eq "MSWin32") {
223 $nb = (! ! $nb) + 0;
224 ioctl $fh, 0x8004667e, \$nb; # FIONBIO
225 } else {
226 fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
227 }
228
229}
230
169package CFPlus::Layout; 231package DC::Layout;
170 232
171$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { 233$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
172 reset_glyph_cache; 234 glyph_cache_restore;
173}; 235};
174 236
175package CFPlus::Item; 237$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
176 238 glyph_cache_backup;
177use strict; 239};
178use Crossfire::Protocol::Constants;
179
180my $last_enter_count = 1;
181
182sub desc_string {
183 my ($self) = @_;
184
185 my $desc =
186 $self->{nrof} < 2
187 ? $self->{name}
188 : "$self->{nrof} × $self->{name_pl}";
189
190 $self->{flags} & F_OPEN
191 and $desc .= " (open)";
192 $self->{flags} & F_APPLIED
193 and $desc .= " (applied)";
194 $self->{flags} & F_UNPAID
195 and $desc .= " (unpaid)";
196 $self->{flags} & F_MAGIC
197 and $desc .= " (magic)";
198 $self->{flags} & F_CURSED
199 and $desc .= " (cursed)";
200 $self->{flags} & F_DAMNED
201 and $desc .= " (damned)";
202 $self->{flags} & F_LOCKED
203 and $desc .= " *";
204
205 $desc
206}
207
208sub weight_string {
209 my ($self) = @_;
210
211 my $weight = ($self->{nrof} || 1) * $self->{weight};
212
213 $weight < 0 ? "?" : $weight * 0.001
214}
215
216sub do_n_dialog {
217 my ($cb) = @_;
218
219 my $w = new CFPlus::UI::Toplevel
220 on_delete => sub { $_[0]->destroy; 1 },
221 has_close_button => 1,
222 ;
223
224 $w->add (my $vb = new CFPlus::UI::VBox x => "center", y => "center");
225 $vb->add (new CFPlus::UI::Label text => "Enter item count:");
226 $vb->add (my $entry = new CFPlus::UI::Entry
227 text => $last_enter_count,
228 on_activate => sub {
229 my ($entry) = @_;
230 $last_enter_count = $entry->get_text;
231 $cb->($last_enter_count);
232 $w->hide;
233 $w->destroy;
234
235 0
236 },
237 on_escape => sub { $w->destroy; 1 },
238 );
239 $entry->grab_focus;
240 $w->show;
241}
242
243sub update_widgets {
244 my ($self) = @_;
245
246 # necessary to avoid cyclic references
247 Scalar::Util::weaken $self;
248
249 my $button_cb = sub {
250 my (undef, $ev, $x, $y) = @_;
251
252 my $targ = $::CONN->{player}{tag};
253
254 if ($self->{container} == $::CONN->{player}{tag}) {
255 $targ = $::CONN->{open_container};
256 }
257
258 if (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 1) {
259 $::CONN->send ("move $targ $self->{tag} 0")
260 if $targ || !($self->{flags} & F_LOCKED);
261 } elsif (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 2) {
262 $self->{flags} & F_LOCKED
263 ? $::CONN->send ("lock " . pack "CN", 0, $self->{tag})
264 : $::CONN->send ("lock " . pack "CN", 1, $self->{tag})
265 } elsif ($ev->{button} == 1) {
266 $::CONN->send ("examine $self->{tag}");
267 } elsif ($ev->{button} == 2) {
268 $::CONN->send ("apply $self->{tag}");
269 } elsif ($ev->{button} == 3) {
270 my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
271 if ($self->{container} == $::CONN->{open_container}) {
272 $move_prefix = "take";
273 }
274
275 my @menu_items = (
276 ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
277 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
278 ["ignite/thaw", # first try of an easier use of flint&steel
279 sub {
280 $::CONN->send ("mark ". pack "N", $self->{tag});
281 $::CONN->send ("command apply flint and steel");
282 }
283 ],
284 ["inscribe", # first try of an easier use of flint&steel
285 sub {
286 &::open_string_query ("Text to inscribe", sub {
287 my ($entry, $txt) = @_;
288 $::CONN->send ("mark ". pack "N", $self->{tag});
289 $::CONN->send ("command use_skill inscription $txt");
290 });
291 }
292 ],
293 ["rename", # first try of an easier use of flint&steel
294 sub {
295 &::open_string_query ("Rename item to:", sub {
296 my ($entry, $txt) = @_;
297 $::CONN->send ("mark ". pack "N", $self->{tag});
298 $::CONN->send ("command rename to <$txt>");
299 }, $self->{name},
300 "If you input no name or erase the current custom name, the custom name will be unset");
301 }
302 ],
303 ["apply", sub { $::CONN->send ("apply $self->{tag}") }],
304 (
305 $self->{flags} & F_LOCKED
306 ? (
307 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
308 )
309 : (
310 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
311 ["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }],
312 ["$move_prefix &lt;n&gt;",
313 sub {
314 do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
315 }
316 ]
317 )
318 ),
319 );
320
321 CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
322 }
323
324 1
325 };
326
327 my $tooltip_std = "<small>"
328 . "Left click - examine item\n"
329 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
330 . "Middle click - apply\n"
331 . "Shift-Middle click - lock/unlock\n"
332 . "Right click - further options"
333 . "</small>\n";
334
335 my $bg = $self->{flags} & F_CURSED ? [1 , 0 , 0, 0.5]
336 : $self->{flags} & F_MAGIC ? [0.2, 0.2, 1, 0.5]
337 : undef;
338
339 $self->{face_widget} ||= new CFPlus::UI::Face
340 can_events => 1,
341 can_hover => 1,
342 anim => $self->{anim},
343 animspeed => $self->{animspeed}, # TODO# must be set at creation time
344 on_button_down => $button_cb,
345 ;
346 $self->{face_widget}{bg} = $bg;
347 $self->{face_widget}{face} = $self->{face};
348 $self->{face_widget}{anim} = $self->{anim};
349 $self->{face_widget}{animspeed} = $self->{animspeed};
350 $self->{face_widget}->set_tooltip (
351 "<b>Face/Animation.</b>\n"
352 . "Item uses face #$self->{face}. "
353 . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
354 . "\n\n$tooltip_std"
355 );
356
357 $self->{desc_widget} ||= new CFPlus::UI::Label
358 can_events => 1,
359 can_hover => 1,
360 ellipsise => 2,
361 align => -1,
362 on_button_down => $button_cb,
363 ;
364 my $desc = CFPlus::Item::desc_string $self;
365 $self->{desc_widget}{bg} = $bg;
366 $self->{desc_widget}->set_text ($desc);
367 $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
368
369 $self->{weight_widget} ||= new CFPlus::UI::Label
370 can_events => 1,
371 can_hover => 1,
372 ellipsise => 0,
373 align => 0,
374 on_button_down => $button_cb,
375 ;
376 $self->{weight_widget}{bg} = $bg;
377 $self->{weight_widget}->set_text (CFPlus::Item::weight_string $self);
378 $self->{weight_widget}->set_tooltip (
379 "<b>Weight</b>.\n"
380 . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
381 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
382 . "\n\n$tooltip_std"
383 );
384}
385 240
3861; 2411;
387 242
388=back 243=back
389 244

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines