[ViewVC] Diff of: cvs/deliantra/server/lib/cf.pm

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.273 by root, Mon Jun 4 12:19:08 2007 UTC vs.
Revision 1.283 by root, Sun Jun 24 04:09:29 2007 UTC

…		…
206	}	206	}
207		207
208	$Event::DIED = sub {	208	$Event::DIED = sub {
209	warn "error in event callback: @_";	209	warn "error in event callback: @_";
210	};	210	};
		211
		212	#############################################################################
211		213
212	=head2 UTILITY FUNCTIONS	214	=head2 UTILITY FUNCTIONS
213		215
214	=over 4	216	=over 4
215		217
…		…
318		320
319	BEGIN { *async = \&Coro::async_pool }	321	BEGIN { *async = \&Coro::async_pool }
320		322
321	=item cf::sync_job { BLOCK }	323	=item cf::sync_job { BLOCK }
322		324
323	The design of crossfire+ requires that the main coro ($Coro::main) is	325	The design of Crossfire TRT requires that the main coroutine ($Coro::main)
324	always able to handle events or runnable, as crossfire+ is only partly	326	is always able to handle events or runnable, as Crossfire TRT is only
325	reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.	327	partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
		328	acceptable.
326		329
327	If it must be done, put the blocking parts into C<sync_job>. This will run	330	If it must be done, put the blocking parts into C<sync_job>. This will run
328	the given BLOCK in another coroutine while waiting for the result. The	331	the given BLOCK in another coroutine while waiting for the result. The
329	server will be frozen during this time, so the block should either finish	332	server will be frozen during this time, so the block should either finish
330	fast or be very important.	333	fast or be very important.
…		…
390	$EXT_CORO{$coro+0} = $coro;	393	$EXT_CORO{$coro+0} = $coro;
391		394
392	$coro	395	$coro
393	}	396	}
394		397
395	sub write_runtime {	398	=item fork_call { }, $args
396	my $runtime = "$LOCALDIR/runtime";
397		399
398	# first touch the runtime file to show we are still running:	400	Executes the given code block with the given arguments in a seperate
399	# the fsync below can take a very very long time.	401	process, returning the results. Everything must be serialisable with
		402	Coro::Storable. May, of course, block. Note that the executed sub may
		403	never block itself or use any form of Event handling.
400		404
401	IO::AIO::aio_utime $runtime, undef, undef;	405	=cut
402		406
403	my $guard = cf::lock_acquire "write_runtime";	407	sub fork_call(&@) {
		408	my ($cb, @args) = @_;
404		409
405	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644	410	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
406	or return;	411	# or die "socketpair: $!";
		412	pipe my $fh1, my $fh2
		413	or die "pipe: $!";
407		414
408	my $value = $cf::RUNTIME + 90 + 10;	415	if (my $pid = fork) {
409	# 10 is the runtime save interval, for a monotonic clock
410	# 60 allows for the watchdog to kill the server.
411
412	(aio_write $fh, 0, (length $value), $value, 0) <= 0
413	and return;
414
415	# always fsync - this file is important
416	aio_fsync $fh
417	and return;
418
419	# touch it again to show we are up-to-date
420	aio_utime $fh, undef, undef;
421
422	close $fh	416	close $fh2;
423	or return;
424		417
425	aio_rename "$runtime~", $runtime	418	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
426	and return;	419	$res = Coro::Storable::thaw $res;
427		420
428	warn "runtime file written.\n";#d#	421	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
429		422
		423	die $$res unless "ARRAY" eq ref $res;
		424
		425	return wantarray ? @$res : $res->[-1];
		426	} else {
		427	reset_signals;
		428	local $SIG{__WARN__};
		429	local $SIG{__DIE__};
		430	eval {
		431	close $fh1;
		432
		433	my @res = eval { $cb->(@args) };
		434	syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
		435	};
		436
		437	warn $@ if $@;
		438	_exit 0;
430	1	439	}
		440	}
		441
		442	=item $value = cf::db_get $family => $key
		443
		444	Returns a single value from the environment database.
		445
		446	=item cf::db_put $family => $key => $value
		447
		448	Stores the given C<$value> in the family. It can currently store binary
		449	data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
		450
		451	=cut
		452
		453	our $DB;
		454
		455	sub db_init {
		456	unless ($DB) {
		457	$DB = BDB::db_create $DB_ENV;
		458
		459	cf::sync_job {
		460	eval {
		461	$DB->set_flags (BDB::CHKSUM);
		462
		463	BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
		464	BDB::CREATE \| BDB::AUTO_COMMIT, 0666;
		465	cf::cleanup "db_open(db): $!" if $!;
		466	};
		467	cf::cleanup "db_open(db): $@" if $@;
		468	};
		469	}
		470	}
		471
		472	sub db_get($$) {
		473	my $key = "$_[0]/$_[1]";
		474
		475	cf::sync_job {
		476	BDB::db_get $DB, undef, $key, my $data;
		477
		478	$! ? ()
		479	: $data
		480	}
		481	}
		482
		483	sub db_put($$$) {
		484	BDB::dbreq_pri 4;
		485	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
		486	}
		487
		488	=item cf::cache $id => [$paths...], $processversion => $process
		489
		490	Generic caching function that returns the value of the resource $id,
		491	caching and regenerating as required.
		492
		493	This function can block.
		494
		495	=cut
		496
		497	sub cache {
		498	my ($id, $src, $processversion, $process) = @_;
		499
		500	my $meta =
		501	join "\x00",
		502	$processversion,
		503	map {
		504	aio_stat $_
		505	and Carp::croak "$_: $!";
		506
		507	($_, (stat _)[7,9])
		508	} @$src;
		509
		510	my $dbmeta = db_get cache => "$id/meta";
		511	if ($dbmeta ne $meta) {
		512	# changed, we may need to process
		513
		514	my @data;
		515	my $md5;
		516
		517	for (0 .. $#$src) {
		518	0 <= aio_load $src->[$_], $data[$_]
		519	or Carp::croak "$src->[$_]: $!";
		520	}
		521
		522	# if processing is expensive, check
		523	# checksum first
		524	if (1) {
		525	$md5 =
		526	join "\x00",
		527	$processversion,
		528	map {
		529	Coro::cede;
		530	($src->[$_], Digest::MD5::md5_hex $data[$_])
		531	} 0.. $#$src;
		532
		533
		534	my $dbmd5 = db_get cache => "$id/md5";
		535	if ($dbmd5 eq $md5) {
		536	db_put cache => "$id/meta", $meta;
		537
		538	return db_get cache => "$id/data";
		539	}
		540	}
		541
		542	my $t1 = Time::HiRes::time;
		543	my $data = $process->(\@data);
		544	my $t2 = Time::HiRes::time;
		545
		546	warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
		547
		548	db_put cache => "$id/data", $data;
		549	db_put cache => "$id/md5" , $md5;
		550	db_put cache => "$id/meta", $meta;
		551
		552	return $data;
		553	}
		554
		555	db_get cache => "$id/data"
431	}	556	}
432		557
433	=item cf::datalog type => key => value, ...	558	=item cf::datalog type => key => value, ...
434		559
435	Log a datalog packet of the given type with the given key-value pairs.	560	Log a datalog packet of the given type with the given key-value pairs.
…		…
453	attach callbacks/event handlers (a collection of which is called an "attachment")	578	attach callbacks/event handlers (a collection of which is called an "attachment")
454	to it. All such attachable objects support the following methods.	579	to it. All such attachable objects support the following methods.
455		580
456	In the following description, CLASS can be any of C<global>, C<object>	581	In the following description, CLASS can be any of C<global>, C<object>
457	C<player>, C<client> or C<map> (i.e. the attachable objects in	582	C<player>, C<client> or C<map> (i.e. the attachable objects in
458	crossfire+).	583	Crossfire TRT).
459		584
460	=over 4	585	=over 4
461		586
462	=item $attachable->attach ($attachment, key => $value...)	587	=item $attachable->attach ($attachment, key => $value...)
463		588
…		…
665	_attach $registry, $klass, @attach;	790	_attach $registry, $klass, @attach;
666	}	791	}
667		792
668	$obj->{$name} = \%arg;	793	$obj->{$name} = \%arg;
669	} else {	794	} else {
670	warn "object uses attachment '$name' that is not available, postponing.\n";	795	warn "object uses attachment '$name' which is not available, postponing.\n";
671	}	796	}
672		797
673	$obj->{_attachment}{$name} = undef;	798	$obj->{_attachment}{$name} = undef;
674	}	799	}
675		800
…		…
873	or return;	998	or return;
874	$av = eval { (Storable::thaw $av)->{objs} };	999	$av = eval { (Storable::thaw $av)->{objs} };
875	}	1000	}
876		1001
877	warn sprintf "loading %s (%d)\n",	1002	warn sprintf "loading %s (%d)\n",
878	$filename, length $data, scalar @{$av \|\| []};#d#	1003	$filename, length $data, scalar @{$av \|\| []};
879	return ($data, $av);	1004	return ($data, $av);
880	}	1005	}
		1006
		1007	=head2 COMMAND CALLBACKS
		1008
		1009	=over 4
		1010
		1011	=cut
881		1012
882	#############################################################################	1013	#############################################################################
883	# command handling &c	1014	# command handling &c
884		1015
885	=item cf::register_command $name => \&callback($ob,$args);	1016	=item cf::register_command $name => \&callback($ob,$args);
…		…
898	push @{ $COMMAND{$name} }, [$caller, $cb];	1029	push @{ $COMMAND{$name} }, [$caller, $cb];
899	}	1030	}
900		1031
901	=item cf::register_extcmd $name => \&callback($pl,$packet);	1032	=item cf::register_extcmd $name => \&callback($pl,$packet);
902		1033
903	Register a callbackf ro execution when the client sends an extcmd packet.	1034	Register a callback fro execution when the client sends an extcmd packet.
904		1035
905	If the callback returns something, it is sent back as if reply was being	1036	If the callback returns something, it is sent back as if reply was being
906	called.	1037	called.
907		1038
908	=cut	1039	=cut
…		…
943		1074
944	cf::override;	1075	cf::override;
945	},	1076	},
946	);	1077	);
947		1078
948	sub load_extension {
949	my ($path) = @_;
950
951	$path =~ /([^\/\\]+)\.ext$/ or die "$path";
952	my $base = $1;
953	my $pkg = $1;
954	$pkg =~ s/[^[:word:]]/_/g;
955	$pkg = "ext::$pkg";
956
957	warn "... loading '$path' into '$pkg'\n";
958
959	open my $fh, "<:utf8", $path
960	or die "$path: $!";
961
962	my $source =
963	"package $pkg; use strict; use utf8;\n"
964	. "#line 1 \"$path\"\n{\n"
965	. (do { local $/; <$fh> })
966	. "\n};\n1";
967
968	unless (eval $source) {
969	my $msg = $@ ? "$path: $@\n"
970	: "extension disabled.\n";
971	if ($source =~ /^#!.perl.#.*MANDATORY/m) { # ugly match
972	warn $@;
973	warn "mandatory extension failed to load, exiting.\n";
974	exit 1;
975	}
976	die $@;
977	}
978
979	push @EXTS, $pkg;
980	}
981
982	sub load_extensions {	1079	sub load_extensions {
		1080	cf::sync_job {
		1081	my %todo;
		1082
983	for my $ext (<$LIBDIR/*.ext>) {	1083	for my $path (<$LIBDIR/*.ext>) {
984	next unless -r $ext;	1084	next unless -r $path;
985	eval {	1085
986	load_extension $ext;	1086	$path =~ /([^\/\\]+)\.ext$/ or die "$path";
		1087	my $base = $1;
		1088	my $pkg = $1;
		1089	$pkg =~ s/[^[:word:]]/_/g;
		1090	$pkg = "ext::$pkg";
		1091
		1092	open my $fh, "<:utf8", $path
		1093	or die "$path: $!";
		1094
		1095	my $source = do { local $/; <$fh> };
		1096
		1097	my %ext = (
		1098	path => $path,
		1099	base => $base,
		1100	pkg => $pkg,
		1101	);
		1102
		1103	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
		1104	if $source =~ /\A#!.?perl.?#\s(.)$/m;
		1105
		1106	$ext{source} =
		1107	"package $pkg; use strict; use utf8;\n"
		1108	. "#line 1 \"$path\"\n{\n"
		1109	. $source
		1110	. "\n};\n1";
		1111
		1112	$todo{$base} = \%ext;
		1113	}
		1114
		1115	my %done;
		1116	while (%todo) {
		1117	my $progress;
		1118
		1119	while (my ($k, $v) = each %todo) {
		1120	for (split /,\s*/, $v->{meta}{depends}) {
		1121	goto skip
		1122	unless exists $done{$_};
		1123	}
		1124
		1125	warn "... loading '$k' into '$v->{pkg}'\n";
		1126
		1127	unless (eval $v->{source}) {
		1128	my $msg = $@ ? "$v->{path}: $@\n"
		1129	: "$v->{base}: extension inactive.\n";
		1130
		1131	if (exists $v->{meta}{mandatory}) {
		1132	warn $msg;
		1133	warn "mandatory extension failed to load, exiting.\n";
		1134	exit 1;
		1135	}
		1136
		1137	warn $msg;
		1138	}
		1139
		1140	$done{$k} = delete $todo{$k};
		1141	push @EXTS, $v->{pkg};
		1142	$progress = 1;
987	1	1143	}
988	} or warn "$ext not loaded: $@";	1144
		1145	skip:
		1146	die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
		1147	unless $progress;
		1148	}
989	}	1149	};
990	}	1150	}
991		1151
992	#############################################################################	1152	#############################################################################
		1153
		1154	=back
993		1155
994	=head2 CORE EXTENSIONS	1156	=head2 CORE EXTENSIONS
995		1157
996	Functions and methods that extend core crossfire objects.	1158	Functions and methods that extend core crossfire objects.
997		1159
…		…
1185	}	1347	}
1186		1348
1187	\@paths	1349	\@paths
1188	}	1350	}
1189		1351
		1352	=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
		1353
		1354	Expand crossfire pod fragments into protocol xml.
		1355
		1356	=cut
		1357
		1358	sub expand_cfpod {
		1359	((my $self), (local $_)) = @_;
		1360
		1361	# escape & and <
		1362	s/&/&/g;
		1363	s/(?<![BIUGH])</</g;
		1364
		1365	# this is buggy, it needs to properly take care of nested <'s
		1366
		1367	1 while
		1368	# replace B<>, I<>, U<> etc.
		1369	s/B<([^\>]*)>/<b>$1<\/b>/
		1370	\|\| s/I<([^\>]*)>/<i>$1<\/i>/
		1371	\|\| s/U<([^\>]*)>/<u>$1<\/u>/
		1372	# replace G<male\|female> tags
		1373	\|\| s{G<([^>\|])\\|([^>])>}{
		1374	$self->gender ? $2 : $1
		1375	}ge
		1376	# replace H<hint text>
		1377	\|\| s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g;
		1378
		1379	# create single paragraphs (very hackish)
		1380	s/(?<=\S)\n(?=\w)/ /g;
		1381
		1382	$_
		1383	}
		1384
1190	=item $player->ext_reply ($msgid, %msg)	1385	=item $player->ext_reply ($msgid, %msg)
1191		1386
1192	Sends an ext reply to the player.	1387	Sends an ext reply to the player.
1193		1388
1194	=cut	1389	=cut
…		…
1221		1416
1222	package cf::region;	1417	package cf::region;
1223		1418
1224	=item cf::region::find_by_path $path	1419	=item cf::region::find_by_path $path
1225		1420
1226	Tries to decuce the probable region for a map knowing only its path.	1421	Tries to decuce the likely region for a map knowing only its path.
1227		1422
1228	=cut	1423	=cut
1229		1424
1230	sub find_by_path($) {	1425	sub find_by_path($) {
1231	my ($path) = @_;	1426	my ($path) = @_;
…		…
1305	my ($self, $merge) = @_;	1500	my ($self, $merge) = @_;
1306		1501
1307	# we have to keep some variables in memory intact	1502	# we have to keep some variables in memory intact
1308	local $self->{path};	1503	local $self->{path};
1309	local $self->{load_path};	1504	local $self->{load_path};
1310	local $self->{deny_save};
1311	local $self->{deny_reset};
1312		1505
1313	$self->SUPER::thawer_merge ($merge);	1506	$self->SUPER::thawer_merge ($merge);
1314	}	1507	}
1315		1508
1316	sub normalise {	1509	sub normalise {
…		…
1416		1609
1417	$_->change_map_light ($change)	1610	$_->change_map_light ($change)
1418	for grep $_->outdoor, values %cf::MAP;	1611	for grep $_->outdoor, values %cf::MAP;
1419	}	1612	}
1420		1613
		1614	sub decay_objects {
		1615	my ($self) = @_;
		1616
		1617	return if $self->{deny_reset};
		1618
		1619	$self->do_decay_objects;
		1620	}
		1621
1421	sub unlink_save {	1622	sub unlink_save {
1422	my ($self) = @_;	1623	my ($self) = @_;
1423		1624
1424	utf8::encode (my $save = $self->save_path);	1625	utf8::encode (my $save = $self->save_path);
1425	IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;	1626	IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
…		…
1481	$self->load_header_orig	1682	$self->load_header_orig
1482	or return;	1683	or return;
1483	$self->prepare_orig;	1684	$self->prepare_orig;
1484	}	1685	}
1485		1686
		1687	$self->{deny_reset} = 1
		1688	if $self->no_reset;
		1689
1486	$self->default_region (cf::region::find_by_path $self->{path})	1690	$self->default_region (cf::region::find_by_path $self->{path})
1487	unless $self->default_region;	1691	unless $self->default_region;
1488		1692
1489	1	1693	1
1490	}	1694	}
…		…
1505	$map->{last_save} = $cf::RUNTIME;	1709	$map->{last_save} = $cf::RUNTIME;
1506		1710
1507	$map->load_header	1711	$map->load_header
1508	or return;	1712	or return;
1509		1713
1510	if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?)	1714	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1511	# doing this can freeze the server in a sync job, obviously	1715	# doing this can freeze the server in a sync job, obviously
1512	#$cf::WAIT_FOR_TICK->wait;	1716	#$cf::WAIT_FOR_TICK->wait;
1513	$map->reset;	1717	$map->reset;
1514	undef $guard;	1718	undef $guard;
1515	return find $path;	1719	return find $path;
…		…
1582	my ($self, $ob) = @_;	1786	my ($self, $ob) = @_;
1583		1787
1584	return find "~" . $ob->name . "/" . $self->{path}	1788	return find "~" . $ob->name . "/" . $self->{path}
1585	if $self->per_player;	1789	if $self->per_player;
1586		1790
		1791	# return find "?party/" . $ob->name . "/" . $self->{path}
		1792	# if $self->per_party;
		1793
1587	$self	1794	$self
1588	}	1795	}
1589		1796
1590	# find and load all maps in the 3x3 area around a map	1797	# find and load all maps in the 3x3 area around a map
1591	sub load_diag {	1798	sub load_diag {
…		…
1701		1908
1702	sub reset_at {	1909	sub reset_at {
1703	my ($self) = @_;	1910	my ($self) = @_;
1704		1911
1705	# TODO: safety, remove and allow resettable per-player maps	1912	# TODO: safety, remove and allow resettable per-player maps
1706	return 1e99 if $self->isa ("ext::map_per_player");#d#
1707	return 1e99 if $self->{deny_reset};	1913	return 1e99 if $self->{deny_reset};
1708		1914
1709	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;	1915	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1710	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;	1916	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;
1711		1917
…		…
1722	my ($self) = @_;	1928	my ($self) = @_;
1723		1929
1724	my $lock = cf::lock_acquire "map_data:$self->{path}";	1930	my $lock = cf::lock_acquire "map_data:$self->{path}";
1725		1931
1726	return if $self->players;	1932	return if $self->players;
1727	return if $self->isa ("ext::map_per_player");#d#
1728		1933
1729	warn "resetting map ", $self->path;#d#	1934	warn "resetting map ", $self->path;
1730		1935
1731	$self->in_memory (cf::MAP_SWAPPED);	1936	$self->in_memory (cf::MAP_SWAPPED);
1732		1937
1733	# need to save uniques path	1938	# need to save uniques path
1734	unless ($self->{deny_save}) {	1939	unless ($self->{deny_save}) {
…		…
1766	$cf::MAP{$self->path} = $self;	1971	$cf::MAP{$self->path} = $self;
1767		1972
1768	$self->reset; # polite request, might not happen	1973	$self->reset; # polite request, might not happen
1769	}	1974	}
1770		1975
		1976	=item $maps = cf::map::tmp_maps
		1977
		1978	Returns an arrayref with all map paths of currently instantiated and saved
		1979	maps. May block.
		1980
		1981	=cut
		1982
		1983	sub tmp_maps() {
		1984	[
		1985	map {
		1986	utf8::decode $_;
		1987	/\.map$/
		1988	? normalise $_
		1989	: ()
		1990	} @{ aio_readdir $TMPDIR or [] }
		1991	]
		1992	}
		1993
		1994	=item $maps = cf::map::random_maps
		1995
		1996	Returns an arrayref with all map paths of currently instantiated and saved
		1997	random maps. May block.
		1998
		1999	=cut
		2000
		2001	sub random_maps() {
		2002	[
		2003	map {
		2004	utf8::decode $_;
		2005	/\.map$/
		2006	? normalise "?random/$_"
		2007	: ()
		2008	} @{ aio_readdir $RANDOMDIR or [] }
		2009	]
		2010	}
		2011
1771	=item cf::map::unique_maps	2012	=item cf::map::unique_maps
1772		2013
1773	Returns an arrayref of paths of all shared maps that have	2014	Returns an arrayref of paths of all shared maps that have
1774	instantiated unique items. May block.	2015	instantiated unique items. May block.
1775		2016
1776	=cut	2017	=cut
1777		2018
1778	sub unique_maps() {	2019	sub unique_maps() {
1779	my $files = aio_readdir $UNIQUEDIR	2020	[
1780	or return;	2021	map {
1781
1782	my @paths;
1783
1784	for (@$files) {
1785	utf8::decode $_;	2022	utf8::decode $_;
1786	next if /\.pst$/;	2023	/\.map$/
1787	next unless /^$PATH_SEP/o;	2024	? normalise $_
1788		2025	: ()
1789	push @paths, cf::map::normalise $_;	2026	} @{ aio_readdir $UNIQUEDIR or [] }
1790	}	2027	]
1791
1792	\@paths
1793	}	2028	}
1794		2029
1795	package cf;	2030	package cf;
1796		2031
1797	=back	2032	=back
…		…
1843		2078
1844	$flags = cf::NDI_BROWN \| cf::NDI_UNIQUE unless @_ >= 4;	2079	$flags = cf::NDI_BROWN \| cf::NDI_UNIQUE unless @_ >= 4;
1845		2080
1846	if ($self->{record_replies}) {	2081	if ($self->{record_replies}) {
1847	push @{ $self->{record_replies} }, [$npc, $msg, $flags];	2082	push @{ $self->{record_replies} }, [$npc, $msg, $flags];
		2083
1848	} else {	2084	} else {
		2085	my $pl = $self->contr;
		2086
		2087	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
		2088	my $diag = $pl->{npc_dialog};
		2089	$diag->{pl}->ext_reply (
		2090	$diag->{id},
		2091	msgtype => "reply",
		2092	msg => $diag->{pl}->expand_cfpod ($msg),
		2093	add_topics => []
		2094	);
		2095
		2096	} else {
1849	$msg = $npc->name . " says: $msg" if $npc;	2097	$msg = $npc->name . " says: $msg" if $npc;
1850	$self->message ($msg, $flags);	2098	$self->message ($msg, $flags);
		2099	}
1851	}	2100	}
1852	}	2101	}
1853		2102
1854	=item $player_object->may ("access")	2103	=item $player_object->may ("access")
1855		2104
…		…
2098	sub cf::client::send_drawinfo {	2347	sub cf::client::send_drawinfo {
2099	my ($self, $text, $flags) = @_;	2348	my ($self, $text, $flags) = @_;
2100		2349
2101	utf8::encode $text;	2350	utf8::encode $text;
2102	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2351	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
		2352	}
		2353
		2354	=item $client->send_msg ($color, $type, $msg, [extra...])
		2355
		2356	Send a drawinfo or msg packet to the client, formatting the msg for the
		2357	client if neccessary. C<$type> should be a string identifying the type of
		2358	the message, with C<log> being the default. If C<$color> is negative, suppress
		2359	the message unless the client supports the msg packet.
		2360
		2361	=cut
		2362
		2363	sub cf::client::send_msg {
		2364	my ($self, $color, $type, $msg, @extra) = @_;
		2365
		2366	$msg = $self->pl->expand_cfpod ($msg);
		2367
		2368	if ($self->can_msg) {
		2369	$self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]);
		2370	} else {
		2371	# replace some tags by gcfclient-compatible ones
		2372	for ($msg) {
		2373	1 while
		2374	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2375	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2376	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2377	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2378	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${1}[\/color]/;
		2379	}
		2380
		2381	if ($color >= 0) {
		2382	if ($msg =~ /\[/) {
		2383	$self->send_packet ("drawextinfo $color 4 0 $msg")
		2384	} else {
		2385	$self->send_packet ("drawinfo $color $msg")
		2386	}
		2387	}
		2388	}
2103	}	2389	}
2104		2390
2105	=item $client->ext_event ($type, %msg)	2391	=item $client->ext_event ($type, %msg)
2106		2392
2107	Sends an exti event to the client.	2393	Sends an exti event to the client.
…		…
2309	=back	2595	=back
2310		2596
2311	=cut	2597	=cut
2312		2598
2313	#############################################################################	2599	#############################################################################
2314
2315	=head2 EXTENSION DATABASE SUPPORT
2316
2317	Crossfire maintains a very simple database for extension use. It can
2318	currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2319	convert to/from binary).
2320
2321	The parameter C<$family> should best start with the name of the extension
2322	using it, it should be unique.
2323
2324	=over 4
2325
2326	=item $value = cf::db_get $family => $key
2327
2328	Returns a single value from the database.
2329
2330	=item cf::db_put $family => $key => $value
2331
2332	Stores the given C<$value> in the family.
2333
2334	=cut
2335
2336	our $DB;
2337
2338	sub db_init {
2339	unless ($DB) {
2340	$DB = BDB::db_create $DB_ENV;
2341
2342	cf::sync_job {
2343	eval {
2344	$DB->set_flags (BDB::CHKSUM);
2345
2346	BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2347	BDB::CREATE \| BDB::AUTO_COMMIT, 0666;
2348	cf::cleanup "db_open(db): $!" if $!;
2349	};
2350	cf::cleanup "db_open(db): $@" if $@;
2351	};
2352	}
2353	}
2354
2355	sub db_get($$) {
2356	my $key = "$_[0]/$_[1]";
2357
2358	cf::sync_job {
2359	BDB::db_get $DB, undef, $key, my $data;
2360
2361	$! ? ()
2362	: $data
2363	}
2364	}
2365
2366	sub db_put($$$) {
2367	BDB::dbreq_pri 4;
2368	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2369	}
2370
2371	=item cf::cache $id => [$paths...], $processversion => $process
2372
2373	Generic caching function that returns the value of the resource $id,
2374	caching and regenerating as required.
2375
2376	This function can block.
2377
2378	=cut
2379
2380	sub cache {
2381	my ($id, $src, $processversion, $process) = @_;
2382
2383	my $meta =
2384	join "\x00",
2385	$processversion,
2386	map {
2387	aio_stat $_
2388	and Carp::croak "$_: $!";
2389
2390	($_, (stat _)[7,9])
2391	} @$src;
2392
2393	my $dbmeta = db_get cache => "$id/meta";
2394	if ($dbmeta ne $meta) {
2395	# changed, we may need to process
2396
2397	my @data;
2398	my $md5;
2399
2400	for (0 .. $#$src) {
2401	0 <= aio_load $src->[$_], $data[$_]
2402	or Carp::croak "$src->[$_]: $!";
2403	}
2404
2405	# if processing is expensive, check
2406	# checksum first
2407	if (1) {
2408	$md5 =
2409	join "\x00",
2410	$processversion,
2411	map {
2412	Coro::cede;
2413	($src->[$_], Digest::MD5::md5_hex $data[$_])
2414	} 0.. $#$src;
2415
2416
2417	my $dbmd5 = db_get cache => "$id/md5";
2418	if ($dbmd5 eq $md5) {
2419	db_put cache => "$id/meta", $meta;
2420
2421	return db_get cache => "$id/data";
2422	}
2423	}
2424
2425	my $t1 = Time::HiRes::time;
2426	my $data = $process->(\@data);
2427	my $t2 = Time::HiRes::time;
2428
2429	warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2430
2431	db_put cache => "$id/data", $data;
2432	db_put cache => "$id/md5" , $md5;
2433	db_put cache => "$id/meta", $meta;
2434
2435	return $data;
2436	}
2437
2438	db_get cache => "$id/data"
2439	}
2440
2441	=item fork_call { }, $args
2442
2443	Executes the given code block with the given arguments in a seperate
2444	process, returning the results. Everything must be serialisable with
2445	Coro::Storable. May, of course, block. Note that the executed sub may
2446	never block itself or use any form of Event handling.
2447
2448	=cut
2449
2450	sub fork_call(&@) {
2451	my ($cb, @args) = @_;
2452
2453	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2454	# or die "socketpair: $!";
2455	pipe my $fh1, my $fh2
2456	or die "pipe: $!";
2457
2458	if (my $pid = fork) {
2459	close $fh2;
2460
2461	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2462	$res = Coro::Storable::thaw $res;
2463
2464	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2465
2466	die $$res unless "ARRAY" eq ref $res;
2467
2468	return wantarray ? @$res : $res->[-1];
2469	} else {
2470	reset_signals;
2471	local $SIG{__WARN__};
2472	local $SIG{__DIE__};
2473	eval {
2474	close $fh1;
2475
2476	my @res = eval { $cb->(@args) };
2477	syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2478	};
2479
2480	warn $@ if $@;
2481	_exit 0;
2482	}
2483	}
2484
2485	#############################################################################
2486	# the server's init and main functions	2600	# the server's init and main functions
2487		2601
2488	sub load_facedata($) {	2602	sub load_facedata($) {
2489	my ($path) = @_;	2603	my ($path) = @_;
2490		2604
…		…
2560	sub reload_resources {	2674	sub reload_resources {
2561	warn "reloading resource files...\n";	2675	warn "reloading resource files...\n";
2562		2676
2563	reload_regions;	2677	reload_regions;
2564	reload_facedata;	2678	reload_facedata;
		2679	#reload_archetypes;#d#
2565	reload_archetypes;	2680	reload_archetypes;
2566	reload_treasures;	2681	reload_treasures;
2567		2682
2568	warn "finished reloading resource files\n";	2683	warn "finished reloading resource files\n";
2569	}	2684	}
…		…
2624	cb => sub {	2739	cb => sub {
2625	cf::cleanup "SIG$signal";	2740	cf::cleanup "SIG$signal";
2626	},	2741	},
2627	);	2742	);
2628	}	2743	}
		2744	}
		2745
		2746	sub write_runtime {
		2747	my $runtime = "$LOCALDIR/runtime";
		2748
		2749	# first touch the runtime file to show we are still running:
		2750	# the fsync below can take a very very long time.
		2751
		2752	IO::AIO::aio_utime $runtime, undef, undef;
		2753
		2754	my $guard = cf::lock_acquire "write_runtime";
		2755
		2756	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644
		2757	or return;
		2758
		2759	my $value = $cf::RUNTIME + 90 + 10;
		2760	# 10 is the runtime save interval, for a monotonic clock
		2761	# 60 allows for the watchdog to kill the server.
		2762
		2763	(aio_write $fh, 0, (length $value), $value, 0) <= 0
		2764	and return;
		2765
		2766	# always fsync - this file is important
		2767	aio_fsync $fh
		2768	and return;
		2769
		2770	# touch it again to show we are up-to-date
		2771	aio_utime $fh, undef, undef;
		2772
		2773	close $fh
		2774	or return;
		2775
		2776	aio_rename "$runtime~", $runtime
		2777	and return;
		2778
		2779	warn "runtime file written.\n";
		2780
		2781	1
2629	}	2782	}
2630		2783
2631	sub emergency_save() {	2784	sub emergency_save() {
2632	my $freeze_guard = cf::freeze_mainloop;	2785	my $freeze_guard = cf::freeze_mainloop;
2633		2786

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.273 by root, Mon Jun 4 12:19:08 2007 UTC vs. Revision 1.283 by root, Sun Jun 24 04:09:29 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.273 by root, Mon Jun 4 12:19:08 2007 UTC vs.
Revision 1.283 by root, Sun Jun 24 04:09:29 2007 UTC