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.112 by root, Sun Aug 13 03:20:53 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;
18
19use Carp ();
16 20
17BEGIN { 21BEGIN {
18 $VERSION = '0.2'; 22 $VERSION = '0.9974';
19 23
20 use XSLoader; 24 use XSLoader;
21 XSLoader::load "CFPlus", $VERSION; 25 XSLoader::load "Deliantra::Client", $VERSION;
22} 26}
23 27
24use utf8; 28use utf8;
25 29
26use Carp ();
27use AnyEvent (); 30use AnyEvent ();
28use BerkeleyDB;
29use Pod::POM (); 31use Pod::POM ();
30use Scalar::Util (); 32use File::Path ();
31use Storable (); # finally 33use Storable (); # finally
34use Fcntl ();
35use JSON::XS qw(encode_json decode_json);
32 36
33=item guard { BLOCK } 37=item guard { BLOCK }
34 38
35Returns 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.
36 40
37=cut 41=cut
38 42
39sub guard(&) { 43sub guard(&) {
40 bless \(my $cb = $_[0]), "CFPlus::Guard" 44 bless \(my $cb = $_[0]), "DC::Guard"
41} 45}
42 46
43sub CFPlus::Guard::DESTROY { 47sub DC::Guard::DESTROY {
44 ${$_[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
45} 59}
46 60
47sub asxml($) { 61sub asxml($) {
48 local $_ = $_[0]; 62 local $_ = $_[0];
49 63
52 s/</&lt;/g; 66 s/</&lt;/g;
53 67
54 $_ 68 $_
55} 69}
56 70
57package 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";
58 74
59our @ISA = BerkeleyDB::Btree::; 75 ($fh1, $fh2)
60
61sub get($$) {
62 my $data;
63
64 $_[0]->db_get ($_[1], $data) == 0
65 ? $data
66 : ()
67} 76}
68 77
69my %DB_SYNC; 78sub background(&;&) {
79 my ($bg, $cb) = @_;
70 80
71sub put($$$) { 81 my ($fh_r, $fh_w) = DC::socketpipe;
72 my ($db, $key, $data) = @_;
73 82
74 $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync }); 83 my $pid = fork;
75 84
76 $db->db_put ($key => $data) 85 if (defined $pid && !$pid) {
77} 86 local $SIG{__DIE__};
78 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 }
133 });
134}
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
79package CFPlus; 145package DC;
80 146
81sub find_rcfile($) { 147sub find_rcfile($) {
82 my $path; 148 my $path;
83 149
84 for (grep !ref, @INC) { 150 for (grep !ref, @INC) {
85 $path = "$_/CFPlus/resources/$_[0]"; 151 $path = "$_/Deliantra/Client/private/resources/$_[0]";
86 return $path if -r $path; 152 return $path if -r $path;
87 } 153 }
88 154
89 die "FATAL: can't find required file $_[0]\n"; 155 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} 156}
97 157
98sub read_cfg { 158sub read_cfg {
99 my ($file) = @_; 159 my ($file) = @_;
100 160
102 or return; 162 or return;
103 163
104 local $/; 164 local $/;
105 my $CFG = <$fh>; 165 my $CFG = <$fh>;
106 166
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; 167 $::CFG = decode_json $CFG;
113 } else {
114 $::CFG = eval $CFG; ## todo comaptibility cruft
115 }
116} 168}
117 169
118sub write_cfg { 170sub write_cfg {
119 my ($file) = @_; 171 my $file = "$Deliantra::VARDIR/client.cf";
120 172
121 $::CFG->{VERSION} = $::VERSION; 173 $::CFG->{VERSION} = $::VERSION;
122 174
123 open my $fh, ">:utf8", $file 175 open my $fh, ">:utf8", $file
124 or return; 176 or return;
125 print $fh to_json $::CFG; 177 print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
126} 178}
127 179
128our $DB_ENV; 180sub http_proxy {
181 my @proxy = win32_proxy_info;
129 182
130{ 183 if (@proxy) {
131 use strict; 184 "http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
132 185 } elsif (exists $ENV{http_proxy}) {
133 mkdir "$Crossfire::VARDIR/cfplus", 0777; 186 $ENV{http_proxy}
134 my $recover = $BerkeleyDB::db_version >= 4.4 187 } else {
135 ? eval "DB_REGISTER | DB_RECOVER" 188 ()
136 : 0; 189 }
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} 190}
148 191
149sub db_table($) { 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($) {
150 my ($table) = @_; 213 my ($res) = @_;
151 214
152 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 215 $res->is_error
216 and die $res->status_line;
153 217
154 new CFPlus::Database 218 $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} 219}
163 220
221sub fh_nonblocking($$) {
222 my ($fh, $nb) = @_;
223
224 if ($^O eq "MSWin32") {
225 $nb = (! ! $nb) + 0;
226 ioctl $fh, 0x8004667e, \$nb; # FIONBIO
227 } else {
228 fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
229 }
230}
231
164package CFPlus::Layout; 232package DC::Layout;
165 233
166$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { 234$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
167 reset_glyph_cache; 235 glyph_cache_restore;
168}; 236};
169 237
170package CFPlus::Item; 238$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
171 239 glyph_cache_backup;
172use strict; 240};
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::FancyFrame
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 ["apply", sub { $::CONN->send ("apply $self->{tag}") }],
289 (
290 $self->{flags} & F_LOCKED
291 ? (
292 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
293 )
294 : (
295 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
296 ["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }],
297 ["$move_prefix &lt;n&gt;",
298 sub {
299 do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
300 }
301 ]
302 )
303 ),
304 );
305
306 CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
307 }
308
309 1
310 };
311
312 my $tooltip_std = "<small>"
313 . "Left click - examine item\n"
314 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
315 . "Middle click - apply\n"
316 . "Shift-Middle click - lock/unlock\n"
317 . "Right click - further options"
318 . "</small>\n";
319
320 my $bg = $self->{flags} & F_CURSED ? [1 , 0 , 0, 0.5]
321 : $self->{flags} & F_MAGIC ? [0.2, 0.2, 1, 0.5]
322 : undef;
323
324 $self->{face_widget} ||= new CFPlus::UI::Face
325 can_events => 1,
326 can_hover => 1,
327 anim => $self->{anim},
328 animspeed => $self->{animspeed}, # TODO# must be set at creation time
329 on_button_down => $button_cb,
330 ;
331 $self->{face_widget}{bg} = $bg;
332 $self->{face_widget}{face} = $self->{face};
333 $self->{face_widget}{anim} = $self->{anim};
334 $self->{face_widget}{animspeed} = $self->{animspeed};
335 $self->{face_widget}->set_tooltip (
336 "<b>Face/Animation.</b>\n"
337 . "Item uses face #$self->{face}. "
338 . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
339 . "\n\n$tooltip_std"
340 );
341
342 $self->{desc_widget} ||= new CFPlus::UI::Label
343 can_events => 1,
344 can_hover => 1,
345 ellipsise => 2,
346 align => -1,
347 on_button_down => $button_cb,
348 ;
349 my $desc = CFPlus::Item::desc_string $self;
350 $self->{desc_widget}{bg} = $bg;
351 $self->{desc_widget}->set_text ($desc);
352 $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
353
354 $self->{weight_widget} ||= new CFPlus::UI::Label
355 can_events => 1,
356 can_hover => 1,
357 ellipsise => 0,
358 align => 0,
359 on_button_down => $button_cb,
360 ;
361 $self->{weight_widget}{bg} = $bg;
362 $self->{weight_widget}->set_text (CFPlus::Item::weight_string $self);
363 $self->{weight_widget}->set_tooltip (
364 "<b>Weight</b>.\n"
365 . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
366 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
367 . "\n\n$tooltip_std"
368 );
369}
370 241
3711; 2421;
372 243
373=back 244=back
374 245

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines