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

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.109 by elmex, Sun Jul 30 13:40:17 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 ();
31	use JSON::Syck ();	32	use File::Path ();
32	use Storable (); # finally	33	use Storable (); # finally
33		34
34	our %STAT_TOOLTIP = (	35	BEGIN {
35	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 ();
36	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;
37	Con => "<b>Constitution</b>, physical health and toughness. Determines how many healthpoints you can have",	38	*from_json = \&Crossfire::Protocol::Base::from_json;
38	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	}
39	Wis => "<b>Wisdom</b>, the ability to learn and use divine magic (prayers). Determines how many grace points you can have",
40	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",
41	Cha => "<b>Charisma</b>, how well you are received by NPCs. Affects buying and selling prices in shops.",
42
43	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.",
44	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.",
45	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.",
46	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.",
47	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.",
48	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.",
49	);
50		40
51	=item guard { BLOCK }	41	=item guard { BLOCK }
52		42
53	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.
54		44
…		…
58	bless \(my $cb = $_[0]), "CFPlus::Guard"	48	bless \(my $cb = $_[0]), "CFPlus::Guard"
59	}	49	}
60		50
61	sub CFPlus::Guard::DESTROY {	51	sub CFPlus::Guard::DESTROY {
62	${$_[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
63	}	63	}
64		64
65	sub asxml($) {	65	sub asxml($) {
66	local $_ = $_[0];	66	local $_ = $_[0];
67		67
…		…
70	s/</</g;	70	s/</</g;
71		71
72	$_	72	$_
73	}	73	}
74		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
75	package CFPlus::Database;	149	package CFPlus::Database;
76		150
77	our @ISA = BerkeleyDB::Btree::;	151	our @ISA = BerkeleyDB::Btree::;
78		152
79	sub get($$) {	153	sub get($$) {
…		…
87	my %DB_SYNC;	161	my %DB_SYNC;
88		162
89	sub put($$$) {	163	sub put($$$) {
90	my ($db, $key, $data) = @_;	164	my ($db, $key, $data) = @_;
91		165
		166	my $hkey = $db + 0;
		167	Scalar::Util::weaken $db;
92	$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	});
93		172
94	$db->db_put ($key => $data)	173	$db->db_put ($key => $data)
95	}	174	}
96		175
97	package CFPlus;	176	package CFPlus;
…		…
103	$path = "$_/CFPlus/resources/$_[0]";	182	$path = "$_/CFPlus/resources/$_[0]";
104	return $path if -r $path;	183	return $path if -r $path;
105	}	184	}
106		185
107	die "FATAL: can't find required file $_[0]\n";	186	die "FATAL: can't find required file $_[0]\n";
108	}
109
110	$JSON::Syck::ImplicitUnicode = 1;
111
112	sub from_json {
113	JSON::Syck::Load $_[0]
114	}
115
116	sub to_json {
117	JSON::Syck::Dump $_[0]
118	}	187	}
119		188
120	sub read_cfg {	189	sub read_cfg {
121	my ($file) = @_;	190	my ($file) = @_;
122		191
…		…
145	open my $fh, ">:utf8", $file	214	open my $fh, ">:utf8", $file
146	or return;	215	or return;
147	print $fh to_json $::CFG;	216	print $fh to_json $::CFG;
148	}	217	}
149		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
150	our $DB_ENV;	260	our $DB_ENV;
151		261	our $DB_STATE;
152	{
153	use strict;
154
155	mkdir "$Crossfire::VARDIR/cfplus", 0777;
156	my $recover = $BerkeleyDB::db_version >= 4.4
157	? eval "DB_REGISTER \| DB_RECOVER"
158	: 0;
159
160	$DB_ENV = new BerkeleyDB::Env
161	-Home => "$Crossfire::VARDIR/cfplus",
162	-Cachesize => 1_000_000,
163	-ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
164	# -ErrPrefix => "DATABASE",
165	-Verbose => 1,
166	-Flags => DB_CREATE \| DB_RECOVER \| DB_INIT_MPOOL \| DB_INIT_LOCK \| DB_INIT_TXN \| $recover,
167	-SetFlags => DB_AUTO_COMMIT \| DB_LOG_AUTOREMOVE,
168	or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
169	}
170		262
171	sub db_table($) {	263	sub db_table($) {
172	my ($table) = @_;	264	my ($table) = @_;
173		265
174	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;	266	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
…		…
179	# -Filename => "database",	271	# -Filename => "database",
180	# -Subname => $table,	272	# -Subname => $table,
181	-Property => DB_CHKSUM,	273	-Property => DB_CHKSUM,
182	-Flags => DB_CREATE \| DB_UPGRADE,	274	-Flags => DB_CREATE \| DB_UPGRADE,
183	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;
184	}	306	}
185		307
186	package CFPlus::Layout;	308	package CFPlus::Layout;
187		309
188	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {	310	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {
…		…
231	}	353	}
232		354
233	sub do_n_dialog {	355	sub do_n_dialog {
234	my ($cb) = @_;	356	my ($cb) = @_;
235		357
236	my $w = new CFPlus::UI::FancyFrame	358	my $w = new CFPlus::UI::Toplevel
237	on_delete => sub { $_[0]->destroy; 1 },	359	on_delete => sub { $_[0]->destroy; 1 },
238	has_close_button => 1,	360	has_close_button => 1,
239	;	361	;
240		362
241	$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");
…		…
286	} elsif ($ev->{button} == 3) {	408	} elsif ($ev->{button} == 3) {
287	my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';	409	my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
288	if ($self->{container} == $::CONN->{open_container}) {	410	if ($self->{container} == $::CONN->{open_container}) {
289	$move_prefix = "take";	411	$move_prefix = "take";
290	}	412	}
		413
		414	my $shortname = CFPlus::shorten $self->{name}, 14;
291		415
292	my @menu_items = (	416	my @menu_items = (
293	["examine", sub { $::CONN->send ("examine $self->{tag}") }],	417	["examine", sub { $::CONN->send ("examine $self->{tag}") }],
294	["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],	418	["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
295	["ignite/thaw", # first try of an easier use of flint&steel	419	["ignite/thaw", # first try of an easier use of flint&steel
…		…
305	$::CONN->send ("mark ". pack "N", $self->{tag});	429	$::CONN->send ("mark ". pack "N", $self->{tag});
306	$::CONN->send ("command use_skill inscription $txt");	430	$::CONN->send ("command use_skill inscription $txt");
307	});	431	});
308	}	432	}
309	],	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	],
310	["apply", sub { $::CONN->send ("apply $self->{tag}") }],	444	["apply", sub { $::CONN->send ("apply $self->{tag}") }],
311	(	445	(
312	$self->{flags} & F_LOCKED	446	$self->{flags} & F_LOCKED
313	? (	447	? (
314	["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],	448	["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
…		…
321	do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })	455	do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
322	}	456	}
323	]	457	]
324	)	458	)
325	),	459	),
		460	["bind <i>apply $shortname</i> to a key" => sub { $::BIND_EDITOR->do_quick_binding (["apply $self->{name}"]) }],
326	);	461	);
327		462
328	CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);	463	CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
329	}	464	}
330		465

Diff Legend

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

Comparing deliantra/Deliantra-Client/DC.pm (file contents): Revision 1.109 by elmex, Sun Jul 30 13:40:17 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.109 by elmex, Sun Jul 30 13:40:17 2006 UTC vs.
Revision 1.135 by root, Thu Dec 7 15:57:13 2006 UTC