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

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

Diff Legend

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

Comparing deliantra/Deliantra-Client/DC.pm (file contents): Revision 1.114 by elmex, Mon Aug 14 04:34:40 2006 UTC vs. Revision 1.213 by root, Sat Jan 7 15:24:41 2012 UTC

Diff Legend

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.114 by elmex, Mon Aug 14 04:34:40 2006 UTC vs.
Revision 1.213 by root, Sat Jan 7 15:24:41 2012 UTC