[ViewVC] Diff of: cvs/deliantra/Deliantra-Client/DC.pm

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.116 by root, Fri Aug 18 01:01:00 2006 UTC vs.
Revision 1.200 by root, Sun Jan 4 10:22:19 2009 UTC

…		…
1	=head1 NAME	1	=head1 NAME
2		2
3	CFPlus - undocumented utility garbage for our crossfire client	3	DC - 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
15	package CFPlus;	15	package DC;
		16
		17	use Carp ();
		18
		19	our $VERSION;
16		20
17	BEGIN {	21	BEGIN {
18	$VERSION = '0.2';	22	$VERSION = '2.02';
19		23
20	use XSLoader;	24	use XSLoader;
21	XSLoader::load "CFPlus", $VERSION;	25	XSLoader::load "Deliantra::Client", $VERSION;
22	}	26	}
23		27
24	use utf8;	28	use utf8;
		29	use strict qw(vars subs);
25		30
26	use Carp ();	31	use Socket ();
27	use AnyEvent ();	32	use AnyEvent ();
28	use BerkeleyDB;	33	use AnyEvent::Util ();
29	use Pod::POM ();	34	use Pod::POM ();
30	use Scalar::Util ();	35	use File::Path ();
31	use Storable (); # finally	36	use Storable (); # finally
		37	use Fcntl ();
		38	use JSON::XS qw(encode_json decode_json);
32		39
33	=item guard { BLOCK }	40	=item guard { BLOCK }
34		41
35	Returns an object that executes the given block as soon as it is destroyed.	42	Returns an object that executes the given block as soon as it is destroyed.
36		43
37	=cut	44	=cut
38		45
39	sub guard(&) {	46	sub guard(&) {
40	bless \(my $cb = $_[0]), "CFPlus::Guard"	47	bless \(my $cb = $_[0]), "DC::Guard"
41	}	48	}
42		49
43	sub CFPlus::Guard::DESTROY {	50	sub DC::Guard::DESTROY {
44	${$_[0]}->()	51	${$_[0]}->()
		52	}
		53
		54	=item shorten $string[, $maxlength]
		55
		56	=cut
		57
		58	sub shorten($;$) {
		59	my ($str, $len) = @_;
		60	substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
		61	$str
45	}	62	}
46		63
47	sub asxml($) {	64	sub asxml($) {
48	local $_ = $_[0];	65	local $_ = $_[0];
49		66
52	s/</</g;	69	s/</</g;
53		70
54	$_	71	$_
55	}	72	}
56		73
57	package CFPlus::Database;	74	sub background(&;&) {
		75	my ($bg, $cb) = @_;
58		76
59	our @ISA = BerkeleyDB::Btree::;	77	my ($fh_r, $fh_w) = AnyEvent::Util::portable_socketpair
		78	or die "unable to create background socketpair: $!";
60		79
61	sub get($$) {	80	my $pid = fork;
62	my $data;
63		81
64	$_[0]->db_get ($_[1], $data) == 0	82	if (defined $pid && !$pid) {
65	? $data	83	local $SIG{__DIE__};
66	: ()
67	}
68		84
69	my %DB_SYNC;	85	open STDOUT, ">&", $fh_w;
		86	open STDERR, ">&", $fh_w;
		87	close $fh_r;
		88	close $fh_w;
70		89
71	sub put($$$) {	90	$\| = 1;
72	my ($db, $key, $data) = @_;
73		91
74	my $key = $db + 0;	92	eval { $bg->() };
75	Scalar::Util::weaken $db;	93
76	$DB_SYNC{$key} \|\|= AnyEvent->timer (after => 5, cb => sub {	94	if ($@) {
77	delete $DB_SYNC{$key};	95	my $msg = $@;
78	$db->db_sync if $db;	96	$msg =~ s/\n+/\n/;
		97	warn "FATAL: $msg";
		98	DC::_exit 1;
		99	}
		100
		101	# win32 is fucked up, of course. exit will clean stuff up,
		102	# which destroys our database etc. _exit will exit ALL
		103	# forked processes, because of the dreaded fork emulation.
		104	DC::_exit 0;
		105	}
		106
		107	close $fh_w;
		108
		109	my $buffer;
		110
		111	my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
		112	unless (sysread $fh_r, $buffer, 4096, length $buffer) {
		113	undef $w;
		114	$cb->();
		115	return;
		116	}
		117
		118	while ($buffer =~ s/^(.*)\n//) {
		119	my $line = $1;
		120	$line =~ s/\s+$//;
		121	utf8::decode $line;
		122	if ($line =~ /^\x{e877}json_msg (.*)$/s) {
		123	$cb->(JSON::XS->new->allow_nonref->decode ($1));
		124	} else {
		125	::message ({
		126	markup => "background($pid): " . DC::asxml $line,
		127	});
		128	}
		129	}
79	});	130	});
80
81	$db->db_put ($key => $data)
82	}	131	}
83		132
		133	sub background_msg {
		134	my ($msg) = @_;
		135
		136	$msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
		137	$msg =~ s/\n//g;
		138	utf8::encode $msg;
		139	print $msg, "\n";
		140	}
		141
84	package CFPlus;	142	package DC;
		143
		144	our $RC_THEME;
		145	our %THEME;
		146	our @RC_PATH;
		147	our $RC_BASE;
		148
		149	for (grep !ref, @INC) {
		150	$RC_BASE = "$_/Deliantra/Client/private/resources";
		151	last if -d $RC_BASE;
		152	}
85		153
86	sub find_rcfile($) {	154	sub find_rcfile($) {
87	my $path;	155	my $path;
88		156
89	for (grep !ref, @INC) {	157	for (@RC_PATH, "") {
90	$path = "$_/CFPlus/resources/$_[0]";	158	$path = "$RC_BASE/$_/$_[0]";
91	return $path if -r $path;	159	return $path if -r $path;
92	}	160	}
93		161
94	die "FATAL: can't find required file $_[0]\n";	162	die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
95	}	163	}
96		164
97	BEGIN {	165	sub load_json($) {
98	use Crossfire::Protocol::Base ();	166	my ($file) = @_;
99	*to_json = \&Crossfire::Protocol::Base::to_json;	167
100	*from_json = \&Crossfire::Protocol::Base::from_json;	168	open my $fh, $file
		169	or return;
		170
		171	local $/;
		172	JSON::XS->new->utf8->relaxed->decode (<$fh>)
		173	}
		174
		175	sub set_theme($) {
		176	return if $RC_THEME eq $_[0];
		177	$RC_THEME = $_[0];
		178
		179	# kind of hacky, find the main theme file, then load all theme files and merge them
		180
		181	%THEME = ();
		182	@RC_PATH = "theme-$RC_THEME";
		183
		184	my $theme = load_json find_rcfile "theme.json"
		185	or die "FATAL: theme resource file not found";
		186
		187	@RC_PATH = @{ $theme->{path} } if $theme->{path};
		188
		189	for (@RC_PATH, "") {
		190	my $theme = load_json "$RC_BASE/$_/theme.json"
		191	or next;
		192
		193	%THEME = ( %$theme, %THEME );
		194	}
101	}	195	}
102		196
103	sub read_cfg {	197	sub read_cfg {
104	my ($file) = @_;	198	my ($file) = @_;
105		199
106	open my $fh, $file	200	$::CFG = load_json $file;
107	or return;
108
109	local $/;
110	my $CFG = <$fh>;
111
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;
118	} else {
119	$::CFG = eval $CFG; ## todo comaptibility cruft
120	}
121	}	201	}
122		202
123	sub write_cfg {	203	sub write_cfg {
124	my ($file) = @_;	204	my $file = "$Deliantra::VARDIR/client.cf";
125		205
126	$::CFG->{VERSION} = $::VERSION;	206	$::CFG->{VERSION} = $::VERSION;
127		207
128	open my $fh, ">:utf8", $file	208	open my $fh, ">:utf8", $file
129	or return;	209	or return;
130	print $fh to_json $::CFG;	210	print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
131	}	211	}
132		212
133	our $DB_ENV;	213	sub http_proxy {
		214	my @proxy = win32_proxy_info;
134		215
135	{	216	if (@proxy) {
136	use strict;	217	"http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
137		218	} elsif (exists $ENV{http_proxy}) {
138	mkdir "$Crossfire::VARDIR/cfplus", 0777;	219	$ENV{http_proxy}
139	my $recover = $BerkeleyDB::db_version >= 4.4	220	} else {
140	? eval "DB_REGISTER \| DB_RECOVER"	221	()
141	: 0;	222	}
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	}	223	}
153		224
154	sub db_table($) {	225	sub set_proxy {
		226	my $proxy = http_proxy
		227	or return;
		228
		229	$ENV{http_proxy} = $proxy;
		230	}
		231
		232	sub lwp_useragent {
		233	require LWP::UserAgent;
		234
		235	DC::set_proxy;
		236
		237	my $ua = LWP::UserAgent->new (
		238	agent => "deliantra $VERSION",
		239	keep_alive => 1,
		240	env_proxy => 1,
		241	timeout => 30,
		242	);
		243	}
		244
		245	sub lwp_check($) {
155	my ($table) = @_;	246	my ($res) = @_;
156		247
157	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;	248	$res->is_error
		249	and die $res->status_line;
158		250
159	new CFPlus::Database	251	$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	}	252	}
168		253
		254	sub fh_nonblocking($$) {
		255	my ($fh, $nb) = @_;
		256
		257	if ($^O eq "MSWin32") {
		258	$nb = (! ! $nb) + 0;
		259	ioctl $fh, 0x8004667e, \$nb; # FIONBIO
		260	} else {
		261	fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
		262	}
		263	}
		264
169	package CFPlus::Layout;	265	package DC::Layout;
170		266
171	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {	267	$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
172	reset_glyph_cache;	268	glyph_cache_restore;
173	};	269	};
174		270
175	package CFPlus::Item;	271	$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
176		272	glyph_cache_backup;
177	use strict;	273	};
178	use Crossfire::Protocol::Constants;
179
180	my $last_enter_count = 1;
181
182	sub 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
208	sub weight_string {
209	my ($self) = @_;
210
211	my $weight = ($self->{nrof} \|\| 1) * $self->{weight};
212
213	$weight < 0 ? "?" : $weight * 0.001
214	}
215
216	sub 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
243	sub 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 <n>",
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		274
386	1;	275	1;
387		276
388	=back	277	=back
389		278

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing deliantra/Deliantra-Client/DC.pm (file contents): Revision 1.116 by root, Fri Aug 18 01:01:00 2006 UTC vs. Revision 1.200 by root, Sun Jan 4 10:22:19 2009 UTC

Diff Legend

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.116 by root, Fri Aug 18 01:01:00 2006 UTC vs.
Revision 1.200 by root, Sun Jan 4 10:22:19 2009 UTC