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

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.110 by root, Sun Jul 30 17:43:26 2006 UTC vs.
Revision 1.135 by root, Thu Dec 7 15:57:13 2006 UTC

…		…
12		12
13	=cut	13	=cut
14		14
15	package CFPlus;	15	package CFPlus;
16		16
		17	use Carp ();
		18
17	BEGIN {	19	BEGIN {
18	$VERSION = '0.1';	20	$VERSION = '0.97';
19		21
20	use XSLoader;	22	use XSLoader;
21	XSLoader::load "CFPlus", $VERSION;	23	XSLoader::load "CFPlus", $VERSION;
22	}	24	}
23		25
24	use utf8;	26	use utf8;
25		27
26	use Carp ();
27	use AnyEvent ();	28	use AnyEvent ();
28	use BerkeleyDB;	29	use BerkeleyDB;
29	use Pod::POM ();	30	use Pod::POM ();
30	use Scalar::Util ();	31	use Scalar::Util ();
		32	use File::Path ();
31	use Storable (); # finally	33	use Storable (); # finally
32		34
33	our %STAT_TOOLTIP = (	35	BEGIN {
34	Str => "<b>Physical Strength</b>, determines damage dealt with weapons, how much you can carry, and how often you can attack",	36	use Crossfire::Protocol::Base ();
35	Dex => "<b>Dexterity</b>, your physical agility. Determines chance of being hit and affects armor class and speed",	37	*to_json = \&Crossfire::Protocol::Base::to_json;
36	Con => "<b>Constitution</b>, physical health and toughness. Determines how many healthpoints you can have",	38	*from_json = \&Crossfire::Protocol::Base::from_json;
37	Int => "<b>Intelligence</b>, your ability to learn and use skills and incantations (both prayers and magic) and determines how much spell points you can have",	39	}
38	Wis => "<b>Wisdom</b>, the ability to learn and use divine magic (prayers). Determines how many grace points you can have",
39	Pow => "<b>Power</b>, your magical potential. Influences the strength of spell effects, and also how much your spell and grace points increase when leveling up",
40	Cha => "<b>Charisma</b>, how well you are received by NPCs. Affects buying and selling prices in shops.",
41
42	Wc => "<b>Weapon Class</b>, effectiveness of melee/missile attacks. Lower is more potent. Current weapon, level and Str are some things which effect the value of Wc. The value of Wc may range between 25 and -72.",
43	Ac => "<b>Armour Class</b>, how protected you are from being hit by any attack. Lower values are better. Ac is based on your race and is modified by the Dex and current armour worn. For characters that cannot wear armour, Ac improves as their level increases.",
44	Dam => "<b>Damage</b>, how much damage your melee/missile attack inflicts. Higher values indicate a greater amount of damage will be inflicted with each attack.",
45	Arm => "<b>Armour</b>, how much damage (from physical attacks) will be subtracted from successful hits made upon you. This value ranges between 0 to 99%. Current armour worn primarily determines Arm value. This is the same as the physical resistance.",
46	Spd => "<b>Speed</b>, how fast you can move. The value of speed may range between nearly 0 (\"very slow\") to higher than 5 (\"lightning fast\"). Base speed is determined from the Dex and modified downward proportionally by the amount of weight carried which exceeds the Max Carry limit. The armour worn also sets the upper limit on speed.",
47	WSp => "<b>Weapon Speed</b>, how many attacks you may make per unit of time (0.120s). Higher values indicate faster attack speed. Current weapon and Dex effect the value of weapon speed.",
48	);
49		40
50	=item guard { BLOCK }	41	=item guard { BLOCK }
51		42
52	Returns an object that executes the given block as soon as it is destroyed.	43	Returns an object that executes the given block as soon as it is destroyed.
53		44
…		…
57	bless \(my $cb = $_[0]), "CFPlus::Guard"	48	bless \(my $cb = $_[0]), "CFPlus::Guard"
58	}	49	}
59		50
60	sub CFPlus::Guard::DESTROY {	51	sub CFPlus::Guard::DESTROY {
61	${$_[0]}->()	52	${$_[0]}->()
		53	}
		54
		55	=item shorten $string[, $maxlength]
		56
		57	=cut
		58
		59	sub shorten($;$) {
		60	my ($str, $len) = @_;
		61	substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
		62	$str
62	}	63	}
63		64
64	sub asxml($) {	65	sub asxml($) {
65	local $_ = $_[0];	66	local $_ = $_[0];
66		67
…		…
69	s/</</g;	70	s/</</g;
70		71
71	$_	72	$_
72	}	73	}
73		74
		75	sub socketpipe() {
		76	socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
		77	or die "cannot establish bidiretcional pipe: $!\n";
		78
		79	($fh1, $fh2)
		80	}
		81
		82	sub background(&;&) {
		83	my ($bg, $cb) = @_;
		84
		85	my ($fh_r, $fh_w) = CFPlus::socketpipe;
		86
		87	my $pid = fork;
		88
		89	if (defined $pid && !$pid) {
		90	local $SIG{__DIE__};
		91
		92	open STDOUT, ">&", $fh_w;
		93	open STDERR, ">&", $fh_w;
		94	close $fh_r;
		95	close $fh_w;
		96
		97	$\| = 1;
		98
		99	eval { $bg->() };
		100
		101	if ($@) {
		102	my $msg = $@;
		103	$msg =~ s/\n+/\n/;
		104	warn "FATAL: $msg";
		105	CFPlus::_exit 1;
		106	}
		107
		108	# win32 is fucked up, of course. exit will clean stuff up,
		109	# which destroys our database etc. _exit will exit ALL
		110	# forked processes, because of the dreaded fork emulation.
		111	CFPlus::_exit 0;
		112	}
		113
		114	close $fh_w;
		115
		116	my $buffer;
		117
		118	my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
		119	unless (sysread $fh_r, $buffer, 4096, length $buffer) {
		120	undef $w;
		121	$cb->();
		122	return;
		123	}
		124
		125	while ($buffer =~ s/^(.*)\n//) {
		126	my $line = $1;
		127	$line =~ s/\s+$//;
		128	utf8::decode $line;
		129	if ($line =~ /^\x{e877}json_msg (.*)$/s) {
		130	$cb->(from_json $1);
		131	} else {
		132	::message ({
		133	markup => "background($pid): " . CFPlus::asxml $line,
		134	});
		135	}
		136	}
		137	});
		138	}
		139
		140	sub background_msg {
		141	my ($msg) = @_;
		142
		143	$msg = "\x{e877}json_msg " . to_json $msg;
		144	$msg =~ s/\n//g;
		145	utf8::encode $msg;
		146	print $msg, "\n";
		147	}
		148
74	package CFPlus::Database;	149	package CFPlus::Database;
75		150
76	our @ISA = BerkeleyDB::Btree::;	151	our @ISA = BerkeleyDB::Btree::;
77		152
78	sub get($$) {	153	sub get($$) {
…		…
86	my %DB_SYNC;	161	my %DB_SYNC;
87		162
88	sub put($$$) {	163	sub put($$$) {
89	my ($db, $key, $data) = @_;	164	my ($db, $key, $data) = @_;
90		165
		166	my $hkey = $db + 0;
		167	Scalar::Util::weaken $db;
91	$DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });	168	$DB_SYNC{$hkey} \|\|= AnyEvent->timer (after => 5, cb => sub {
		169	delete $DB_SYNC{$hkey};
		170	$db->db_sync if $db;
		171	});
92		172
93	$db->db_put ($key => $data)	173	$db->db_put ($key => $data)
94	}	174	}
95		175
96	package CFPlus;	176	package CFPlus;
…		…
102	$path = "$_/CFPlus/resources/$_[0]";	182	$path = "$_/CFPlus/resources/$_[0]";
103	return $path if -r $path;	183	return $path if -r $path;
104	}	184	}
105		185
106	die "FATAL: can't find required file $_[0]\n";	186	die "FATAL: can't find required file $_[0]\n";
107	}
108
109	BEGIN {
110	use Crossfire::Protocol::Base ();
111	*to_json = \&Crossfire::Protocol::Base::to_json;
112	*from_json = \&Crossfire::Protocol::Base::from_json;
113	}	187	}
114		188
115	sub read_cfg {	189	sub read_cfg {
116	my ($file) = @_;	190	my ($file) = @_;
117		191
…		…
140	open my $fh, ">:utf8", $file	214	open my $fh, ">:utf8", $file
141	or return;	215	or return;
142	print $fh to_json $::CFG;	216	print $fh to_json $::CFG;
143	}	217	}
144		218
		219	sub http_proxy {
		220	my @proxy = win32_proxy_info;
		221
		222	if (@proxy) {
		223	"http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
		224	} elsif (exists $ENV{http_proxy}) {
		225	$ENV{http_proxy}
		226	} else {
		227	()
		228	}
		229	}
		230
		231	sub set_proxy {
		232	my $proxy = http_proxy
		233	or return;
		234
		235	$ENV{http_proxy} = $proxy;
		236	}
		237
		238	sub lwp_useragent {
		239	require LWP::UserAgent;
		240
		241	CFPlus::set_proxy;
		242
		243	my $ua = LWP::UserAgent->new (
		244	agent => "cfplus $VERSION",
		245	keep_alive => 1,
		246	env_proxy => 1,
		247	timeout => 30,
		248	);
		249	}
		250
		251	sub lwp_check($) {
		252	my ($res) = @_;
		253
		254	$res->is_error
		255	and die $res->status_line;
		256
		257	$res
		258	}
		259
145	our $DB_ENV;	260	our $DB_ENV;
146		261	our $DB_STATE;
147	{
148	use strict;
149
150	mkdir "$Crossfire::VARDIR/cfplus", 0777;
151	my $recover = $BerkeleyDB::db_version >= 4.4
152	? eval "DB_REGISTER \| DB_RECOVER"
153	: 0;
154
155	$DB_ENV = new BerkeleyDB::Env
156	-Home => "$Crossfire::VARDIR/cfplus",
157	-Cachesize => 1_000_000,
158	-ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
159	# -ErrPrefix => "DATABASE",
160	-Verbose => 1,
161	-Flags => DB_CREATE \| DB_RECOVER \| DB_INIT_MPOOL \| DB_INIT_LOCK \| DB_INIT_TXN \| $recover,
162	-SetFlags => DB_AUTO_COMMIT \| DB_LOG_AUTOREMOVE,
163	or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
164	}
165		262
166	sub db_table($) {	263	sub db_table($) {
167	my ($table) = @_;	264	my ($table) = @_;
168		265
169	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;	266	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
…		…
174	# -Filename => "database",	271	# -Filename => "database",
175	# -Subname => $table,	272	# -Subname => $table,
176	-Property => DB_CHKSUM,	273	-Property => DB_CHKSUM,
177	-Flags => DB_CREATE \| DB_UPGRADE,	274	-Flags => DB_CREATE \| DB_UPGRADE,
178	or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"	275	or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
		276	}
		277
		278	our $DB_HOME = "$Crossfire::VARDIR/cfplus";
		279
		280	sub open_db {
		281	use strict;
		282
		283	mkdir $DB_HOME, 0777;
		284	my $recover = $BerkeleyDB::db_version >= 4.4
		285	? eval "DB_REGISTER \| DB_RECOVER"
		286	: 0;
		287
		288	$DB_ENV = new BerkeleyDB::Env
		289	-Home => $DB_HOME,
		290	-Cachesize => 1_000_000,
		291	-ErrFile => "$DB_HOME/errorlog.txt",
		292	# -ErrPrefix => "DATABASE",
		293	-Verbose => 1,
		294	-Flags => DB_CREATE \| DB_RECOVER \| DB_INIT_MPOOL \| DB_INIT_LOCK \| DB_INIT_TXN \| $recover,
		295	-SetFlags => DB_AUTO_COMMIT \| DB_LOG_AUTOREMOVE,
		296	or die "unable to create/open database home $DB_HOME: $BerkeleyDB::Error";
		297
		298	$DB_STATE = db_table "state";
		299
		300	1
		301	}
		302
		303	unless (eval { open_db }) {
		304	File::Path::rmtree $DB_HOME;
		305	open_db;
179	}	306	}
180		307
181	package CFPlus::Layout;	308	package CFPlus::Layout;
182		309
183	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {	310	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {
…		…
226	}	353	}
227		354
228	sub do_n_dialog {	355	sub do_n_dialog {
229	my ($cb) = @_;	356	my ($cb) = @_;
230		357
231	my $w = new CFPlus::UI::FancyFrame	358	my $w = new CFPlus::UI::Toplevel
232	on_delete => sub { $_[0]->destroy; 1 },	359	on_delete => sub { $_[0]->destroy; 1 },
233	has_close_button => 1,	360	has_close_button => 1,
234	;	361	;
235		362
236	$w->add (my $vb = new CFPlus::UI::VBox x => "center", y => "center");	363	$w->add (my $vb = new CFPlus::UI::VBox x => "center", y => "center");
…		…
281	} elsif ($ev->{button} == 3) {	408	} elsif ($ev->{button} == 3) {
282	my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';	409	my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
283	if ($self->{container} == $::CONN->{open_container}) {	410	if ($self->{container} == $::CONN->{open_container}) {
284	$move_prefix = "take";	411	$move_prefix = "take";
285	}	412	}
		413
		414	my $shortname = CFPlus::shorten $self->{name}, 14;
286		415
287	my @menu_items = (	416	my @menu_items = (
288	["examine", sub { $::CONN->send ("examine $self->{tag}") }],	417	["examine", sub { $::CONN->send ("examine $self->{tag}") }],
289	["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],	418	["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
290	["ignite/thaw", # first try of an easier use of flint&steel	419	["ignite/thaw", # first try of an easier use of flint&steel
…		…
300	$::CONN->send ("mark ". pack "N", $self->{tag});	429	$::CONN->send ("mark ". pack "N", $self->{tag});
301	$::CONN->send ("command use_skill inscription $txt");	430	$::CONN->send ("command use_skill inscription $txt");
302	});	431	});
303	}	432	}
304	],	433	],
		434	["rename", # first try of an easier use of flint&steel
		435	sub {
		436	&::open_string_query ("Rename item to:", sub {
		437	my ($entry, $txt) = @_;
		438	$::CONN->send ("mark ". pack "N", $self->{tag});
		439	$::CONN->send ("command rename to <$txt>");
		440	}, $self->{name},
		441	"If you input no name or erase the current custom name, the custom name will be unset");
		442	}
		443	],
305	["apply", sub { $::CONN->send ("apply $self->{tag}") }],	444	["apply", sub { $::CONN->send ("apply $self->{tag}") }],
306	(	445	(
307	$self->{flags} & F_LOCKED	446	$self->{flags} & F_LOCKED
308	? (	447	? (
309	["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],	448	["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
…		…
316	do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })	455	do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
317	}	456	}
318	]	457	]
319	)	458	)
320	),	459	),
		460	["bind <i>apply $shortname</i> to a key" => sub { $::BIND_EDITOR->do_quick_binding (["apply $self->{name}"]) }],
321	);	461	);
322		462
323	CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);	463	CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
324	}	464	}
325		465

Diff Legend

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

Comparing deliantra/Deliantra-Client/DC.pm (file contents): Revision 1.110 by root, Sun Jul 30 17:43:26 2006 UTC vs. Revision 1.135 by root, Thu Dec 7 15:57:13 2006 UTC

Diff Legend

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.110 by root, Sun Jul 30 17:43:26 2006 UTC vs.
Revision 1.135 by root, Thu Dec 7 15:57:13 2006 UTC