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

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.119 by root, Tue Sep 12 20:51:17 2006 UTC vs.
Revision 1.190 by root, Tue Sep 2 17:08:44 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.51';	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	my $hkey = $db + 0;	86	my $pid = fork;
75	Scalar::Util::weaken $db;	87
76	$DB_SYNC{$hkey} \|\|= AnyEvent->timer (after => 5, cb => sub {	88	if (defined $pid && !$pid) {
77	delete $DB_SYNC{$hkey};	89	local $SIG{__DIE__};
78	$db->db_sync if $db;	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	}
79	});	136	});
80
81	$db->db_put ($key => $data)
82	}	137	}
83		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
84	package CFPlus;	148	package DC;
		149
		150	our @RC_THEME = ("theme-blue", ".");
		151	our $RC_BASE;
		152
		153	for (grep !ref, @INC) {
		154	$RC_BASE = "$_/Deliantra/Client/private/resources";
		155	last if -d $RC_BASE;
		156	}
85		157
86	sub find_rcfile($) {	158	sub find_rcfile($) {
87	my $path;	159	my $path;
88		160
89	for (grep !ref, @INC) {	161	for (@RC_THEME) {
90	$path = "$_/CFPlus/resources/$_[0]";	162	$path = "$RC_BASE/$_/$_[0]";
91	return $path if -r $path;	163	return $path if -r $path;
92	}	164	}
93		165
94	die "FATAL: can't find required file $_[0]\n";	166	die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
95	}
96
97	BEGIN {
98	use Crossfire::Protocol::Base ();
99	*to_json = \&Crossfire::Protocol::Base::to_json;
100	*from_json = \&Crossfire::Protocol::Base::from_json;
101	}	167	}
102		168
103	sub read_cfg {	169	sub read_cfg {
104	my ($file) = @_;	170	my ($file) = @_;
105		171
…		…
107	or return;	173	or return;
108		174
109	local $/;	175	local $/;
110	my $CFG = <$fh>;	176	my $CFG = <$fh>;
111		177
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;	178	$::CFG = decode_json $CFG;
118	} else {
119	$::CFG = eval $CFG; ## todo comaptibility cruft
120	}
121	}	179	}
122		180
123	sub write_cfg {	181	sub write_cfg {
124	my ($file) = @_;	182	my $file = "$Deliantra::VARDIR/client.cf";
125		183
126	$::CFG->{VERSION} = $::VERSION;	184	$::CFG->{VERSION} = $::VERSION;
127		185
128	open my $fh, ">:utf8", $file	186	open my $fh, ">:utf8", $file
129	or return;	187	or return;
130	print $fh to_json $::CFG;	188	print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
131	}	189	}
132		190
133	our $DB_ENV;	191	sub http_proxy {
		192	my @proxy = win32_proxy_info;
134		193
135	{	194	if (@proxy) {
136	use strict;	195	"http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
137		196	} elsif (exists $ENV{http_proxy}) {
138	mkdir "$Crossfire::VARDIR/cfplus", 0777;	197	$ENV{http_proxy}
139	my $recover = $BerkeleyDB::db_version >= 4.4	198	} else {
140	? eval "DB_REGISTER \| DB_RECOVER"	199	()
141	: 0;	200	}
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	}	201	}
153		202
154	sub db_table($) {	203	sub set_proxy {
		204	my $proxy = http_proxy
		205	or return;
		206
		207	$ENV{http_proxy} = $proxy;
		208	}
		209
		210	sub lwp_useragent {
		211	require LWP::UserAgent;
		212
		213	DC::set_proxy;
		214
		215	my $ua = LWP::UserAgent->new (
		216	agent => "deliantra $VERSION",
		217	keep_alive => 1,
		218	env_proxy => 1,
		219	timeout => 30,
		220	);
		221	}
		222
		223	sub lwp_check($) {
155	my ($table) = @_;	224	my ($res) = @_;
156		225
157	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;	226	$res->is_error
		227	and die $res->status_line;
158		228
159	new CFPlus::Database	229	$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	}	230	}
168		231
		232	sub fh_nonblocking($$) {
		233	my ($fh, $nb) = @_;
		234
		235	if ($^O eq "MSWin32") {
		236	$nb = (! ! $nb) + 0;
		237	ioctl $fh, 0x8004667e, \$nb; # FIONBIO
		238	} else {
		239	fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
		240	}
		241	}
		242
169	package CFPlus::Layout;	243	package DC::Layout;
170		244
171	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {	245	$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
172	reset_glyph_cache;	246	glyph_cache_restore;
173	};	247	};
174		248
175	package CFPlus::Item;	249	$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
176		250	glyph_cache_backup;
177	use strict;	251	};
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		252
386	1;	253	1;
387		254
388	=back	255	=back
389		256

Diff Legend

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

Comparing deliantra/Deliantra-Client/DC.pm (file contents): Revision 1.119 by root, Tue Sep 12 20:51:17 2006 UTC vs. Revision 1.190 by root, Tue Sep 2 17:08:44 2008 UTC

Diff Legend

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.119 by root, Tue Sep 12 20:51:17 2006 UTC vs.
Revision 1.190 by root, Tue Sep 2 17:08:44 2008 UTC