[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.212 by root, Wed Jan 4 11:23:23 2012 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.11';
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);
		39	use Guard qw(guard);
42		40
43	=item guard { BLOCK }	41	# modules to support other DC::* packages
		42	use List::Util ();
		43	use IO::AIO ();
		44	use Coro::AIO ();
		45	use AnyEvent::AIO ();
44		46
45	Returns an object that executes the given block as soon as it is destroyed.	47	=item shorten $string[, $maxlength]
46		48
47	=cut	49	=cut
48		50
49	sub guard(&) {	51	sub shorten($;$) {
50	bless \(my $cb = $_[0]), "CFPlus::Guard"	52	my ($str, $len) = @_;
51	}	53	substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
52		54	$str
53	sub CFPlus::Guard::DESTROY {
54	${$_[0]}->()
55	}	55	}
56		56
57	sub asxml($) {	57	sub asxml($) {
58	local $_ = $_[0];	58	local $_ = $_[0];
59		59
62	s/</</g;	62	s/</</g;
63		63
64	$_	64	$_
65	}	65	}
66		66
67	package CFPlus::Database;	67	sub background(&;&) {
		68	my ($bg, $cb) = @_;
68		69
69	our @ISA = BerkeleyDB::Btree::;	70	my ($fh_r, $fh_w) = AnyEvent::Util::portable_socketpair
		71	or die "unable to create background socketpair: $!";
70		72
71	sub get($$) {	73	my $pid = fork;
72	my $data;
73		74
74	$_[0]->db_get ($_[1], $data) == 0	75	if (defined $pid && !$pid) {
75	? $data	76	local $SIG{__DIE__};
76	: ()
77	}
78		77
79	my %DB_SYNC;	78	open STDOUT, ">&", $fh_w;
		79	open STDERR, ">&", $fh_w;
		80	close $fh_r;
		81	close $fh_w;
80		82
81	sub put($$$) {	83	$\| = 1;
82	my ($db, $key, $data) = @_;
83		84
84	my $hkey = $db + 0;	85	eval { $bg->() };
85	Scalar::Util::weaken $db;	86
86	$DB_SYNC{$hkey} \|\|= AnyEvent->timer (after => 5, cb => sub {	87	if ($@) {
87	delete $DB_SYNC{$hkey};	88	my $msg = $@;
88	$db->db_sync if $db;	89	$msg =~ s/\n+/\n/;
		90	warn "FATAL: $msg";
		91	DC::_exit 1;
		92	}
		93
		94	# win32 is fucked up, of course. exit will clean stuff up,
		95	# which destroys our database etc. _exit will exit ALL
		96	# forked processes, because of the dreaded fork emulation.
		97	DC::_exit 0;
		98	}
		99
		100	close $fh_w;
		101
		102	my $buffer;
		103
		104	my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
		105	unless (sysread $fh_r, $buffer, 4096, length $buffer) {
		106	undef $w;
		107	$cb->();
		108	return;
		109	}
		110
		111	while ($buffer =~ s/^(.*)\n//) {
		112	my $line = $1;
		113	$line =~ s/\s+$//;
		114	utf8::decode $line;
		115	if ($line =~ /^\x{e877}json_msg (.*)$/s) {
		116	$cb->(JSON::XS->new->allow_nonref->decode ($1));
		117	} else {
		118	::message ({
		119	markup => "background($pid): " . DC::asxml $line,
		120	});
		121	}
		122	}
89	});	123	});
90
91	$db->db_put ($key => $data)
92	}	124	}
93		125
		126	sub background_msg {
		127	my ($msg) = @_;
		128
		129	$msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
		130	$msg =~ s/\n//g;
		131	utf8::encode $msg;
		132	print $msg, "\n";
		133	}
		134
94	package CFPlus;	135	package DC;
		136
		137	our $RC_THEME;
		138	our %THEME;
		139	our @RC_PATH;
		140	our $RC_BASE;
		141
		142	for (grep !ref, @INC) {
		143	$RC_BASE = "$_/Deliantra/Client/private/resources";
		144	last if -d $RC_BASE;
		145	}
95		146
96	sub find_rcfile($) {	147	sub find_rcfile($) {
97	my $path;	148	my $path;
98		149
99	for (grep !ref, @INC) {	150	for (@RC_PATH, "") {
100	$path = "$_/CFPlus/resources/$_[0]";	151	$path = "$RC_BASE/$_/$_[0]";
101	return $path if -r $path;	152	return $path if -e $path;
102	}	153	}
103		154
104	die "FATAL: can't find required file $_[0]\n";	155	die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
105	}	156	}
106		157
107	BEGIN {	158	sub load_json($) {
108	use Crossfire::Protocol::Base ();	159	my ($file) = @_;
109	*to_json = \&Crossfire::Protocol::Base::to_json;	160
110	*from_json = \&Crossfire::Protocol::Base::from_json;	161	open my $fh, $file
		162	or return;
		163
		164	local $/;
		165	eval { JSON::XS->new->utf8->relaxed->decode (<$fh>) }
		166	}
		167
		168	sub set_theme($) {
		169	return if $RC_THEME eq $_[0];
		170	$RC_THEME = $_[0];
		171
		172	# kind of hacky, find the main theme file, then load all theme files and merge them
		173
		174	%THEME = ();
		175	@RC_PATH = "theme-$RC_THEME";
		176
		177	my $theme = load_json find_rcfile "theme.json"
		178	or die "FATAL: theme resource file not found";
		179
		180	@RC_PATH = @{ $theme->{path} } if $theme->{path};
		181
		182	for (@RC_PATH, "") {
		183	my $theme = load_json "$RC_BASE/$_/theme.json"
		184	or next;
		185
		186	%THEME = ( %$theme, %THEME );
		187	}
111	}	188	}
112		189
113	sub read_cfg {	190	sub read_cfg {
114	my ($file) = @_;	191	my ($file) = @_;
115		192
		193	$::CFG = (load_json $file) \|\| (load_json "$file.bak");
		194	}
		195
		196	sub write_cfg {
		197	my $file = "$Deliantra::VARDIR/client.cf";
		198
		199	$::CFG->{VERSION} = $::VERSION;
		200	$::CFG->{layout} = DC::UI::get_layout ();
		201
116	open my $fh, $file	202	open my $fh, ">:utf8", "$file~"
117	or return;	203	or return;
		204	print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
		205	close $fh;
118		206
119	local $/;	207	rename $file, "$file.bak";
120	my $CFG = <$fh>;	208	rename "$file~", $file;
		209	}
121		210
122	if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove	211	sub http_proxy {
123	require YAML;	212	my @proxy = win32_proxy_info;
124	utf8::decode $CFG;	213
125	$::CFG = YAML::Load ($CFG);	214	if (@proxy) {
126	} elsif ($CFG =~ /^\{/) {	215	"http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
127	$::CFG = from_json $CFG;	216	} elsif (exists $ENV{http_proxy}) {
		217	$ENV{http_proxy}
128	} else {	218	} else {
129	$::CFG = eval $CFG; ## todo comaptibility cruft	219	()
130	}	220	}
131	}	221	}
132		222
133	sub write_cfg {	223	sub set_proxy {
134	my ($file) = @_;	224	my $proxy = http_proxy
135
136	$::CFG->{VERSION} = $::VERSION;
137
138	open my $fh, ">:utf8", $file
139	or return;	225	or return;
140	print $fh to_json $::CFG;
141	}
142		226
143	our $DB_ENV;	227	$ENV{http_proxy} = $proxy;
144	our $DB_STATE;	228	}
145		229
146	sub db_table($) {	230	sub lwp_useragent {
		231	require LWP::UserAgent;
		232
		233	DC::set_proxy;
		234
		235	my $ua = LWP::UserAgent->new (
		236	agent => "deliantra $VERSION",
		237	keep_alive => 1,
		238	env_proxy => 1,
		239	timeout => 30,
		240	);
		241	}
		242
		243	sub lwp_check($) {
147	my ($table) = @_;	244	my ($res) = @_;
148		245
149	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;	246	$res->is_error
		247	and die $res->status_line;
150		248
151	new CFPlus::Database	249	$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	}	250	}
160		251
161	{	252	sub fh_nonblocking($$) {
162	use strict;	253	my ($fh, $nb) = @_;
163		254
164	mkdir "$Crossfire::VARDIR/cfplus", 0777;	255	if ($^O eq "MSWin32") {
165	my $recover = $BerkeleyDB::db_version >= 4.4	256	$nb = (! ! $nb) + 0;
166	? eval "DB_REGISTER \| DB_RECOVER"	257	ioctl $fh, 0x8004667e, \$nb; # FIONBIO
167	: 0;	258	} else {
168		259	fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
169	$DB_ENV = new BerkeleyDB::Env	260	}
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	}	261	}
181		262
182	package CFPlus::Layout;	263	package DC::Layout;
183		264
184	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {	265	$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
185	reset_glyph_cache;	266	glyph_cache_restore;
186	};	267	};
187		268
188	package CFPlus::Item;	269	$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
189		270	glyph_cache_backup;
190	use strict;	271	};
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		272
399	1;	273	1;
400		274
401	=back	275	=back
402		276

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.212 by root, Wed Jan 4 11:23:23 2012 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.212 by root, Wed Jan 4 11:23:23 2012 UTC