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.118 by root, Tue Sep 12 20:48:17 2006 UTC vs.
Revision 1.136 by root, Sat Dec 9 02:21:24 2006 UTC

12 12
13=cut 13=cut
14 14
15package CFPlus; 15package CFPlus;
16 16
17use Carp ();
18
17BEGIN { 19BEGIN {
18 $VERSION = '0.5'; 20 $VERSION = '0.97';
19 21
20 use XSLoader; 22 use XSLoader;
21 XSLoader::load "CFPlus", $VERSION; 23 XSLoader::load "CFPlus", $VERSION;
22} 24}
23 25
24use utf8; 26use utf8;
25 27
26use Carp ();
27use AnyEvent (); 28use AnyEvent ();
28use BerkeleyDB; 29use BerkeleyDB;
29use Pod::POM (); 30use Pod::POM ();
30use Scalar::Util (); 31use Scalar::Util ();
32use File::Path ();
31use Storable (); # finally 33use Storable (); # finally
34
35BEGIN {
36 use Crossfire::Protocol::Base ();
37 *to_json = \&Crossfire::Protocol::Base::to_json;
38 *from_json = \&Crossfire::Protocol::Base::from_json;
39}
32 40
33=item guard { BLOCK } 41=item guard { BLOCK }
34 42
35Returns an object that executes the given block as soon as it is destroyed. 43Returns an object that executes the given block as soon as it is destroyed.
36 44
40 bless \(my $cb = $_[0]), "CFPlus::Guard" 48 bless \(my $cb = $_[0]), "CFPlus::Guard"
41} 49}
42 50
43sub CFPlus::Guard::DESTROY { 51sub CFPlus::Guard::DESTROY {
44 ${$_[0]}->() 52 ${$_[0]}->()
53}
54
55=item shorten $string[, $maxlength]
56
57=cut
58
59sub shorten($;$) {
60 my ($str, $len) = @_;
61 substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
62 $str
45} 63}
46 64
47sub asxml($) { 65sub asxml($) {
48 local $_ = $_[0]; 66 local $_ = $_[0];
49 67
50 s/&/&amp;/g; 68 s/&/&amp;/g;
51 s/>/&gt;/g; 69 s/>/&gt;/g;
52 s/</&lt;/g; 70 s/</&lt;/g;
53 71
54 $_ 72 $_
73}
74
75sub socketpipe() {
76 socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
77 or die "cannot establish bidiretcional pipe: $!\n";
78
79 ($fh1, $fh2)
80}
81
82sub background(&;&) {
83 my ($bg, $cb) = @_;
84
85 my ($fh_r, $fh_w) = CFPlus::socketpipe;
86
87 my $pid = fork;
88
89 if (defined $pid && !$pid) {
90 local $SIG{__DIE__};
91
92 open STDOUT, ">&", $fh_w;
93 open STDERR, ">&", $fh_w;
94 close $fh_r;
95 close $fh_w;
96
97 $| = 1;
98
99 eval { $bg->() };
100
101 if ($@) {
102 my $msg = $@;
103 $msg =~ s/\n+/\n/;
104 warn "FATAL: $msg";
105 CFPlus::_exit 1;
106 }
107
108 # win32 is fucked up, of course. exit will clean stuff up,
109 # which destroys our database etc. _exit will exit ALL
110 # forked processes, because of the dreaded fork emulation.
111 CFPlus::_exit 0;
112 }
113
114 close $fh_w;
115
116 my $buffer;
117
118 my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
119 unless (sysread $fh_r, $buffer, 4096, length $buffer) {
120 undef $w;
121 $cb->();
122 return;
123 }
124
125 while ($buffer =~ s/^(.*)\n//) {
126 my $line = $1;
127 $line =~ s/\s+$//;
128 utf8::decode $line;
129 if ($line =~ /^\x{e877}json_msg (.*)$/s) {
130 $cb->(from_json $1);
131 } else {
132 ::message ({
133 markup => "background($pid): " . CFPlus::asxml $line,
134 });
135 }
136 }
137 });
138}
139
140sub background_msg {
141 my ($msg) = @_;
142
143 $msg = "\x{e877}json_msg " . to_json $msg;
144 $msg =~ s/\n//g;
145 utf8::encode $msg;
146 print $msg, "\n";
55} 147}
56 148
57package CFPlus::Database; 149package CFPlus::Database;
58 150
59our @ISA = BerkeleyDB::Btree::; 151our @ISA = BerkeleyDB::Btree::;
90 $path = "$_/CFPlus/resources/$_[0]"; 182 $path = "$_/CFPlus/resources/$_[0]";
91 return $path if -r $path; 183 return $path if -r $path;
92 } 184 }
93 185
94 die "FATAL: can't find required file $_[0]\n"; 186 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} 187}
102 188
103sub read_cfg { 189sub read_cfg {
104 my ($file) = @_; 190 my ($file) = @_;
105 191
128 open my $fh, ">:utf8", $file 214 open my $fh, ">:utf8", $file
129 or return; 215 or return;
130 print $fh to_json $::CFG; 216 print $fh to_json $::CFG;
131} 217}
132 218
219sub http_proxy {
220 my @proxy = win32_proxy_info;
221
222 if (@proxy) {
223 "http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
224 } elsif (exists $ENV{http_proxy}) {
225 $ENV{http_proxy}
226 } else {
227 ()
228 }
229}
230
231sub set_proxy {
232 my $proxy = http_proxy
233 or return;
234
235 $ENV{http_proxy} = $proxy;
236}
237
238sub lwp_useragent {
239 require LWP::UserAgent;
240
241 CFPlus::set_proxy;
242
243 my $ua = LWP::UserAgent->new (
244 agent => "cfplus $VERSION",
245 keep_alive => 1,
246 env_proxy => 1,
247 timeout => 30,
248 );
249}
250
251sub lwp_check($) {
252 my ($res) = @_;
253
254 $res->is_error
255 and die $res->status_line;
256
257 $res
258}
259
133our $DB_ENV; 260our $DB_ENV;
134 261our $DB_STATE;
135{
136 use strict;
137
138 mkdir "$Crossfire::VARDIR/cfplus", 0777;
139 my $recover = $BerkeleyDB::db_version >= 4.4
140 ? eval "DB_REGISTER | DB_RECOVER"
141 : 0;
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}
153 262
154sub db_table($) { 263sub db_table($) {
155 my ($table) = @_; 264 my ($table) = @_;
156 265
157 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 266 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
164 -Property => DB_CHKSUM, 273 -Property => DB_CHKSUM,
165 -Flags => DB_CREATE | DB_UPGRADE, 274 -Flags => DB_CREATE | DB_UPGRADE,
166 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error" 275 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
167} 276}
168 277
278our $DB_HOME = "$Crossfire::VARDIR/cfplus";
279
280sub open_db {
281 use strict;
282
283 mkdir $DB_HOME, 0777;
284 my $recover = $BerkeleyDB::db_version >= 4.4
285 ? eval "DB_REGISTER | DB_RECOVER"
286 : 0;
287
288 $DB_ENV = new BerkeleyDB::Env
289 -Home => $DB_HOME,
290 -Cachesize => 1_000_000,
291 -ErrFile => "$DB_HOME/errorlog.txt",
292# -ErrPrefix => "DATABASE",
293 -Verbose => 1,
294 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover,
295 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
296 or die "unable to create/open database home $DB_HOME: $BerkeleyDB::Error";
297
298 $DB_STATE = db_table "state";
299
300 1
301}
302
303unless (eval { open_db }) {
304 File::Path::rmtree $DB_HOME;
305 open_db;
306}
307
169package CFPlus::Layout; 308package CFPlus::Layout;
170 309
171$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { 310$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {
172 reset_glyph_cache; 311 reset_glyph_cache;
173}; 312};
174 313
175package CFPlus::Item;
176
177use strict;
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
3861; 3141;
387 315
388=back 316=back
389 317
390=head1 AUTHOR 318=head1 AUTHOR

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines