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

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.122 by root, Sun Oct 1 14:48:50 2006 UTC vs.
Revision 1.193 by root, Fri Sep 5 15:24:10 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.9976';
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 load_json($) {
108	use Crossfire::Protocol::Base ();	172	my ($file) = @_;
109	*to_json = \&Crossfire::Protocol::Base::to_json;	173
110	*from_json = \&Crossfire::Protocol::Base::from_json;	174	open my $fh, $file
		175	or return;
		176
		177	local $/;
		178	JSON::XS->new->utf8->relaxed->decode (<$fh>)
		179	}
		180
		181	sub set_theme($) {
		182	return if $RC_THEME eq $_[0];
		183	$RC_THEME = $_[0];
		184
		185	# kind of hacky, find the main theme file, then load all theme files and merge them
		186
		187	%THEME = ();
		188	@RC_PATH = "theme-$RC_THEME";
		189
		190	my $theme = load_json find_rcfile "theme.json"
		191	or die "FATAL: theme resource file not found";
		192
		193	@RC_PATH = @{ $theme->{path} } if $theme->{path};
		194
		195	for (@RC_PATH, "") {
		196	my $theme = load_json "$RC_BASE/$_/theme.json"
		197	or next;
		198
		199	%THEME = ( %$theme, %THEME );
		200	}
111	}	201	}
112		202
113	sub read_cfg {	203	sub read_cfg {
114	my ($file) = @_;	204	my ($file) = @_;
115		205
116	open my $fh, $file	206	$::CFG = load_json $file;
117	or return;
118
119	local $/;
120	my $CFG = <$fh>;
121
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;
128	} else {
129	$::CFG = eval $CFG; ## todo comaptibility cruft
130	}
131	}	207	}
132		208
133	sub write_cfg {	209	sub write_cfg {
134	my ($file) = @_;	210	my $file = "$Deliantra::VARDIR/client.cf";
135		211
136	$::CFG->{VERSION} = $::VERSION;	212	$::CFG->{VERSION} = $::VERSION;
137		213
138	open my $fh, ">:utf8", $file	214	open my $fh, ">:utf8", $file
139	or return;	215	or return;
140	print $fh to_json $::CFG;	216	print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
141	}	217	}
142		218
143	sub http_proxy {	219	sub http_proxy {
144	my @proxy = win32_proxy_info;	220	my @proxy = win32_proxy_info;
145		221
…		…
157	or return;	233	or return;
158		234
159	$ENV{http_proxy} = $proxy;	235	$ENV{http_proxy} = $proxy;
160	}	236	}
161		237
162	our $DB_ENV;	238	sub lwp_useragent {
163	our $DB_STATE;	239	require LWP::UserAgent;
		240
		241	DC::set_proxy;
164		242
165	sub db_table($) {	243	my $ua = LWP::UserAgent->new (
		244	agent => "deliantra $VERSION",
		245	keep_alive => 1,
		246	env_proxy => 1,
		247	timeout => 30,
		248	);
		249	}
		250
		251	sub lwp_check($) {
166	my ($table) = @_;	252	my ($res) = @_;
167		253
168	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;	254	$res->is_error
		255	and die $res->status_line;
169		256
170	new CFPlus::Database	257	$res
171	-Env => $DB_ENV,
172	-Filename => $table,
173	# -Filename => "database",
174	# -Subname => $table,
175	-Property => DB_CHKSUM,
176	-Flags => DB_CREATE \| DB_UPGRADE,
177	or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
178	}	258	}
179		259
180	{	260	sub fh_nonblocking($$) {
181	use strict;	261	my ($fh, $nb) = @_;
182		262
183	mkdir "$Crossfire::VARDIR/cfplus", 0777;	263	if ($^O eq "MSWin32") {
184	my $recover = $BerkeleyDB::db_version >= 4.4	264	$nb = (! ! $nb) + 0;
185	? eval "DB_REGISTER \| DB_RECOVER"	265	ioctl $fh, 0x8004667e, \$nb; # FIONBIO
186	: 0;	266	} else {
187		267	fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
188	$DB_ENV = new BerkeleyDB::Env	268	}
189	-Home => "$Crossfire::VARDIR/cfplus",
190	-Cachesize => 1_000_000,
191	-ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
192	# -ErrPrefix => "DATABASE",
193	-Verbose => 1,
194	-Flags => DB_CREATE \| DB_RECOVER \| DB_INIT_MPOOL \| DB_INIT_LOCK \| DB_INIT_TXN \| $recover,
195	-SetFlags => DB_AUTO_COMMIT \| DB_LOG_AUTOREMOVE,
196	or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
197
198	$DB_STATE = db_table "state";
199	}	269	}
200		270
201	package CFPlus::Layout;	271	package DC::Layout;
202		272
203	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {	273	$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
204	reset_glyph_cache;	274	glyph_cache_restore;
205	};	275	};
206		276
207	package CFPlus::Item;	277	$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
208		278	glyph_cache_backup;
209	use strict;	279	};
210	use Crossfire::Protocol::Constants;
211
212	my $last_enter_count = 1;
213
214	sub desc_string {
215	my ($self) = @_;
216
217	my $desc =
218	$self->{nrof} < 2
219	? $self->{name}
220	: "$self->{nrof} × $self->{name_pl}";
221
222	$self->{flags} & F_OPEN
223	and $desc .= " (open)";
224	$self->{flags} & F_APPLIED
225	and $desc .= " (applied)";
226	$self->{flags} & F_UNPAID
227	and $desc .= " (unpaid)";
228	$self->{flags} & F_MAGIC
229	and $desc .= " (magic)";
230	$self->{flags} & F_CURSED
231	and $desc .= " (cursed)";
232	$self->{flags} & F_DAMNED
233	and $desc .= " (damned)";
234	$self->{flags} & F_LOCKED
235	and $desc .= " *";
236
237	$desc
238	}
239
240	sub weight_string {
241	my ($self) = @_;
242
243	my $weight = ($self->{nrof} \|\| 1) * $self->{weight};
244
245	$weight < 0 ? "?" : $weight * 0.001
246	}
247
248	sub do_n_dialog {
249	my ($cb) = @_;
250
251	my $w = new CFPlus::UI::Toplevel
252	on_delete => sub { $_[0]->destroy; 1 },
253	has_close_button => 1,
254	;
255
256	$w->add (my $vb = new CFPlus::UI::VBox x => "center", y => "center");
257	$vb->add (new CFPlus::UI::Label text => "Enter item count:");
258	$vb->add (my $entry = new CFPlus::UI::Entry
259	text => $last_enter_count,
260	on_activate => sub {
261	my ($entry) = @_;
262	$last_enter_count = $entry->get_text;
263	$cb->($last_enter_count);
264	$w->hide;
265	$w->destroy;
266
267	0
268	},
269	on_escape => sub { $w->destroy; 1 },
270	);
271	$entry->grab_focus;
272	$w->show;
273	}
274
275	sub update_widgets {
276	my ($self) = @_;
277
278	# necessary to avoid cyclic references
279	Scalar::Util::weaken $self;
280
281	my $button_cb = sub {
282	my (undef, $ev, $x, $y) = @_;
283
284	my $targ = $::CONN->{player}{tag};
285
286	if ($self->{container} == $::CONN->{player}{tag}) {
287	$targ = $::CONN->{open_container};
288	}
289
290	if (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 1) {
291	$::CONN->send ("move $targ $self->{tag} 0")
292	if $targ \|\| !($self->{flags} & F_LOCKED);
293	} elsif (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 2) {
294	$self->{flags} & F_LOCKED
295	? $::CONN->send ("lock " . pack "CN", 0, $self->{tag})
296	: $::CONN->send ("lock " . pack "CN", 1, $self->{tag})
297	} elsif ($ev->{button} == 1) {
298	$::CONN->send ("examine $self->{tag}");
299	} elsif ($ev->{button} == 2) {
300	$::CONN->send ("apply $self->{tag}");
301	} elsif ($ev->{button} == 3) {
302	my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
303	if ($self->{container} == $::CONN->{open_container}) {
304	$move_prefix = "take";
305	}
306
307	my @menu_items = (
308	["examine", sub { $::CONN->send ("examine $self->{tag}") }],
309	["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
310	["ignite/thaw", # first try of an easier use of flint&steel
311	sub {
312	$::CONN->send ("mark ". pack "N", $self->{tag});
313	$::CONN->send ("command apply flint and steel");
314	}
315	],
316	["inscribe", # first try of an easier use of flint&steel
317	sub {
318	&::open_string_query ("Text to inscribe", sub {
319	my ($entry, $txt) = @_;
320	$::CONN->send ("mark ". pack "N", $self->{tag});
321	$::CONN->send ("command use_skill inscription $txt");
322	});
323	}
324	],
325	["rename", # first try of an easier use of flint&steel
326	sub {
327	&::open_string_query ("Rename item to:", sub {
328	my ($entry, $txt) = @_;
329	$::CONN->send ("mark ". pack "N", $self->{tag});
330	$::CONN->send ("command rename to <$txt>");
331	}, $self->{name},
332	"If you input no name or erase the current custom name, the custom name will be unset");
333	}
334	],
335	["apply", sub { $::CONN->send ("apply $self->{tag}") }],
336	(
337	$self->{flags} & F_LOCKED
338	? (
339	["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
340	)
341	: (
342	["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
343	["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }],
344	["$move_prefix <n>",
345	sub {
346	do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
347	}
348	]
349	)
350	),
351	);
352
353	CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
354	}
355
356	1
357	};
358
359	my $tooltip_std = "<small>"
360	. "Left click - examine item\n"
361	. "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
362	. "Middle click - apply\n"
363	. "Shift-Middle click - lock/unlock\n"
364	. "Right click - further options"
365	. "</small>\n";
366
367	my $bg = $self->{flags} & F_CURSED ? [1 , 0 , 0, 0.5]
368	: $self->{flags} & F_MAGIC ? [0.2, 0.2, 1, 0.5]
369	: undef;
370
371	$self->{face_widget} \|\|= new CFPlus::UI::Face
372	can_events => 1,
373	can_hover => 1,
374	anim => $self->{anim},
375	animspeed => $self->{animspeed}, # TODO# must be set at creation time
376	on_button_down => $button_cb,
377	;
378	$self->{face_widget}{bg} = $bg;
379	$self->{face_widget}{face} = $self->{face};
380	$self->{face_widget}{anim} = $self->{anim};
381	$self->{face_widget}{animspeed} = $self->{animspeed};
382	$self->{face_widget}->set_tooltip (
383	"<b>Face/Animation.</b>\n"
384	. "Item uses face #$self->{face}. "
385	. ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
386	. "\n\n$tooltip_std"
387	);
388
389	$self->{desc_widget} \|\|= new CFPlus::UI::Label
390	can_events => 1,
391	can_hover => 1,
392	ellipsise => 2,
393	align => -1,
394	on_button_down => $button_cb,
395	;
396	my $desc = CFPlus::Item::desc_string $self;
397	$self->{desc_widget}{bg} = $bg;
398	$self->{desc_widget}->set_text ($desc);
399	$self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
400
401	$self->{weight_widget} \|\|= new CFPlus::UI::Label
402	can_events => 1,
403	can_hover => 1,
404	ellipsise => 0,
405	align => 0,
406	on_button_down => $button_cb,
407	;
408	$self->{weight_widget}{bg} = $bg;
409	$self->{weight_widget}->set_text (CFPlus::Item::weight_string $self);
410	$self->{weight_widget}->set_tooltip (
411	"<b>Weight</b>.\n"
412	. ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
413	. ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
414	. "\n\n$tooltip_std"
415	);
416	}
417		280
418	1;	281	1;
419		282
420	=back	283	=back
421		284

Diff Legend

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

Comparing deliantra/Deliantra-Client/DC.pm (file contents): Revision 1.122 by root, Sun Oct 1 14:48:50 2006 UTC vs. Revision 1.193 by root, Fri Sep 5 15:24:10 2008 UTC

Diff Legend

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.122 by root, Sun Oct 1 14:48:50 2006 UTC vs.
Revision 1.193 by root, Fri Sep 5 15:24:10 2008 UTC