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.82 by root, Wed May 31 07:13:50 2006 UTC vs.
Revision 1.215 by root, Wed Jan 18 13:42:19 2012 UTC

1=head1 NAME 1=head1 NAME
2 2
3CFClient - 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 CFClient; 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 CFClient; 15package DC;
16
17use Carp ();
18
19our $VERSION;
16 20
17BEGIN { 21BEGIN {
18 $VERSION = '0.1'; 22 $VERSION = '3.0';
19 23
20 use XSLoader; 24 use XSLoader;
21 XSLoader::load "CFClient", $VERSION; 25 XSLoader::load "Deliantra::Client", $VERSION;
22} 26}
23 27
24use utf8; 28use utf8;
29use strict qw(vars subs);
25 30
26use Carp (); 31use Socket ();
27use AnyEvent (); 32use AnyEvent ();
28use BerkeleyDB; 33use AnyEvent::Util ();
34use Pod::POM ();
35use File::Path ();
36use Storable (); # finally
37use Fcntl ();
38use JSON::XS qw(encode_json decode_json);
39use Guard qw(guard);
40
41# modules to support other DC::* packages
42use List::Util ();
43use IO::AIO ();
44use Coro::AIO ();
45use AnyEvent::AIO ();
46
47use Deliantra::Protocol::Constants ();
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
57}
58
59sub asxml($) {
60 local $_ = $_[0];
61
62 s/&/&amp;/g;
63 s/>/&gt;/g;
64 s/</&lt;/g;
65
66 $_
67}
68
69sub background(&;&) {
70 my ($bg, $cb) = @_;
71
72 my ($fh_r, $fh_w) = AnyEvent::Util::portable_socketpair
73 or die "unable to create background socketpair: $!";
74
75 my $pid = fork;
76
77 if (defined $pid && !$pid) {
78 local $SIG{__DIE__};
79
80 open STDOUT, ">&", $fh_w;
81 open STDERR, ">&", $fh_w;
82 close $fh_r;
83 close $fh_w;
84
85 $| = 1;
86
87 eval { $bg->() };
88
89 if ($@) {
90 my $msg = $@;
91 $msg =~ s/\n+/\n/;
92 warn "FATAL: $msg";
93 DC::_exit 1;
94 }
95
96 # win32 is fucked up, of course. exit will clean stuff up,
97 # which destroys our database etc. _exit will exit ALL
98 # forked processes, because of the dreaded fork emulation.
99 DC::_exit 0;
100 }
101
102 close $fh_w;
103
104 my $buffer;
105
106 my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
107 unless (sysread $fh_r, $buffer, 4096, length $buffer) {
108 undef $w;
109 $cb->();
110 return;
111 }
112
113 while ($buffer =~ s/^(.*)\n//) {
114 my $line = $1;
115 $line =~ s/\s+$//;
116 utf8::decode $line;
117 if ($line =~ /^\x{e877}json_msg (.*)$/s) {
118 $cb->(JSON::XS->new->allow_nonref->decode ($1));
119 } else {
120 ::message ({
121 markup => "background($pid): " . DC::asxml $line,
122 });
123 }
124 }
125 });
126}
127
128sub background_msg {
129 my ($msg) = @_;
130
131 $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
132 $msg =~ s/\n//g;
133 utf8::encode $msg;
134 print $msg, "\n";
135}
136
137package DC;
138
139our $RC_THEME;
140our %THEME;
141our @RC_PATH;
142our $RC_BASE;
143
144for (grep !ref, @INC) {
145 $RC_BASE = "$_/Deliantra/Client/private/resources";
146 last if -d $RC_BASE;
147}
29 148
30sub find_rcfile($) { 149sub find_rcfile($) {
31 my $path; 150 my $path;
32 151
33 for (grep !ref, @INC) { 152 for (@RC_PATH, "") {
34 $path = "$_/CFClient/resources/$_[0]"; 153 $path = "$RC_BASE/$_/$_[0]";
35 return $path if -r $path; 154 return $path if -e $path;
36 } 155 }
37 156
38 die "FATAL: can't find required file $_[0]\n"; 157 die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
39} 158}
40 159
41sub read_cfg { 160sub load_json($) {
42 my ($file) = @_; 161 my ($file) = @_;
43 162
44 open CFG, $file 163 open my $fh, $file
45 or return; 164 or return;
46 165
47 my $CFG;
48
49 local $/; 166 local $/;
50 $CFG = eval <CFG>; 167 eval { JSON::XS->new->utf8->relaxed->decode (<$fh>) }
51
52 $::CFG = $CFG;
53
54 close CFG;
55} 168}
56 169
170sub set_theme($) {
171 return if $RC_THEME eq $_[0];
172 $RC_THEME = $_[0];
173
174 # kind of hacky, find the main theme file, then load all theme files and merge them
175
176 %THEME = ();
177 @RC_PATH = "theme-$RC_THEME";
178
179 my $theme = load_json find_rcfile "theme.json"
180 or die "FATAL: theme resource file not found";
181
182 @RC_PATH = @{ $theme->{path} } if $theme->{path};
183
184 for (@RC_PATH, "") {
185 my $theme = load_json "$RC_BASE/$_/theme.json"
186 or next;
187
188 %THEME = ( %$theme, %THEME );
189 }
190}
191
57sub write_cfg { 192sub read_cfg($) {
58 my ($file) = @_; 193 my ($file) = @_;
59 194
60 open CFG, ">$file" 195 $::CFG = (load_json $file) || (load_json "$file.bak");
196}
197
198sub write_cfg($) {
199 my $file = "$Deliantra::VARDIR/client.cf";
200
201 $::CFG->{VERSION} = $::VERSION;
202 $::CFG->{layout} = DC::UI::get_layout ();
203
204 open my $fh, ">:utf8", "$file~"
61 or return; 205 or return;
206 print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
207 close $fh;
62 208
209 rename $file, "$file.bak";
210 rename "$file~", $file;
211}
212
213sub load_cfg() {
214 if (-e "$Deliantra::VARDIR/client.cf") {
215 DC::read_cfg "$Deliantra::VARDIR/client.cf";
216 } else {
217 $::CFG = {};
218 }
219}
220
221sub save_cfg() {
222 write_cfg "$Deliantra::VARDIR/client.cf";
223}
224
225sub upgrade_cfg() {
226 my %DEF_CFG = (
227 config_autosave => 1,
228 sdl_mode => undef,
229 fullscreen => 1,
230 fast => 0,
231 force_opengl11 => undef,
232 disable_alpha => 0,
233 smooth_movement => 1,
234 smooth_transitions => 1,
235 texture_compression => 1,
236 map_scale => 1,
237 fow_enable => 1,
238 fow_intensity => 0,
239 fow_texture => 0,
240 map_smoothing => 1,
241 gui_fontsize => 1,
242 log_fontsize => 0.7,
243 gauge_fontsize => 1,
244 gauge_size => 0.35,
245 stat_fontsize => 0.7,
246 mapsize => 100,
247 audio_enable => 1,
248 audio_hw_channels => 0,
249 audio_hw_frequency => 0,
250 audio_hw_chunksize => 0,
251 audio_mix_channels => 8,
252 effects_enable => 1,
253 effects_volume => 1,
254 bgm_enable => 1,
255 bgm_volume => 0.5,
256 output_rate => "",
257 pickup => Deliantra::Protocol::Constants::PICKUP_SPELLBOOK
258 | Deliantra::Protocol::Constants::PICKUP_SKILLSCROLL
259 | Deliantra::Protocol::Constants::PICKUP_VALUABLES,
260 inv_sort => "mtime",
261 default => "profile", # default profile
262 show_tips => 1,
263 logview_max_par => 1000,
264 shift_fire_stop => 0,
265 uitheme => "wood",
266 map_shift_x => -24, # arbitrary
267 map_shift_y => +24, # arbitrary
268 #db_schema => 0,
269 );
270
271 while (my ($k, $v) = each %DEF_CFG) {
272 $::CFG->{$k} = $v unless exists $::CFG->{$k};
273 }
274}
275
276sub http_proxy {
277 my @proxy = win32_proxy_info;
278
279 if (@proxy) {
280 "http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
281 } elsif (exists $ENV{http_proxy}) {
282 $ENV{http_proxy}
283 } else {
284 ()
285 }
286}
287
288sub set_proxy {
289 my $proxy = http_proxy
290 or return;
291
292 $ENV{http_proxy} = $proxy;
293}
294
295sub lwp_useragent {
296 require LWP::UserAgent;
63 { 297
64 require Data::Dumper; 298 DC::set_proxy;
65 local $Data::Dumper::Purity = 1;
66 $::CFG->{VERSION} = $::VERSION;
67 print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]);
68 }
69 299
70 close CFG; 300 my $ua = LWP::UserAgent->new (
301 agent => "deliantra $VERSION",
302 keep_alive => 1,
303 env_proxy => 1,
304 timeout => 30,
305 );
71} 306}
72 307
73mkdir "$Crossfire::VARDIR/cfplus", 0777; 308sub lwp_check($) {
74
75our $DB_ENV;
76
77{
78 use strict;
79
80 my $recover = $BerkeleyDB::db_version >= 4.4
81 ? eval "DB_REGISTER | DB_RECOVER"
82 : 0;
83 warn $recover;
84
85 $DB_ENV = new BerkeleyDB::Env
86 -Home => "$Crossfire::VARDIR/cfplus",
87 -Cachesize => 1_000_000,
88 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
89# -ErrPrefix => "DATABASE",
90 -Verbose => 1,
91 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover,
92 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
93 or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
94}
95
96sub db_table($) {
97 my ($table) = @_; 309 my ($res) = @_;
98 310
99 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 311 $res->is_error
312 and die $res->status_line;
100 313
101 new CFClient::Database 314 $res
102 -Env => $DB_ENV,
103 -Filename => $table,
104# -Filename => "database",
105# -Subname => $table,
106 -Property => DB_CHKSUM,
107 -Flags => DB_CREATE | DB_UPGRADE,
108 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
109} 315}
110 316
111sub pod_to_pango($) { 317sub fh_nonblocking($$) {
112 my ($pom) = @_; 318 my ($fh, $nb) = @_;
113 319
114 $pom->present ("CFClient::PodToPango") 320 if ($^O eq "MSWin32") {
115} 321 $nb = (! ! $nb) + 0;
116 322 ioctl $fh, 0x8004667e, \$nb; # FIONBIO
117sub pod_to_pango_list($) { 323 } else {
118 my ($pom) = @_; 324 fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
119
120 [ 325 }
121 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "],
122 split /\n/, $pom->present ("CFClient::PodToPango")
123 ]
124} 326}
125 327
126package CFClient::PodToPango; 328package DC::Layout;
127 329
128use base Pod::POM::View::Text; 330$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
129 331 glyph_cache_restore;
130our $indent = 0;
131
132*view_seq_code =
133*view_seq_bold = sub { "<b>$_[1]</b>" };
134*view_seq_italic = sub { "<i>$_[1]</i>" };
135*view_seq_space =
136*view_seq_link =
137*view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
138
139sub view_seq_text {
140 my $text = $_[1];
141 $text =~ s/\s+/ /g;
142 CFClient::UI::Label::escape ($text)
143}
144
145sub view_item {
146 ("\t" x ($indent / 4))
147 . $_[1]->title->present ($_[0])
148 . "\n"
149 . $_[1]->content->present ($_[0])
150}
151
152sub view_verbatim {
153 (join "",
154 map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
155 split /\n/, CFClient::UI::Label::escape ($_[1]))
156 . "\n"
157}
158
159sub view_textblock {
160 ("\t" x ($indent / 2)) . "$_[1]\n\n"
161}
162
163sub view_head1 {
164 "\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
165 . $_[1]->content->present ($_[0])
166}; 332};
167 333
168sub view_head2 { 334$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
169 "\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n" 335 glyph_cache_backup;
170 . $_[1]->content->present ($_[0])
171}; 336};
172
173sub view_head3 {
174 "\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
175 . $_[1]->content->present ($_[0])
176};
177
178sub view_over {
179 local $indent = $indent + $_[1]->indent;
180 $_[1]->content->present ($_[0])
181}
182
183package CFClient::Database;
184
185our @ISA = BerkeleyDB::Btree::;
186
187sub get($$) {
188 my $data;
189
190 $_[0]->db_get ($_[1], $data) == 0
191 ? $data
192 : ()
193}
194
195my %DB_SYNC;
196
197sub put($$$) {
198 my ($db, $key, $data) = @_;
199
200 $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
201
202 $db->db_put ($key => $data)
203}
204
205package CFClient::Item;
206
207use strict;
208use Crossfire::Protocol::Constants;
209
210sub desc_string {
211 my ($self) = @_;
212
213 my $desc =
214 $self->{nrof} < 2
215 ? $self->{name}
216 : "$self->{nrof} × $self->{name_pl}";
217
218 $self->{flags} & F_OPEN
219 and $desc .= " (open)";
220 $self->{flags} & F_APPLIED
221 and $desc .= " (applied)";
222 $self->{flags} & F_UNPAID
223 and $desc .= " (unpaid)";
224 $self->{flags} & F_MAGIC
225 and $desc .= " (magic)";
226 $self->{flags} & F_CURSED
227 and $desc .= " (cursed)";
228 $self->{flags} & F_DAMNED
229 and $desc .= " (damned)";
230 $self->{flags} & F_LOCKED
231 and $desc .= " *";
232
233 $desc
234}
235
236sub weight_string {
237 my ($self) = @_;
238
239 my $weight = ($self->{nrof} || 1) * $self->{weight};
240
241 $weight < 0 ? "?" : $weight * 0.001
242}
243
244sub update_widgets {
245 my ($self) = @_;
246
247 my $button_cb = sub {
248 my (undef, $ev, $x, $y) = @_;
249
250 if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
251 my $targ = $::CONN->{player}{tag};
252
253 if ($self->{container} == $::CONN->{player}{tag}) {
254 $targ = $::CONN->{open_container};
255 }
256
257 $::CONN->send ("move $targ $self->{tag} 0")
258 if $targ || !($self->{flags} & F_LOCKED);
259 } elsif ($ev->{button} == 1) {
260 $::CONN->send ("examine $self->{tag}");
261 } elsif ($ev->{button} == 2) {
262 $::CONN->send ("apply $self->{tag}");
263 } elsif ($ev->{button} == 3) {
264 my @menu_items = (
265 ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
266 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
267 ["apply", sub { $::CONN->send ("apply $self->{tag}") }],
268 (
269 $self->{flags} & F_LOCKED
270 ? (
271 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
272 )
273 : (
274 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
275 ["drop", sub { $::CONN->send ("move $::CONN->{open_container} $self->{tag} 0") }],
276 )
277 ),
278 );
279
280 CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
281 }
282
283 1
284 };
285
286 my $tooltip_std = "<small>"
287 . "Left click - examine item\n"
288 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
289 . "Middle click - apply\n"
290 . "Right click - further options"
291 . "</small>\n";
292
293 $self->{face_widget} ||= new CFClient::UI::Face
294 can_events => 1,
295 can_hover => 1,
296 anim => $self->{anim},
297 animspeed => $self->{animspeed}, # TODO# must be set at creation time
298 on_button_down => $button_cb,
299 ;
300 $self->{face_widget}{face} = $self->{face};
301 $self->{face_widget}{anim} = $self->{anim};
302 $self->{face_widget}{animspeed} = $self->{animspeed};
303 $self->{face_widget}->set_tooltip (
304 "<b>Face/Animation.</b>\n"
305 . "Item uses face #$self->{face}. "
306 . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
307 . "\n\n$tooltip_std"
308 );
309
310 $self->{desc_widget} ||= new CFClient::UI::Label
311 can_events => 1,
312 can_hover => 1,
313 ellipsise => 2,
314 align => -1,
315 on_button_down => $button_cb,
316 ;
317 my $desc = CFClient::Item::desc_string $self;
318 $self->{desc_widget}->set_text ($desc);
319 $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
320
321 $self->{weight_widget} ||= new CFClient::UI::Label
322 can_events => 1,
323 can_hover => 1,
324 ellipsise => 0,
325 align => 0,
326 on_button_down => $button_cb,
327 ;
328 $self->{weight_widget}->set_text (CFClient::Item::weight_string $self);
329
330 $self->{weight_widget}->set_tooltip (
331 "<b>Weight</b>.\n"
332 . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
333 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
334 . "\n\n$tooltip_std"
335 );
336}
337
338package CFClient::Binder;
339
340my @ALLOWED_MODIFIER_KEYS = (
341 (CFClient::SDLK_LSHIFT),
342 (CFClient::SDLK_LCTRL ),
343 (CFClient::SDLK_LALT ),
344 (CFClient::SDLK_LMETA ),
345
346 (CFClient::SDLK_RSHIFT),
347 (CFClient::SDLK_RCTRL ),
348 (CFClient::SDLK_RALT ),
349 (CFClient::SDLK_RMETA ),
350);
351
352my %ALLOWED_MODIFIERS = (
353 (CFClient::KMOD_LSHIFT) => "LSHIFT",
354 (CFClient::KMOD_LCTRL ) => "LCTRL",
355 (CFClient::KMOD_LALT ) => "LALT",
356 (CFClient::KMOD_LMETA ) => "LMETA",
357
358 (CFClient::KMOD_RSHIFT) => "RSHIFT",
359 (CFClient::KMOD_RCTRL ) => "RCTRL",
360 (CFClient::KMOD_RALT ) => "RALT",
361 (CFClient::KMOD_RMETA ) => "RMETA",
362);
363
364my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/;
365my @DIRECT_BIND_KEYS = (
366 CFClient::SDLK_F1,
367 CFClient::SDLK_F2,
368 CFClient::SDLK_F3,
369 CFClient::SDLK_F4,
370 CFClient::SDLK_F5,
371 CFClient::SDLK_F6,
372 CFClient::SDLK_F7,
373 CFClient::SDLK_F8,
374 CFClient::SDLK_F9,
375 CFClient::SDLK_F10,
376 CFClient::SDLK_F11,
377 CFClient::SDLK_F12,
378 CFClient::SDLK_F13,
379 CFClient::SDLK_F14,
380 CFClient::SDLK_F15,
381);
382
383# this binding dialog asks for a key-combo to be pressed
384# and if successful it calls the $cb with $mod and $sym as args.
385sub open_binding_dialog {
386 my ($cb) = @_;
387
388 my $w = new CFClient::UI::FancyFrame
389 title => "Bind Action",
390 x => "center",
391 y => "center";
392
393 $w->add (my $vb = new CFClient::UI::VBox);
394 $vb->add (new CFClient::UI::Label
395 text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
396 ."You can only bind 0-9 and F1-F15 without modifiers."
397 );
398 $vb->add (my $entry = new CFClient::UI::Entry
399 text => "",
400 on_key_down => sub {
401 my ($entry, $ev) = @_;
402
403 my $mod = $ev->{mod};
404 my $sym = $ev->{sym};
405
406 # XXX: This seems a little bit hackisch to me, but i have to ignore them
407 if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) {
408 return;
409 }
410
411 if ($mod == CFClient::KMOD_NONE
412 and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})}
413 and not grep { $sym == $_ } @DIRECT_BIND_KEYS)
414 {
415 $::STATUSBOX->add (
416 "Can't bind key ".CFClient::SDL_GetKeyName ($sym)
417 ." directly without modifier! It would damage the completer handling."
418 );
419 return;
420 }
421
422 $entry->focus_out;
423
424 $cb->($mod, $sym);
425
426 $w->destroy
427 });
428
429 $entry->focus_in;
430 $w->show;
431}
432
433sub keycombo_to_name {
434 my ($mod, $sym) = @_;
435
436 my $mods = join '+',
437 map { $ALLOWED_MODIFIERS{$_} }
438 grep { ($_ + 0) & ($mod + 0) }
439 keys %ALLOWED_MODIFIERS;
440 $mods .= "+" if $mods ne '';
441
442 return $mods . CFClient::SDL_GetKeyName ($sym);
443}
444 337
4451; 3381;
446 339
447=back 340=back
448 341

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines