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

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.121 by root, Fri Sep 29 00:56:05 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;
16		18
17	use Carp ();	19	use Carp ();
18		20
		21	our $VERSION;
		22
19	BEGIN {	23	BEGIN {
20	$VERSION = '0.52';	24	$VERSION = '0.9975';
21		25
22	use XSLoader;	26	use XSLoader;
23	XSLoader::load "CFPlus", $VERSION;	27	XSLoader::load "Deliantra::Client", $VERSION;
24	}
25
26	BEGIN {
27	$SIG{__DIE__} = sub {
28	return if CFPlus::in_destruct;
29	#CFPlus::fatal $_[0];#d#
30	CFPlus::error Carp::longmess $_[0];#d#
31	die;#d#
32	};
33	}	28	}
34		29
35	use utf8;	30	use utf8;
		31	use strict qw(vars subs);
36		32
37	use AnyEvent ();	33	use AnyEvent ();
38	use BerkeleyDB;
39	use Pod::POM ();	34	use Pod::POM ();
40	use Scalar::Util ();	35	use File::Path ();
41	use Storable (); # finally	36	use Storable (); # finally
		37	use Fcntl ();
		38	use JSON::XS qw(encode_json decode_json);
42		39
43	=item guard { BLOCK }	40	=item guard { BLOCK }
44		41
45	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.
46		43
47	=cut	44	=cut
48		45
49	sub guard(&) {	46	sub guard(&) {
50	bless \(my $cb = $_[0]), "CFPlus::Guard"	47	bless \(my $cb = $_[0]), "DC::Guard"
51	}	48	}
52		49
53	sub CFPlus::Guard::DESTROY {	50	sub DC::Guard::DESTROY {
54	${$_[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
55	}	62	}
56		63
57	sub asxml($) {	64	sub asxml($) {
58	local $_ = $_[0];	65	local $_ = $_[0];
59		66
62	s/</</g;	69	s/</</g;
63		70
64	$_	71	$_
65	}	72	}
66		73
67	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";
68		77
69	our @ISA = BerkeleyDB::Btree::;	78	($fh1, $fh2)
70
71	sub get($$) {
72	my $data;
73
74	$_[0]->db_get ($_[1], $data) == 0
75	? $data
76	: ()
77	}	79	}
78		80
79	my %DB_SYNC;	81	sub background(&;&) {
		82	my ($bg, $cb) = @_;
80		83
81	sub put($$$) {	84	my ($fh_r, $fh_w) = DC::socketpipe;
82	my ($db, $key, $data) = @_;
83		85
84	my $hkey = $db + 0;	86	my $pid = fork;
85	Scalar::Util::weaken $db;	87
86	$DB_SYNC{$hkey} \|\|= AnyEvent->timer (after => 5, cb => sub {	88	if (defined $pid && !$pid) {
87	delete $DB_SYNC{$hkey};	89	local $SIG{__DIE__};
88	$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	}
89	});	136	});
90
91	$db->db_put ($key => $data)
92	}	137	}
93		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
94	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	}
95		159
96	sub find_rcfile($) {	160	sub find_rcfile($) {
97	my $path;	161	my $path;
98		162
99	for (grep !ref, @INC) {	163	for (@RC_PATH, "") {
100	$path = "$_/CFPlus/resources/$_[0]";	164	$path = "$RC_BASE/$_/$_[0]";
101	return $path if -r $path;	165	return $path if -r $path;
102	}	166	}
103		167
104	die "FATAL: can't find required file $_[0]\n";	168	die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
105	}	169	}
106		170
107	BEGIN {	171	sub set_theme($) {
108	use Crossfire::Protocol::Base ();	172	return if $RC_THEME eq $_[0];
109	*to_json = \&Crossfire::Protocol::Base::to_json;	173	$RC_THEME = $_[0];
110	*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};
111	}	186	}
112		187
113	sub read_cfg {	188	sub read_cfg {
114	my ($file) = @_;	189	my ($file) = @_;
115		190
…		…
117	or return;	192	or return;
118		193
119	local $/;	194	local $/;
120	my $CFG = <$fh>;	195	my $CFG = <$fh>;
121		196
122	if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove
123	require YAML;
124	utf8::decode $CFG;
125	$::CFG = YAML::Load ($CFG);
126	} elsif ($CFG =~ /^\{/) {
127	$::CFG = from_json $CFG;	197	$::CFG = decode_json $CFG;
128	} else {
129	$::CFG = eval $CFG; ## todo comaptibility cruft
130	}
131	}	198	}
132		199
133	sub write_cfg {	200	sub write_cfg {
134	my ($file) = @_;	201	my $file = "$Deliantra::VARDIR/client.cf";
135		202
136	$::CFG->{VERSION} = $::VERSION;	203	$::CFG->{VERSION} = $::VERSION;
137		204
138	open my $fh, ">:utf8", $file	205	open my $fh, ">:utf8", $file
139	or return;	206	or return;
140	print $fh to_json $::CFG;	207	print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
141	}	208	}
142		209
143	our $DB_ENV;	210	sub http_proxy {
144	our $DB_STATE;	211	my @proxy = win32_proxy_info;
145		212
146	sub db_table($) {	213	if (@proxy) {
		214	"http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
		215	} elsif (exists $ENV{http_proxy}) {
		216	$ENV{http_proxy}
		217	} else {
		218	()
		219	}
		220	}
		221
		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($) {
147	my ($table) = @_;	243	my ($res) = @_;
148		244
149	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;	245	$res->is_error
		246	and die $res->status_line;
150		247
151	new CFPlus::Database	248	$res
152	-Env => $DB_ENV,
153	-Filename => $table,
154	# -Filename => "database",
155	# -Subname => $table,
156	-Property => DB_CHKSUM,
157	-Flags => DB_CREATE \| DB_UPGRADE,
158	or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
159	}	249	}
160		250
161	{	251	sub fh_nonblocking($$) {
162	use strict;	252	my ($fh, $nb) = @_;
163		253
164	mkdir "$Crossfire::VARDIR/cfplus", 0777;	254	if ($^O eq "MSWin32") {
165	my $recover = $BerkeleyDB::db_version >= 4.4	255	$nb = (! ! $nb) + 0;
166	? eval "DB_REGISTER \| DB_RECOVER"	256	ioctl $fh, 0x8004667e, \$nb; # FIONBIO
167	: 0;	257	} else {
168		258	fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
169	$DB_ENV = new BerkeleyDB::Env	259	}
170	-Home => "$Crossfire::VARDIR/cfplus",
171	-Cachesize => 1_000_000,
172	-ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
173	# -ErrPrefix => "DATABASE",
174	-Verbose => 1,
175	-Flags => DB_CREATE \| DB_RECOVER \| DB_INIT_MPOOL \| DB_INIT_LOCK \| DB_INIT_TXN \| $recover,
176	-SetFlags => DB_AUTO_COMMIT \| DB_LOG_AUTOREMOVE,
177	or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
178
179	$DB_STATE = db_table "state";
180	}	260	}
181		261
182	package CFPlus::Layout;	262	package DC::Layout;
183		263
184	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {	264	$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
185	reset_glyph_cache;	265	glyph_cache_restore;
186	};	266	};
187		267
188	package CFPlus::Item;	268	$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
189		269	glyph_cache_backup;
190	use strict;	270	};
191	use Crossfire::Protocol::Constants;
192
193	my $last_enter_count = 1;
194
195	sub desc_string {
196	my ($self) = @_;
197
198	my $desc =
199	$self->{nrof} < 2
200	? $self->{name}
201	: "$self->{nrof} × $self->{name_pl}";
202
203	$self->{flags} & F_OPEN
204	and $desc .= " (open)";
205	$self->{flags} & F_APPLIED
206	and $desc .= " (applied)";
207	$self->{flags} & F_UNPAID
208	and $desc .= " (unpaid)";
209	$self->{flags} & F_MAGIC
210	and $desc .= " (magic)";
211	$self->{flags} & F_CURSED
212	and $desc .= " (cursed)";
213	$self->{flags} & F_DAMNED
214	and $desc .= " (damned)";
215	$self->{flags} & F_LOCKED
216	and $desc .= " *";
217
218	$desc
219	}
220
221	sub weight_string {
222	my ($self) = @_;
223
224	my $weight = ($self->{nrof} \|\| 1) * $self->{weight};
225
226	$weight < 0 ? "?" : $weight * 0.001
227	}
228
229	sub do_n_dialog {
230	my ($cb) = @_;
231
232	my $w = new CFPlus::UI::Toplevel
233	on_delete => sub { $_[0]->destroy; 1 },
234	has_close_button => 1,
235	;
236
237	$w->add (my $vb = new CFPlus::UI::VBox x => "center", y => "center");
238	$vb->add (new CFPlus::UI::Label text => "Enter item count:");
239	$vb->add (my $entry = new CFPlus::UI::Entry
240	text => $last_enter_count,
241	on_activate => sub {
242	my ($entry) = @_;
243	$last_enter_count = $entry->get_text;
244	$cb->($last_enter_count);
245	$w->hide;
246	$w->destroy;
247
248	0
249	},
250	on_escape => sub { $w->destroy; 1 },
251	);
252	$entry->grab_focus;
253	$w->show;
254	}
255
256	sub update_widgets {
257	my ($self) = @_;
258
259	# necessary to avoid cyclic references
260	Scalar::Util::weaken $self;
261
262	my $button_cb = sub {
263	my (undef, $ev, $x, $y) = @_;
264
265	my $targ = $::CONN->{player}{tag};
266
267	if ($self->{container} == $::CONN->{player}{tag}) {
268	$targ = $::CONN->{open_container};
269	}
270
271	if (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 1) {
272	$::CONN->send ("move $targ $self->{tag} 0")
273	if $targ \|\| !($self->{flags} & F_LOCKED);
274	} elsif (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 2) {
275	$self->{flags} & F_LOCKED
276	? $::CONN->send ("lock " . pack "CN", 0, $self->{tag})
277	: $::CONN->send ("lock " . pack "CN", 1, $self->{tag})
278	} elsif ($ev->{button} == 1) {
279	$::CONN->send ("examine $self->{tag}");
280	} elsif ($ev->{button} == 2) {
281	$::CONN->send ("apply $self->{tag}");
282	} elsif ($ev->{button} == 3) {
283	my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
284	if ($self->{container} == $::CONN->{open_container}) {
285	$move_prefix = "take";
286	}
287
288	my @menu_items = (
289	["examine", sub { $::CONN->send ("examine $self->{tag}") }],
290	["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
291	["ignite/thaw", # first try of an easier use of flint&steel
292	sub {
293	$::CONN->send ("mark ". pack "N", $self->{tag});
294	$::CONN->send ("command apply flint and steel");
295	}
296	],
297	["inscribe", # first try of an easier use of flint&steel
298	sub {
299	&::open_string_query ("Text to inscribe", sub {
300	my ($entry, $txt) = @_;
301	$::CONN->send ("mark ". pack "N", $self->{tag});
302	$::CONN->send ("command use_skill inscription $txt");
303	});
304	}
305	],
306	["rename", # first try of an easier use of flint&steel
307	sub {
308	&::open_string_query ("Rename item to:", sub {
309	my ($entry, $txt) = @_;
310	$::CONN->send ("mark ". pack "N", $self->{tag});
311	$::CONN->send ("command rename to <$txt>");
312	}, $self->{name},
313	"If you input no name or erase the current custom name, the custom name will be unset");
314	}
315	],
316	["apply", sub { $::CONN->send ("apply $self->{tag}") }],
317	(
318	$self->{flags} & F_LOCKED
319	? (
320	["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
321	)
322	: (
323	["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
324	["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }],
325	["$move_prefix <n>",
326	sub {
327	do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
328	}
329	]
330	)
331	),
332	);
333
334	CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
335	}
336
337	1
338	};
339
340	my $tooltip_std = "<small>"
341	. "Left click - examine item\n"
342	. "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
343	. "Middle click - apply\n"
344	. "Shift-Middle click - lock/unlock\n"
345	. "Right click - further options"
346	. "</small>\n";
347
348	my $bg = $self->{flags} & F_CURSED ? [1 , 0 , 0, 0.5]
349	: $self->{flags} & F_MAGIC ? [0.2, 0.2, 1, 0.5]
350	: undef;
351
352	$self->{face_widget} \|\|= new CFPlus::UI::Face
353	can_events => 1,
354	can_hover => 1,
355	anim => $self->{anim},
356	animspeed => $self->{animspeed}, # TODO# must be set at creation time
357	on_button_down => $button_cb,
358	;
359	$self->{face_widget}{bg} = $bg;
360	$self->{face_widget}{face} = $self->{face};
361	$self->{face_widget}{anim} = $self->{anim};
362	$self->{face_widget}{animspeed} = $self->{animspeed};
363	$self->{face_widget}->set_tooltip (
364	"<b>Face/Animation.</b>\n"
365	. "Item uses face #$self->{face}. "
366	. ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
367	. "\n\n$tooltip_std"
368	);
369
370	$self->{desc_widget} \|\|= new CFPlus::UI::Label
371	can_events => 1,
372	can_hover => 1,
373	ellipsise => 2,
374	align => -1,
375	on_button_down => $button_cb,
376	;
377	my $desc = CFPlus::Item::desc_string $self;
378	$self->{desc_widget}{bg} = $bg;
379	$self->{desc_widget}->set_text ($desc);
380	$self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
381
382	$self->{weight_widget} \|\|= new CFPlus::UI::Label
383	can_events => 1,
384	can_hover => 1,
385	ellipsise => 0,
386	align => 0,
387	on_button_down => $button_cb,
388	;
389	$self->{weight_widget}{bg} = $bg;
390	$self->{weight_widget}->set_text (CFPlus::Item::weight_string $self);
391	$self->{weight_widget}->set_tooltip (
392	"<b>Weight</b>.\n"
393	. ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
394	. ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
395	. "\n\n$tooltip_std"
396	);
397	}
398		271
399	1;	272	1;
400		273
401	=back	274	=back
402		275

Diff Legend

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

Comparing deliantra/Deliantra-Client/DC.pm (file contents): Revision 1.121 by root, Fri Sep 29 00:56:05 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.121 by root, Fri Sep 29 00:56:05 2006 UTC vs.
Revision 1.191 by root, Wed Sep 3 06:07:39 2008 UTC