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.114 by elmex, Mon Aug 14 04:34:40 2006 UTC vs.
Revision 1.172 by root, Sun Jan 13 08:47:00 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.2'; 20 $VERSION = '0.9964';
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 $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync }); 81 my $pid = fork;
75 82
76 $db->db_put ($key => $data) 83 if (defined $pid && !$pid) {
77} 84 local $SIG{__DIE__};
78 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 }
131 });
132}
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
79package CFPlus; 143package DC;
80 144
81sub find_rcfile($) { 145sub find_rcfile($) {
82 my $path; 146 my $path;
83 147
84 for (grep !ref, @INC) { 148 for (grep !ref, @INC) {
85 $path = "$_/CFPlus/resources/$_[0]"; 149 $path = "$_/Deliantra/Client/private/resources/$_[0]";
86 return $path if -r $path; 150 return $path if -r $path;
87 } 151 }
88 152
89 die "FATAL: can't find required file $_[0]\n"; 153 die "FATAL: can't find required file $_[0]\n";
90}
91
92BEGIN {
93 use Crossfire::Protocol::Base ();
94 *to_json = \&Crossfire::Protocol::Base::to_json;
95 *from_json = \&Crossfire::Protocol::Base::from_json;
96} 154}
97 155
98sub read_cfg { 156sub read_cfg {
99 my ($file) = @_; 157 my ($file) = @_;
100 158
102 or return; 160 or return;
103 161
104 local $/; 162 local $/;
105 my $CFG = <$fh>; 163 my $CFG = <$fh>;
106 164
107 if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove
108 require YAML;
109 utf8::decode $CFG;
110 $::CFG = YAML::Load ($CFG);
111 } elsif ($CFG =~ /^\{/) {
112 $::CFG = from_json $CFG; 165 $::CFG = decode_json $CFG;
113 } else {
114 $::CFG = eval $CFG; ## todo comaptibility cruft
115 }
116} 166}
117 167
118sub write_cfg { 168sub write_cfg {
119 my ($file) = @_; 169 my ($file) = @_;
120 170
121 $::CFG->{VERSION} = $::VERSION; 171 $::CFG->{VERSION} = $::VERSION;
122 172
123 open my $fh, ">:utf8", $file 173 open my $fh, ">:utf8", $file
124 or return; 174 or return;
125 print $fh to_json $::CFG; 175 print $fh encode_json $::CFG;
126} 176}
127 177
128our $DB_ENV; 178sub http_proxy {
179 my @proxy = win32_proxy_info;
129 180
130{ 181 if (@proxy) {
131 use strict; 182 "http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
132 183 } elsif (exists $ENV{http_proxy}) {
133 mkdir "$Crossfire::VARDIR/cfplus", 0777; 184 $ENV{http_proxy}
134 my $recover = $BerkeleyDB::db_version >= 4.4 185 } else {
135 ? eval "DB_REGISTER | DB_RECOVER" 186 ()
136 : 0; 187 }
137
138 $DB_ENV = new BerkeleyDB::Env
139 -Home => "$Crossfire::VARDIR/cfplus",
140 -Cachesize => 1_000_000,
141 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
142# -ErrPrefix => "DATABASE",
143 -Verbose => 1,
144 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover,
145 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
146 or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
147} 188}
148 189
149sub 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($) {
150 my ($table) = @_; 211 my ($res) = @_;
151 212
152 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 213 $res->is_error
214 and die $res->status_line;
153 215
154 new CFPlus::Database 216 $res
155 -Env => $DB_ENV,
156 -Filename => $table,
157# -Filename => "database",
158# -Subname => $table,
159 -Property => DB_CHKSUM,
160 -Flags => DB_CREATE | DB_UPGRADE,
161 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
162} 217}
163 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
164package CFPlus::Layout; 231package DC::Layout;
165 232
166$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { 233$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
167 reset_glyph_cache; 234 glyph_cache_restore;
168}; 235};
169 236
170package CFPlus::Item; 237$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
171 238 glyph_cache_backup;
172use strict; 239};
173use Crossfire::Protocol::Constants;
174
175my $last_enter_count = 1;
176
177sub desc_string {
178 my ($self) = @_;
179
180 my $desc =
181 $self->{nrof} < 2
182 ? $self->{name}
183 : "$self->{nrof} × $self->{name_pl}";
184
185 $self->{flags} & F_OPEN
186 and $desc .= " (open)";
187 $self->{flags} & F_APPLIED
188 and $desc .= " (applied)";
189 $self->{flags} & F_UNPAID
190 and $desc .= " (unpaid)";
191 $self->{flags} & F_MAGIC
192 and $desc .= " (magic)";
193 $self->{flags} & F_CURSED
194 and $desc .= " (cursed)";
195 $self->{flags} & F_DAMNED
196 and $desc .= " (damned)";
197 $self->{flags} & F_LOCKED
198 and $desc .= " *";
199
200 $desc
201}
202
203sub weight_string {
204 my ($self) = @_;
205
206 my $weight = ($self->{nrof} || 1) * $self->{weight};
207
208 $weight < 0 ? "?" : $weight * 0.001
209}
210
211sub do_n_dialog {
212 my ($cb) = @_;
213
214 my $w = new CFPlus::UI::Toplevel
215 on_delete => sub { $_[0]->destroy; 1 },
216 has_close_button => 1,
217 ;
218
219 $w->add (my $vb = new CFPlus::UI::VBox x => "center", y => "center");
220 $vb->add (new CFPlus::UI::Label text => "Enter item count:");
221 $vb->add (my $entry = new CFPlus::UI::Entry
222 text => $last_enter_count,
223 on_activate => sub {
224 my ($entry) = @_;
225 $last_enter_count = $entry->get_text;
226 $cb->($last_enter_count);
227 $w->hide;
228 $w->destroy;
229
230 0
231 },
232 on_escape => sub { $w->destroy; 1 },
233 );
234 $entry->grab_focus;
235 $w->show;
236}
237
238sub update_widgets {
239 my ($self) = @_;
240
241 # necessary to avoid cyclic references
242 Scalar::Util::weaken $self;
243
244 my $button_cb = sub {
245 my (undef, $ev, $x, $y) = @_;
246
247 my $targ = $::CONN->{player}{tag};
248
249 if ($self->{container} == $::CONN->{player}{tag}) {
250 $targ = $::CONN->{open_container};
251 }
252
253 if (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 1) {
254 $::CONN->send ("move $targ $self->{tag} 0")
255 if $targ || !($self->{flags} & F_LOCKED);
256 } elsif (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 2) {
257 $self->{flags} & F_LOCKED
258 ? $::CONN->send ("lock " . pack "CN", 0, $self->{tag})
259 : $::CONN->send ("lock " . pack "CN", 1, $self->{tag})
260 } elsif ($ev->{button} == 1) {
261 $::CONN->send ("examine $self->{tag}");
262 } elsif ($ev->{button} == 2) {
263 $::CONN->send ("apply $self->{tag}");
264 } elsif ($ev->{button} == 3) {
265 my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
266 if ($self->{container} == $::CONN->{open_container}) {
267 $move_prefix = "take";
268 }
269
270 my @menu_items = (
271 ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
272 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
273 ["ignite/thaw", # first try of an easier use of flint&steel
274 sub {
275 $::CONN->send ("mark ". pack "N", $self->{tag});
276 $::CONN->send ("command apply flint and steel");
277 }
278 ],
279 ["inscribe", # first try of an easier use of flint&steel
280 sub {
281 &::open_string_query ("Text to inscribe", sub {
282 my ($entry, $txt) = @_;
283 $::CONN->send ("mark ". pack "N", $self->{tag});
284 $::CONN->send ("command use_skill inscription $txt");
285 });
286 }
287 ],
288 ["rename", # first try of an easier use of flint&steel
289 sub {
290 &::open_string_query ("Rename item to:", sub {
291 my ($entry, $txt) = @_;
292 $::CONN->send ("mark ". pack "N", $self->{tag});
293 $::CONN->send ("command rename to <$txt>");
294 });
295 }
296 ],
297 ["apply", sub { $::CONN->send ("apply $self->{tag}") }],
298 (
299 $self->{flags} & F_LOCKED
300 ? (
301 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
302 )
303 : (
304 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
305 ["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }],
306 ["$move_prefix &lt;n&gt;",
307 sub {
308 do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
309 }
310 ]
311 )
312 ),
313 );
314
315 CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
316 }
317
318 1
319 };
320
321 my $tooltip_std = "<small>"
322 . "Left click - examine item\n"
323 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
324 . "Middle click - apply\n"
325 . "Shift-Middle click - lock/unlock\n"
326 . "Right click - further options"
327 . "</small>\n";
328
329 my $bg = $self->{flags} & F_CURSED ? [1 , 0 , 0, 0.5]
330 : $self->{flags} & F_MAGIC ? [0.2, 0.2, 1, 0.5]
331 : undef;
332
333 $self->{face_widget} ||= new CFPlus::UI::Face
334 can_events => 1,
335 can_hover => 1,
336 anim => $self->{anim},
337 animspeed => $self->{animspeed}, # TODO# must be set at creation time
338 on_button_down => $button_cb,
339 ;
340 $self->{face_widget}{bg} = $bg;
341 $self->{face_widget}{face} = $self->{face};
342 $self->{face_widget}{anim} = $self->{anim};
343 $self->{face_widget}{animspeed} = $self->{animspeed};
344 $self->{face_widget}->set_tooltip (
345 "<b>Face/Animation.</b>\n"
346 . "Item uses face #$self->{face}. "
347 . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
348 . "\n\n$tooltip_std"
349 );
350
351 $self->{desc_widget} ||= new CFPlus::UI::Label
352 can_events => 1,
353 can_hover => 1,
354 ellipsise => 2,
355 align => -1,
356 on_button_down => $button_cb,
357 ;
358 my $desc = CFPlus::Item::desc_string $self;
359 $self->{desc_widget}{bg} = $bg;
360 $self->{desc_widget}->set_text ($desc);
361 $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
362
363 $self->{weight_widget} ||= new CFPlus::UI::Label
364 can_events => 1,
365 can_hover => 1,
366 ellipsise => 0,
367 align => 0,
368 on_button_down => $button_cb,
369 ;
370 $self->{weight_widget}{bg} = $bg;
371 $self->{weight_widget}->set_text (CFPlus::Item::weight_string $self);
372 $self->{weight_widget}->set_tooltip (
373 "<b>Weight</b>.\n"
374 . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
375 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
376 . "\n\n$tooltip_std"
377 );
378}
379 240
3801; 2411;
381 242
382=back 243=back
383 244

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines