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

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.112 by root, Sun Aug 13 03:20:53 2006 UTC vs.
Revision 1.189 by root, Tue Sep 2 16:50:06 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;
		18
		19	use Carp ();
		20
		21	our $VERSION;
16		22
17	BEGIN {	23	BEGIN {
18	$VERSION = '0.2';	24	$VERSION = '0.9975';
19		25
20	use XSLoader;	26	use XSLoader;
21	XSLoader::load "CFPlus", $VERSION;	27	XSLoader::load "Deliantra::Client", $VERSION;
22	}	28	}
23		29
24	use utf8;	30	use utf8;
		31	use strict qw(vars subs);
25		32
26	use Carp ();
27	use AnyEvent ();	33	use AnyEvent ();
28	use BerkeleyDB;
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);
32		39
33	=item guard { BLOCK }	40	=item guard { BLOCK }
34		41
35	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.
36		43
37	=cut	44	=cut
38		45
39	sub guard(&) {	46	sub guard(&) {
40	bless \(my $cb = $_[0]), "CFPlus::Guard"	47	bless \(my $cb = $_[0]), "DC::Guard"
41	}	48	}
42		49
43	sub CFPlus::Guard::DESTROY {	50	sub DC::Guard::DESTROY {
44	${$_[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
45	}	62	}
46		63
47	sub asxml($) {	64	sub asxml($) {
48	local $_ = $_[0];	65	local $_ = $_[0];
49		66
52	s/</</g;	69	s/</</g;
53		70
54	$_	71	$_
55	}	72	}
56		73
57	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";
58		77
59	our @ISA = BerkeleyDB::Btree::;	78	($fh1, $fh2)
60
61	sub get($$) {
62	my $data;
63
64	$_[0]->db_get ($_[1], $data) == 0
65	? $data
66	: ()
67	}	79	}
68		80
69	my %DB_SYNC;	81	sub background(&;&) {
		82	my ($bg, $cb) = @_;
70		83
71	sub put($$$) {	84	my ($fh_r, $fh_w) = DC::socketpipe;
72	my ($db, $key, $data) = @_;
73		85
74	$DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });	86	my $pid = fork;
75		87
76	$db->db_put ($key => $data)	88	if (defined $pid && !$pid) {
77	}	89	local $SIG{__DIE__};
78		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	}
		136	});
		137	}
		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
79	package CFPlus;	148	package DC;
		149
		150	our @RC_THEME = ("theme-plain", ".");
		151	our $RC_BASE;
		152
		153	for (grep !ref, @INC) {
		154	$RC_BASE = "$_/Deliantra/Client/private/resources";
		155	last if -d $RC_BASE;
		156	}
80		157
81	sub find_rcfile($) {	158	sub find_rcfile($) {
82	my $path;	159	my $path;
83		160
84	for (grep !ref, @INC) {	161	for (@RC_THEME) {
85	$path = "$_/CFPlus/resources/$_[0]";	162	$path = "$RC_BASE/$_/$_[0]";
86	return $path if -r $path;	163	return $path if -r $path;
87	}	164	}
88		165
89	die "FATAL: can't find required file $_[0]\n";	166	die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
90	}
91
92	BEGIN {
93	use Crossfire::Protocol::Base ();
94	*to_json = \&Crossfire::Protocol::Base::to_json;
95	*from_json = \&Crossfire::Protocol::Base::from_json;
96	}	167	}
97		168
98	sub read_cfg {	169	sub read_cfg {
99	my ($file) = @_;	170	my ($file) = @_;
100		171
…		…
102	or return;	173	or return;
103		174
104	local $/;	175	local $/;
105	my $CFG = <$fh>;	176	my $CFG = <$fh>;
106		177
107	if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove
108	require YAML;
109	utf8::decode $CFG;
110	$::CFG = YAML::Load ($CFG);
111	} elsif ($CFG =~ /^\{/) {
112	$::CFG = from_json $CFG;	178	$::CFG = decode_json $CFG;
113	} else {
114	$::CFG = eval $CFG; ## todo comaptibility cruft
115	}
116	}	179	}
117		180
118	sub write_cfg {	181	sub write_cfg {
119	my ($file) = @_;	182	my $file = "$Deliantra::VARDIR/client.cf";
120		183
121	$::CFG->{VERSION} = $::VERSION;	184	$::CFG->{VERSION} = $::VERSION;
122		185
123	open my $fh, ">:utf8", $file	186	open my $fh, ">:utf8", $file
124	or return;	187	or return;
125	print $fh to_json $::CFG;	188	print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
126	}	189	}
127		190
128	our $DB_ENV;	191	sub http_proxy {
		192	my @proxy = win32_proxy_info;
129		193
130	{	194	if (@proxy) {
131	use strict;	195	"http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
132		196	} elsif (exists $ENV{http_proxy}) {
133	mkdir "$Crossfire::VARDIR/cfplus", 0777;	197	$ENV{http_proxy}
134	my $recover = $BerkeleyDB::db_version >= 4.4	198	} else {
135	? eval "DB_REGISTER \| DB_RECOVER"	199	()
136	: 0;	200	}
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	}	201	}
148		202
149	sub db_table($) {	203	sub set_proxy {
		204	my $proxy = http_proxy
		205	or return;
		206
		207	$ENV{http_proxy} = $proxy;
		208	}
		209
		210	sub lwp_useragent {
		211	require LWP::UserAgent;
		212
		213	DC::set_proxy;
		214
		215	my $ua = LWP::UserAgent->new (
		216	agent => "deliantra $VERSION",
		217	keep_alive => 1,
		218	env_proxy => 1,
		219	timeout => 30,
		220	);
		221	}
		222
		223	sub lwp_check($) {
150	my ($table) = @_;	224	my ($res) = @_;
151		225
152	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;	226	$res->is_error
		227	and die $res->status_line;
153		228
154	new CFPlus::Database	229	$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	}	230	}
163		231
		232	sub fh_nonblocking($$) {
		233	my ($fh, $nb) = @_;
		234
		235	if ($^O eq "MSWin32") {
		236	$nb = (! ! $nb) + 0;
		237	ioctl $fh, 0x8004667e, \$nb; # FIONBIO
		238	} else {
		239	fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
		240	}
		241	}
		242
164	package CFPlus::Layout;	243	package DC::Layout;
165		244
166	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {	245	$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
167	reset_glyph_cache;	246	glyph_cache_restore;
168	};	247	};
169		248
170	package CFPlus::Item;	249	$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
171		250	glyph_cache_backup;
172	use strict;	251	};
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::FancyFrame
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	["apply", sub { $::CONN->send ("apply $self->{tag}") }],
289	(
290	$self->{flags} & F_LOCKED
291	? (
292	["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
293	)
294	: (
295	["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
296	["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }],
297	["$move_prefix <n>",
298	sub {
299	do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
300	}
301	]
302	)
303	),
304	);
305
306	CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
307	}
308
309	1
310	};
311
312	my $tooltip_std = "<small>"
313	. "Left click - examine item\n"
314	. "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
315	. "Middle click - apply\n"
316	. "Shift-Middle click - lock/unlock\n"
317	. "Right click - further options"
318	. "</small>\n";
319
320	my $bg = $self->{flags} & F_CURSED ? [1 , 0 , 0, 0.5]
321	: $self->{flags} & F_MAGIC ? [0.2, 0.2, 1, 0.5]
322	: undef;
323
324	$self->{face_widget} \|\|= new CFPlus::UI::Face
325	can_events => 1,
326	can_hover => 1,
327	anim => $self->{anim},
328	animspeed => $self->{animspeed}, # TODO# must be set at creation time
329	on_button_down => $button_cb,
330	;
331	$self->{face_widget}{bg} = $bg;
332	$self->{face_widget}{face} = $self->{face};
333	$self->{face_widget}{anim} = $self->{anim};
334	$self->{face_widget}{animspeed} = $self->{animspeed};
335	$self->{face_widget}->set_tooltip (
336	"<b>Face/Animation.</b>\n"
337	. "Item uses face #$self->{face}. "
338	. ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
339	. "\n\n$tooltip_std"
340	);
341
342	$self->{desc_widget} \|\|= new CFPlus::UI::Label
343	can_events => 1,
344	can_hover => 1,
345	ellipsise => 2,
346	align => -1,
347	on_button_down => $button_cb,
348	;
349	my $desc = CFPlus::Item::desc_string $self;
350	$self->{desc_widget}{bg} = $bg;
351	$self->{desc_widget}->set_text ($desc);
352	$self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
353
354	$self->{weight_widget} \|\|= new CFPlus::UI::Label
355	can_events => 1,
356	can_hover => 1,
357	ellipsise => 0,
358	align => 0,
359	on_button_down => $button_cb,
360	;
361	$self->{weight_widget}{bg} = $bg;
362	$self->{weight_widget}->set_text (CFPlus::Item::weight_string $self);
363	$self->{weight_widget}->set_tooltip (
364	"<b>Weight</b>.\n"
365	. ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
366	. ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
367	. "\n\n$tooltip_std"
368	);
369	}
370		252
371	1;	253	1;
372		254
373	=back	255	=back
374		256

Diff Legend

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

Comparing deliantra/Deliantra-Client/DC.pm (file contents): Revision 1.112 by root, Sun Aug 13 03:20:53 2006 UTC vs. Revision 1.189 by root, Tue Sep 2 16:50:06 2008 UTC

Diff Legend

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.112 by root, Sun Aug 13 03:20:53 2006 UTC vs.
Revision 1.189 by root, Tue Sep 2 16:50:06 2008 UTC