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

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.114 by elmex, Mon Aug 14 04:34:40 2006 UTC vs.
Revision 1.191 by root, Wed Sep 3 06:07:39 2008 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 Deliantra::Client; # work around CPAN breakage
		16	package App::Deliantra; # try to reserve namespace
15	package CFPlus;	17	package DC;
		18
		19	use Carp ();
		20
		21	our $VERSION;
16		22
17	BEGIN {	23	BEGIN {
18	$VERSION = '0.2';	24	$VERSION = '0.9975';
19		25
20	use XSLoader;	26	use XSLoader;
21	XSLoader::load "CFPlus", $VERSION;	27	XSLoader::load "Deliantra::Client", $VERSION;
22	}	28	}
23		29
24	use utf8;	30	use utf8;
		31	use strict qw(vars subs);
25		32
26	use Carp ();
27	use AnyEvent ();	33	use AnyEvent ();
28	use BerkeleyDB;
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 socketpipe() {
		75	socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
		76	or die "cannot establish bidirectional pipe: $!\n";
58		77
59	our @ISA = BerkeleyDB::Btree::;	78	($fh1, $fh2)
60
61	sub get($$) {
62	my $data;
63
64	$_[0]->db_get ($_[1], $data) == 0
65	? $data
66	: ()
67	}	79	}
68		80
69	my %DB_SYNC;	81	sub background(&;&) {
		82	my ($bg, $cb) = @_;
70		83
71	sub put($$$) {	84	my ($fh_r, $fh_w) = DC::socketpipe;
72	my ($db, $key, $data) = @_;
73		85
74	$DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });	86	my $pid = fork;
75		87
76	$db->db_put ($key => $data)	88	if (defined $pid && !$pid) {
77	}	89	local $SIG{__DIE__};
78		90
		91	open STDOUT, ">&", $fh_w;
		92	open STDERR, ">&", $fh_w;
		93	close $fh_r;
		94	close $fh_w;
		95
		96	$\| = 1;
		97
		98	eval { $bg->() };
		99
		100	if ($@) {
		101	my $msg = $@;
		102	$msg =~ s/\n+/\n/;
		103	warn "FATAL: $msg";
		104	DC::_exit 1;
		105	}
		106
		107	# win32 is fucked up, of course. exit will clean stuff up,
		108	# which destroys our database etc. _exit will exit ALL
		109	# forked processes, because of the dreaded fork emulation.
		110	DC::_exit 0;
		111	}
		112
		113	close $fh_w;
		114
		115	my $buffer;
		116
		117	my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
		118	unless (sysread $fh_r, $buffer, 4096, length $buffer) {
		119	undef $w;
		120	$cb->();
		121	return;
		122	}
		123
		124	while ($buffer =~ s/^(.*)\n//) {
		125	my $line = $1;
		126	$line =~ s/\s+$//;
		127	utf8::decode $line;
		128	if ($line =~ /^\x{e877}json_msg (.*)$/s) {
		129	$cb->(JSON::XS->new->allow_nonref->decode ($1));
		130	} else {
		131	::message ({
		132	markup => "background($pid): " . DC::asxml $line,
		133	});
		134	}
		135	}
		136	});
		137	}
		138
		139	sub background_msg {
		140	my ($msg) = @_;
		141
		142	$msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
		143	$msg =~ s/\n//g;
		144	utf8::encode $msg;
		145	print $msg, "\n";
		146	}
		147
79	package CFPlus;	148	package DC;
		149
		150	our $RC_THEME;
		151	our $THEME;
		152	our @RC_PATH;
		153	our $RC_BASE;
		154
		155	for (grep !ref, @INC) {
		156	$RC_BASE = "$_/Deliantra/Client/private/resources";
		157	last if -d $RC_BASE;
		158	}
80		159
81	sub find_rcfile($) {	160	sub find_rcfile($) {
82	my $path;	161	my $path;
83		162
84	for (grep !ref, @INC) {	163	for (@RC_PATH, "") {
85	$path = "$_/CFPlus/resources/$_[0]";	164	$path = "$RC_BASE/$_/$_[0]";
86	return $path if -r $path;	165	return $path if -r $path;
87	}	166	}
88		167
89	die "FATAL: can't find required file $_[0]\n";	168	die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
90	}	169	}
91		170
92	BEGIN {	171	sub set_theme($) {
93	use Crossfire::Protocol::Base ();	172	return if $RC_THEME eq $_[0];
94	*to_json = \&Crossfire::Protocol::Base::to_json;	173	$RC_THEME = $_[0];
95	*from_json = \&Crossfire::Protocol::Base::from_json;	174
		175	@RC_PATH = "theme-$RC_THEME";
		176
		177	{
		178	open my $fh, "<:raw", find_rcfile "theme.json"
		179	or die "cannot open theme description file";
		180
		181	local $/;
		182	$THEME = JSON::XS->new->utf8->relaxed->decode (<$fh>);
		183	}
		184
		185	@RC_PATH = @{ $THEME->{path} } if $THEME->{path};
96	}	186	}
97		187
98	sub read_cfg {	188	sub read_cfg {
99	my ($file) = @_;	189	my ($file) = @_;
100		190
…		…
102	or return;	192	or return;
103		193
104	local $/;	194	local $/;
105	my $CFG = <$fh>;	195	my $CFG = <$fh>;
106		196
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;	197	$::CFG = decode_json $CFG;
113	} else {
114	$::CFG = eval $CFG; ## todo comaptibility cruft
115	}
116	}	198	}
117		199
118	sub write_cfg {	200	sub write_cfg {
119	my ($file) = @_;	201	my $file = "$Deliantra::VARDIR/client.cf";
120		202
121	$::CFG->{VERSION} = $::VERSION;	203	$::CFG->{VERSION} = $::VERSION;
122		204
123	open my $fh, ">:utf8", $file	205	open my $fh, ">:utf8", $file
124	or return;	206	or return;
125	print $fh to_json $::CFG;	207	print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
126	}	208	}
127		209
128	our $DB_ENV;	210	sub http_proxy {
		211	my @proxy = win32_proxy_info;
129		212
130	{	213	if (@proxy) {
131	use strict;	214	"http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
132		215	} elsif (exists $ENV{http_proxy}) {
133	mkdir "$Crossfire::VARDIR/cfplus", 0777;	216	$ENV{http_proxy}
134	my $recover = $BerkeleyDB::db_version >= 4.4	217	} else {
135	? eval "DB_REGISTER \| DB_RECOVER"	218	()
136	: 0;	219	}
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	}	220	}
148		221
149	sub db_table($) {	222	sub set_proxy {
		223	my $proxy = http_proxy
		224	or return;
		225
		226	$ENV{http_proxy} = $proxy;
		227	}
		228
		229	sub lwp_useragent {
		230	require LWP::UserAgent;
		231
		232	DC::set_proxy;
		233
		234	my $ua = LWP::UserAgent->new (
		235	agent => "deliantra $VERSION",
		236	keep_alive => 1,
		237	env_proxy => 1,
		238	timeout => 30,
		239	);
		240	}
		241
		242	sub lwp_check($) {
150	my ($table) = @_;	243	my ($res) = @_;
151		244
152	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;	245	$res->is_error
		246	and die $res->status_line;
153		247
154	new CFPlus::Database	248	$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	}	249	}
163		250
		251	sub fh_nonblocking($$) {
		252	my ($fh, $nb) = @_;
		253
		254	if ($^O eq "MSWin32") {
		255	$nb = (! ! $nb) + 0;
		256	ioctl $fh, 0x8004667e, \$nb; # FIONBIO
		257	} else {
		258	fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
		259	}
		260	}
		261
164	package CFPlus::Layout;	262	package DC::Layout;
165		263
166	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {	264	$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
167	reset_glyph_cache;	265	glyph_cache_restore;
168	};	266	};
169		267
170	package CFPlus::Item;	268	$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
171		269	glyph_cache_backup;
172	use strict;	270	};
173	use Crossfire::Protocol::Constants;
174
175	my $last_enter_count = 1;
176
177	sub 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
203	sub weight_string {
204	my ($self) = @_;
205
206	my $weight = ($self->{nrof} \|\| 1) * $self->{weight};
207
208	$weight < 0 ? "?" : $weight * 0.001
209	}
210
211	sub 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
238	sub 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 <n>",
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		271
380	1;	272	1;
381		273
382	=back	274	=back
383		275

Diff Legend

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

Comparing deliantra/Deliantra-Client/DC.pm (file contents): Revision 1.114 by elmex, Mon Aug 14 04:34:40 2006 UTC vs. Revision 1.191 by root, Wed Sep 3 06:07:39 2008 UTC

Diff Legend

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.114 by elmex, Mon Aug 14 04:34:40 2006 UTC vs.
Revision 1.191 by root, Wed Sep 3 06:07:39 2008 UTC