[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.201 by root, Sun Jan 11 03:19:47 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		16
17	use Carp ();	17	use Carp ();
18		18
		19	our $VERSION;
		20
19	BEGIN {	21	BEGIN {
20	$VERSION = '0.52';	22	$VERSION = '2.02';
21		23
22	use XSLoader;	24	use XSLoader;
23	XSLoader::load "CFPlus", $VERSION;	25	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	}	26	}
34		27
35	use utf8;	28	use utf8;
		29	use strict qw(vars subs);
36		30
		31	use Socket ();
37	use AnyEvent ();	32	use AnyEvent ();
38	use BerkeleyDB;	33	use AnyEvent::Util ();
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 background(&;&) {
		75	my ($bg, $cb) = @_;
68		76
69	our @ISA = BerkeleyDB::Btree::;	77	my ($fh_r, $fh_w) = AnyEvent::Util::portable_socketpair
		78	or die "unable to create background socketpair: $!";
70		79
71	sub get($$) {	80	my $pid = fork;
72	my $data;
73		81
74	$_[0]->db_get ($_[1], $data) == 0	82	if (defined $pid && !$pid) {
75	? $data	83	local $SIG{__DIE__};
76	: ()
77	}
78		84
79	my %DB_SYNC;	85	open STDOUT, ">&", $fh_w;
		86	open STDERR, ">&", $fh_w;
		87	close $fh_r;
		88	close $fh_w;
80		89
81	sub put($$$) {	90	$\| = 1;
82	my ($db, $key, $data) = @_;
83		91
84	my $hkey = $db + 0;	92	eval { $bg->() };
85	Scalar::Util::weaken $db;	93
86	$DB_SYNC{$hkey} \|\|= AnyEvent->timer (after => 5, cb => sub {	94	if ($@) {
87	delete $DB_SYNC{$hkey};	95	my $msg = $@;
88	$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	}
89	});	130	});
90
91	$db->db_put ($key => $data)
92	}	131	}
93		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
94	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	}
95		153
96	sub find_rcfile($) {	154	sub find_rcfile($) {
97	my $path;	155	my $path;
98		156
99	for (grep !ref, @INC) {	157	for (@RC_PATH, "") {
100	$path = "$_/CFPlus/resources/$_[0]";	158	$path = "$RC_BASE/$_/$_[0]";
101	return $path if -r $path;	159	return $path if -r $path;
102	}	160	}
103		161
104	die "FATAL: can't find required file $_[0]\n";	162	die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
105	}	163	}
106		164
107	BEGIN {	165	sub load_json($) {
108	use Crossfire::Protocol::Base ();	166	my ($file) = @_;
109	*to_json = \&Crossfire::Protocol::Base::to_json;	167
110	*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	}
111	}	195	}
112		196
113	sub read_cfg {	197	sub read_cfg {
114	my ($file) = @_;	198	my ($file) = @_;
115		199
		200	$::CFG = (load_json $file) \|\| (load_json "$file.bak");
		201	}
		202
		203	sub write_cfg {
		204	my $file = "$Deliantra::VARDIR/client.cf";
		205
		206	$::CFG->{VERSION} = $::VERSION;
		207	$::CFG->{layout} = DC::UI::get_layout ();
		208
116	open my $fh, $file	209	open my $fh, ">:utf8", "$file~"
117	or return;	210	or return;
		211	print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
		212	close $fh;
118		213
119	local $/;	214	rename $file, "$file.bak";
120	my $CFG = <$fh>;	215	rename "$file~", $file;
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	}
132
133	sub write_cfg {
134	my ($file) = @_;
135
136	$::CFG->{VERSION} = $::VERSION;
137
138	open my $fh, ">:utf8", $file
139	or return;
140	print $fh to_json $::CFG;
141	}	216	}
142		217
143	sub http_proxy {	218	sub http_proxy {
144	my @proxy = win32_proxy_info;	219	my @proxy = win32_proxy_info;
145		220
…		…
157	or return;	232	or return;
158		233
159	$ENV{http_proxy} = $proxy;	234	$ENV{http_proxy} = $proxy;
160	}	235	}
161		236
162	our $DB_ENV;	237	sub lwp_useragent {
163	our $DB_STATE;	238	require LWP::UserAgent;
		239
		240	DC::set_proxy;
164		241
165	sub db_table($) {	242	my $ua = LWP::UserAgent->new (
		243	agent => "deliantra $VERSION",
		244	keep_alive => 1,
		245	env_proxy => 1,
		246	timeout => 30,
		247	);
		248	}
		249
		250	sub lwp_check($) {
166	my ($table) = @_;	251	my ($res) = @_;
167		252
168	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;	253	$res->is_error
		254	and die $res->status_line;
169		255
170	new CFPlus::Database	256	$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	}	257	}
179		258
180	{	259	sub fh_nonblocking($$) {
181	use strict;	260	my ($fh, $nb) = @_;
182		261
183	mkdir "$Crossfire::VARDIR/cfplus", 0777;	262	if ($^O eq "MSWin32") {
184	my $recover = $BerkeleyDB::db_version >= 4.4	263	$nb = (! ! $nb) + 0;
185	? eval "DB_REGISTER \| DB_RECOVER"	264	ioctl $fh, 0x8004667e, \$nb; # FIONBIO
186	: 0;	265	} else {
187		266	fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
188	$DB_ENV = new BerkeleyDB::Env	267	}
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	}	268	}
200		269
201	package CFPlus::Layout;	270	package DC::Layout;
202		271
203	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {	272	$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
204	reset_glyph_cache;	273	glyph_cache_restore;
205	};	274	};
206		275
207	package CFPlus::Item;	276	$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
208		277	glyph_cache_backup;
209	use strict;	278	};
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		279
418	1;	280	1;
419		281
420	=back	282	=back
421		283

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.201 by root, Sun Jan 11 03:19:47 2009 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.201 by root, Sun Jan 11 03:19:47 2009 UTC