[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.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;
		216	}
121		217
122	if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove	218	sub http_proxy {
123	require YAML;	219	my @proxy = win32_proxy_info;
124	utf8::decode $CFG;	220
125	$::CFG = YAML::Load ($CFG);	221	if (@proxy) {
126	} elsif ($CFG =~ /^\{/) {	222	"http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
127	$::CFG = from_json $CFG;	223	} elsif (exists $ENV{http_proxy}) {
		224	$ENV{http_proxy}
128	} else {	225	} else {
129	$::CFG = eval $CFG; ## todo comaptibility cruft	226	()
130	}	227	}
131	}	228	}
132		229
133	sub write_cfg {	230	sub set_proxy {
134	my ($file) = @_;	231	my $proxy = http_proxy
135
136	$::CFG->{VERSION} = $::VERSION;
137
138	open my $fh, ">:utf8", $file
139	or return;	232	or return;
140	print $fh to_json $::CFG;
141	}
142		233
143	our $DB_ENV;	234	$ENV{http_proxy} = $proxy;
144	our $DB_STATE;	235	}
145		236
146	sub db_table($) {	237	sub lwp_useragent {
		238	require LWP::UserAgent;
		239
		240	DC::set_proxy;
		241
		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($) {
147	my ($table) = @_;	251	my ($res) = @_;
148		252
149	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;	253	$res->is_error
		254	and die $res->status_line;
150		255
151	new CFPlus::Database	256	$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	}	257	}
160		258
161	{	259	sub fh_nonblocking($$) {
162	use strict;	260	my ($fh, $nb) = @_;
163		261
164	mkdir "$Crossfire::VARDIR/cfplus", 0777;	262	if ($^O eq "MSWin32") {
165	my $recover = $BerkeleyDB::db_version >= 4.4	263	$nb = (! ! $nb) + 0;
166	? eval "DB_REGISTER \| DB_RECOVER"	264	ioctl $fh, 0x8004667e, \$nb; # FIONBIO
167	: 0;	265	} else {
168		266	fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
169	$DB_ENV = new BerkeleyDB::Env	267	}
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	}	268	}
181		269
182	package CFPlus::Layout;	270	package DC::Layout;
183		271
184	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {	272	$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
185	reset_glyph_cache;	273	glyph_cache_restore;
186	};	274	};
187		275
188	package CFPlus::Item;	276	$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
189		277	glyph_cache_backup;
190	use strict;	278	};
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		279
399	1;	280	1;
400		281
401	=back	282	=back
402		283

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