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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.315 by root, Mon Jul 23 17:53:55 2007 UTC vs.
Revision 1.361 by root, Sun Sep 9 12:52:48 2007 UTC

…		…
10	use Event;	10	use Event;
11	use Opcode;	11	use Opcode;
12	use Safe;	12	use Safe;
13	use Safe::Hole;	13	use Safe::Hole;
14		14
15	use Coro 3.61 ();	15	use Coro 3.64 ();
16	use Coro::State;	16	use Coro::State;
17	use Coro::Handle;	17	use Coro::Handle;
18	use Coro::Event;	18	use Coro::Event;
19	use Coro::Timer;	19	use Coro::Timer;
20	use Coro::Signal;	20	use Coro::Signal;
21	use Coro::Semaphore;	21	use Coro::Semaphore;
22	use Coro::AIO;	22	use Coro::AIO;
23	use Coro::Storable;	23	use Coro::Storable;
		24	use Coro::Util ();
24		25
25	use JSON::XS 1.4 ();	26	use JSON::XS ();
26	use BDB ();	27	use BDB ();
27	use Data::Dumper;	28	use Data::Dumper;
28	use Digest::MD5;	29	use Digest::MD5;
29	use Fcntl;	30	use Fcntl;
30	use YAML::Syck ();	31	use YAML::Syck ();
…		…
86	our %CFG;	87	our %CFG;
87		88
88	our $UPTIME; $UPTIME \|\|= time;	89	our $UPTIME; $UPTIME \|\|= time;
89	our $RUNTIME;	90	our $RUNTIME;
90		91
91	our %PLAYER; # all users	92	our (%PLAYER, %PLAYER_LOADING); # all users
92	our %MAP; # all maps	93	our (%MAP, %MAP_LOADING ); # all maps
93	our $LINK_MAP; # the special {link} map, which is always available	94	our $LINK_MAP; # the special {link} map, which is always available
94		95
95	# used to convert map paths into valid unix filenames by replacing / by ∕	96	# used to convert map paths into valid unix filenames by replacing / by ∕
96	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons	97	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
97		98
…		…
271	Wait until the given lock is available and then acquires it and returns	272	Wait until the given lock is available and then acquires it and returns
272	a Coro::guard object. If the guard object gets destroyed (goes out of scope,	273	a Coro::guard object. If the guard object gets destroyed (goes out of scope,
273	for example when the coroutine gets canceled), the lock is automatically	274	for example when the coroutine gets canceled), the lock is automatically
274	returned.	275	returned.
275		276
		277	Locks are not recursive, locking from the same coro twice results in a
		278	deadlocked coro.
		279
276	Lock names should begin with a unique identifier (for example, cf::map::find	280	Lock names should begin with a unique identifier (for example, cf::map::find
277	uses map_find and cf::map::load uses map_load).	281	uses map_find and cf::map::load uses map_load).
278		282
279	=item $locked = cf::lock_active $string	283	=item $locked = cf::lock_active $string
280		284
281	Return true if the lock is currently active, i.e. somebody has locked it.	285	Return true if the lock is currently active, i.e. somebody has locked it.
282		286
283	=cut	287	=cut
284		288
285	our %LOCK;	289	our %LOCK;
		290	our %LOCKER;#d#
286		291
287	sub lock_wait($) {	292	sub lock_wait($) {
288	my ($key) = @_;	293	my ($key) = @_;
		294
		295	if ($LOCKER{$key} == $Coro::current) {#d#
		296	Carp::cluck "lock_wait($key) for already-acquired lock";#d#
		297	return;#d#
		298	}#d#
289		299
290	# wait for lock, if any	300	# wait for lock, if any
291	while ($LOCK{$key}) {	301	while ($LOCK{$key}) {
292	push @{ $LOCK{$key} }, $Coro::current;	302	push @{ $LOCK{$key} }, $Coro::current;
293	Coro::schedule;	303	Coro::schedule;
…		…
299		309
300	# wait, to be sure we are not locked	310	# wait, to be sure we are not locked
301	lock_wait $key;	311	lock_wait $key;
302		312
303	$LOCK{$key} = [];	313	$LOCK{$key} = [];
		314	$LOCKER{$key} = $Coro::current;#d#
304		315
305	Coro::guard {	316	Coro::guard {
		317	delete $LOCKER{$key};#d#
306	# wake up all waiters, to be on the safe side	318	# wake up all waiters, to be on the safe side
307	$_->ready for @{ delete $LOCK{$key} };	319	$_->ready for @{ delete $LOCK{$key} };
308	}	320	}
309	}	321	}
310		322
…		…
472	Coro::Storable. May, of course, block. Note that the executed sub may	484	Coro::Storable. May, of course, block. Note that the executed sub may
473	never block itself or use any form of Event handling.	485	never block itself or use any form of Event handling.
474		486
475	=cut	487	=cut
476		488
477	sub _store_scalar {
478	open my $fh, ">", \my $buf
479	or die "fork_call: cannot open fh-to-buf in child : $!";
480	Storable::store_fd $_[0], $fh;
481	close $fh;
482
483	$buf
484	}
485
486	sub fork_call(&@) {	489	sub fork_call(&@) {
487	my ($cb, @args) = @_;	490	my ($cb, @args) = @_;
488		491
489	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC	492	# we seemingly have to make a local copy of the whole thing,
490	# or die "socketpair: $!";	493	# otherwise perl prematurely frees the stuff :/
491	pipe my $fh1, my $fh2	494	# TODO: investigate and fix (likely this will be rather laborious)
492	or die "pipe: $!";
493		495
494	if (my $pid = fork) {	496	my @res = Coro::Util::fork_eval {
495	close $fh2;
496
497	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
498	warn "pst<$res>" unless $res =~ /^pst/;
499	$res = Coro::Storable::thaw $res;
500
501	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
502
503	Carp::confess $$res unless "ARRAY" eq ref $res;
504
505	return wantarray ? @$res : $res->[-1];
506	} else {
507	reset_signals;	497	reset_signals;
508	local $SIG{__WARN__};	498	&$cb
509	local $SIG{__DIE__};	499	}, @args;
510	# just in case, this hack effectively disables event
511	# in the child. cleaner and slower would be canceling all watchers,
512	# but this works for the time being.
513	local $Coro::idle;
514	$Coro::current->prio (Coro::PRIO_MAX);
515		500
516	eval {	501	wantarray ? @res : $res[-1]
517	close $fh1;
518
519	my @res = eval { $cb->(@args) };
520
521	syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
522	close $fh2;
523	};
524
525	warn $@ if $@;
526	_exit 0;
527	}
528	}	502	}
529		503
530	=item $value = cf::db_get $family => $key	504	=item $value = cf::db_get $family => $key
531		505
532	Returns a single value from the environment database.	506	Returns a single value from the environment database.
…		…
612	if (1) {	586	if (1) {
613	$md5 =	587	$md5 =
614	join "\x00",	588	join "\x00",
615	$processversion,	589	$processversion,
616	map {	590	map {
617	Coro::cede;	591	cf::cede_to_tick;
618	($src->[$_], Digest::MD5::md5_hex $data[$_])	592	($src->[$_], Digest::MD5::md5_hex $data[$_])
619	} 0.. $#$src;	593	} 0.. $#$src;
620		594
621		595
622	my $dbmd5 = db_get cache => "$id/md5";	596	my $dbmd5 = db_get cache => "$id/md5";
…		…
1038	},	1012	},
1039	);	1013	);
1040		1014
1041	sub object_freezer_save {	1015	sub object_freezer_save {
1042	my ($filename, $rdata, $objs) = @_;	1016	my ($filename, $rdata, $objs) = @_;
		1017
		1018	my $guard = cf::lock_acquire "io";
1043		1019
1044	sync_job {	1020	sync_job {
1045	if (length $$rdata) {	1021	if (length $$rdata) {
1046	warn sprintf "saving %s (%d,%d)\n",	1022	warn sprintf "saving %s (%d,%d)\n",
1047	$filename, length $$rdata, scalar @$objs;	1023	$filename, length $$rdata, scalar @$objs;
…		…
1071	}	1047	}
1072	} else {	1048	} else {
1073	aio_unlink $filename;	1049	aio_unlink $filename;
1074	aio_unlink "$filename.pst";	1050	aio_unlink "$filename.pst";
1075	}	1051	}
1076	}	1052	};
		1053
		1054	undef $guard;
1077	}	1055	}
1078		1056
1079	sub object_freezer_as_string {	1057	sub object_freezer_as_string {
1080	my ($rdata, $objs) = @_;	1058	my ($rdata, $objs) = @_;
1081		1059
…		…
1086		1064
1087	sub object_thawer_load {	1065	sub object_thawer_load {
1088	my ($filename) = @_;	1066	my ($filename) = @_;
1089		1067
1090	my ($data, $av);	1068	my ($data, $av);
		1069
		1070	my $guard = cf::lock_acquire "io";
1091		1071
1092	(aio_load $filename, $data) >= 0	1072	(aio_load $filename, $data) >= 0
1093	or return;	1073	or return;
1094		1074
1095	unless (aio_stat "$filename.pst") {	1075	unless (aio_stat "$filename.pst") {
1096	(aio_load "$filename.pst", $av) >= 0	1076	(aio_load "$filename.pst", $av) >= 0
1097	or return;	1077	or return;
		1078
		1079	undef $guard;
1098	$av = eval { (Storable::thaw $av)->{objs} };	1080	$av = eval { (Storable::thaw $av)->{objs} };
1099	}	1081	}
1100		1082
1101	warn sprintf "loading %s (%d)\n",	1083	warn sprintf "loading %s (%d)\n",
1102	$filename, length $data, scalar @{$av \|\| []};	1084	$filename, length $data, scalar @{$av \|\| []};
		1085
1103	return ($data, $av);	1086	($data, $av)
1104	}	1087	}
1105		1088
1106	=head2 COMMAND CALLBACKS	1089	=head2 COMMAND CALLBACKS
1107		1090
1108	=over 4	1091	=over 4
…		…
1181	my ($pl, $buf) = @_;	1164	my ($pl, $buf) = @_;
1182		1165
1183	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1166	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1184		1167
1185	if (ref $msg) {	1168	if (ref $msg) {
		1169	my ($type, $reply, @payload) =
		1170	"ARRAY" eq ref $msg
		1171	? @$msg
		1172	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		1173
		1174	my @reply;
		1175
1186	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1176	if (my $cb = $EXTCMD{$type}) {
1187	if (my %reply = $cb->($pl, $msg)) {	1177	@reply = $cb->($pl, @payload);
1188	$pl->ext_reply ($msg->{msgid}, %reply);
1189	}
1190	}	1178	}
		1179
		1180	$pl->ext_reply ($reply, @reply)
		1181	if $reply;
		1182
1191	} else {	1183	} else {
1192	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1184	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1193	}	1185	}
1194		1186
1195	cf::override;	1187	cf::override;
…		…
1285		1277
1286	=head3 cf::player	1278	=head3 cf::player
1287		1279
1288	=over 4	1280	=over 4
1289		1281
		1282	=item cf::player::num_playing
		1283
		1284	Returns the official number of playing players, as per the Crossfire metaserver rules.
		1285
		1286	=cut
		1287
		1288	sub num_playing {
		1289	scalar grep
		1290	$_->ob->map
		1291	&& !$_->hidden
		1292	&& !$_->ob->flag (cf::FLAG_WIZ),
		1293	cf::player::list
		1294	}
		1295
1290	=item cf::player::find $login	1296	=item cf::player::find $login
1291		1297
1292	Returns the given player object, loading it if necessary (might block).	1298	Returns the given player object, loading it if necessary (might block).
1293		1299
1294	=cut	1300	=cut
…		…
1329	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";	1335	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1330	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";	1336	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1331	aio_unlink +(playerdir $login) . "/$login.pl.pst";	1337	aio_unlink +(playerdir $login) . "/$login.pl.pst";
1332	aio_unlink +(playerdir $login) . "/$login.pl";	1338	aio_unlink +(playerdir $login) . "/$login.pl";
1333		1339
1334	my $pl = load_pl path $login	1340	my $f = new_from_file cf::object::thawer path $login
1335	or return;	1341	or return;
		1342
		1343	$f->next;
		1344	my $pl = cf::player::load_pl $f
		1345	or return;
		1346	local $cf::PLAYER_LOADING{$login} = $pl;
		1347	$f->resolve_delayed_derefs;
1336	$cf::PLAYER{$login} = $pl	1348	$cf::PLAYER{$login} = $pl
1337	}	1349	}
1338	}	1350	}
1339	}	1351	}
1340		1352
…		…
1350		1362
1351	aio_mkdir playerdir $pl, 0770;	1363	aio_mkdir playerdir $pl, 0770;
1352	$pl->{last_save} = $cf::RUNTIME;	1364	$pl->{last_save} = $cf::RUNTIME;
1353		1365
1354	$pl->save_pl ($path);	1366	$pl->save_pl ($path);
1355	Coro::cede;	1367	cf::cede_to_tick;
1356	}	1368	}
1357		1369
1358	sub new($) {	1370	sub new($) {
1359	my ($login) = @_;	1371	my ($login) = @_;
1360		1372
…		…
1364	$self->{deny_save} = 1;	1376	$self->{deny_save} = 1;
1365		1377
1366	$cf::PLAYER{$login} = $self;	1378	$cf::PLAYER{$login} = $self;
1367		1379
1368	$self	1380	$self
		1381	}
		1382
		1383	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1384
		1385	=cut
		1386
		1387	sub send_msg {
		1388	my $ns = shift->ns
		1389	or return;
		1390	$ns->send_msg (@_);
1369	}	1391	}
1370		1392
1371	=item $pl->quit_character	1393	=item $pl->quit_character
1372		1394
1373	Nukes the player without looking back. If logged in, the connection will	1395	Nukes the player without looking back. If logged in, the connection will
…		…
1428	or return [];	1450	or return [];
1429		1451
1430	my @logins;	1452	my @logins;
1431		1453
1432	for my $login (@$dirs) {	1454	for my $login (@$dirs) {
		1455	my $path = path $login;
		1456
		1457	# a .pst is a dead give-away for a valid player
		1458	unless (-e "$path.pst") {
1433	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;	1459	my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1434	aio_read $fh, 0, 512, my $buf, 0 or next;	1460	aio_read $fh, 0, 512, my $buf, 0 or next;
1435	$buf !~ /^password -------------$/m or next; # official not-valid tag	1461	$buf !~ /^password -------------$/m or next; # official not-valid tag
		1462	}
1436		1463
1437	utf8::decode $login;	1464	utf8::decode $login;
1438	push @logins, $login;	1465	push @logins, $login;
1439	}	1466	}
1440		1467
…		…
1478	sub expand_cfpod {	1505	sub expand_cfpod {
1479	((my $self), (local $_)) = @_;	1506	((my $self), (local $_)) = @_;
1480		1507
1481	# escape & and <	1508	# escape & and <
1482	s/&/&/g;	1509	s/&/&/g;
1483	s/(?<![BIUGH])</</g;	1510	s/(?<![BIUGHT])</</g;
1484		1511
1485	# this is buggy, it needs to properly take care of nested <'s	1512	# this is buggy, it needs to properly take care of nested <'s
1486		1513
1487	1 while	1514	1 while
1488	# replace B<>, I<>, U<> etc.	1515	# replace B<>, I<>, U<> etc.
1489	s/B<([^\>]*)>/<b>$1<\/b>/	1516	s/B<([^\>]*)>/<b>$1<\/b>/
1490	\|\| s/I<([^\>]*)>/<i>$1<\/i>/	1517	\|\| s/I<([^\>]*)>/<i>$1<\/i>/
1491	\|\| s/U<([^\>]*)>/<u>$1<\/u>/	1518	\|\| s/U<([^\>]*)>/<u>$1<\/u>/
		1519	\|\| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1492	# replace G<male\|female> tags	1520	# replace G<male\|female> tags
1493	\|\| s{G<([^>\|])\\|([^>])>}{	1521	\|\| s{G<([^>\|])\\|([^>])>}{
1494	$self->gender ? $2 : $1	1522	$self->gender ? $2 : $1
1495	}ge	1523	}ge
1496	# replace H<hint text>	1524	# replace H<hint text>
…		…
1517	sub hintmode {	1545	sub hintmode {
1518	$_[0]{hintmode} = $_[1] if @_ > 1;	1546	$_[0]{hintmode} = $_[1] if @_ > 1;
1519	$_[0]{hintmode}	1547	$_[0]{hintmode}
1520	}	1548	}
1521		1549
1522	=item $player->ext_reply ($msgid, %msg)	1550	=item $player->ext_reply ($msgid, @msg)
1523		1551
1524	Sends an ext reply to the player.	1552	Sends an ext reply to the player.
1525		1553
1526	=cut	1554	=cut
1527		1555
1528	sub ext_reply($$%) {	1556	sub ext_reply($$@) {
1529	my ($self, $id, %msg) = @_;	1557	my ($self, $id, @msg) = @_;
1530		1558
1531	$msg{msgid} = $id;	1559	$self->ns->ext_reply ($id, @msg)
1532	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1533	}	1560	}
1534		1561
1535	=item $player->ext_event ($type, %msg)	1562	=item $player->ext_msg ($type, @msg)
1536		1563
1537	Sends an ext event to the client.	1564	Sends an ext event to the client.
1538		1565
1539	=cut	1566	=cut
1540		1567
1541	sub ext_event($$%) {	1568	sub ext_msg($$@) {
1542	my ($self, $type, %msg) = @_;	1569	my ($self, $type, @msg) = @_;
1543		1570
1544	$self->ns->ext_event ($type, %msg);	1571	$self->ns->ext_msg ($type, @msg);
1545	}	1572	}
1546		1573
1547	=head3 cf::region	1574	=head3 cf::region
1548		1575
1549	=over 4	1576	=over 4
…		…
1765		1792
1766	sub load_header_from($) {	1793	sub load_header_from($) {
1767	my ($self, $path) = @_;	1794	my ($self, $path) = @_;
1768		1795
1769	utf8::encode $path;	1796	utf8::encode $path;
1770	#aio_open $path, O_RDONLY, 0	1797	my $f = new_from_file cf::object::thawer $path
1771	# or return;
1772
1773	$self->_load_header ($path)
1774	or return;	1798	or return;
		1799
		1800	$self->_load_header ($f)
		1801	or return;
		1802
		1803	local $MAP_LOADING{$self->{path}} = $self;
		1804	$f->resolve_delayed_derefs;
1775		1805
1776	$self->{load_path} = $path;	1806	$self->{load_path} = $path;
1777		1807
1778	1	1808	1
1779	}	1809	}
…		…
1833	sub find {	1863	sub find {
1834	my ($path, $origin) = @_;	1864	my ($path, $origin) = @_;
1835		1865
1836	$path = normalise $path, $origin && $origin->path;	1866	$path = normalise $path, $origin && $origin->path;
1837		1867
		1868	cf::lock_wait "map_data:$path";#d#remove
1838	cf::lock_wait "map_find:$path";	1869	cf::lock_wait "map_find:$path";
1839		1870
1840	$cf::MAP{$path} \|\| do {	1871	$cf::MAP{$path} \|\| do {
1841	my $guard = cf::lock_acquire "map_find:$path";	1872	my $guard1 = cf::lock_acquire "map_find:$path";
		1873	my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
		1874
1842	my $map = new_from_path cf::map $path	1875	my $map = new_from_path cf::map $path
1843	or return;	1876	or return;
1844		1877
1845	$map->{last_save} = $cf::RUNTIME;	1878	$map->{last_save} = $cf::RUNTIME;
1846		1879
…		…
1848	or return;	1881	or return;
1849		1882
1850	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)	1883	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1851	# doing this can freeze the server in a sync job, obviously	1884	# doing this can freeze the server in a sync job, obviously
1852	#$cf::WAIT_FOR_TICK->wait;	1885	#$cf::WAIT_FOR_TICK->wait;
		1886	undef $guard1;
		1887	undef $guard2;
1853	$map->reset;	1888	$map->reset;
1854	undef $guard;
1855	return find $path;	1889	return find $path;
1856	}	1890	}
1857		1891
1858	$cf::MAP{$path} = $map	1892	$cf::MAP{$path} = $map
1859	}	1893	}
…		…
1868	local $self->{deny_reset} = 1; # loading can take a long time	1902	local $self->{deny_reset} = 1; # loading can take a long time
1869		1903
1870	my $path = $self->{path};	1904	my $path = $self->{path};
1871		1905
1872	{	1906	{
1873	my $guard = cf::lock_acquire "map_load:$path";	1907	my $guard = cf::lock_acquire "map_data:$path";
1874		1908
		1909	return unless $self->valid;
1875	return if $self->in_memory != cf::MAP_SWAPPED;	1910	return unless $self->in_memory == cf::MAP_SWAPPED;
1876		1911
1877	$self->in_memory (cf::MAP_LOADING);	1912	$self->in_memory (cf::MAP_LOADING);
1878		1913
1879	$self->alloc;	1914	$self->alloc;
1880		1915
1881	$self->pre_load;	1916	$self->pre_load;
1882	Coro::cede;	1917	cf::cede_to_tick;
1883		1918
		1919	my $f = new_from_file cf::object::thawer $self->{load_path};
		1920	$f->skip_block;
1884	$self->_load_objects ($self->{load_path}, 1)	1921	$self->_load_objects ($f)
1885	or return;	1922	or return;
1886		1923
1887	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	1924	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1888	if delete $self->{load_original};	1925	if delete $self->{load_original};
1889		1926
1890	if (my $uniq = $self->uniq_path) {	1927	if (my $uniq = $self->uniq_path) {
1891	utf8::encode $uniq;	1928	utf8::encode $uniq;
1892	if (aio_open $uniq, O_RDONLY, 0) {	1929	unless (aio_stat $uniq) {
		1930	if (my $f = new_from_file cf::object::thawer $uniq) {
1893	$self->clear_unique_items;	1931	$self->clear_unique_items;
1894	$self->_load_objects ($uniq, 0);	1932	$self->_load_objects ($f);
		1933	$f->resolve_delayed_derefs;
		1934	}
1895	}	1935	}
1896	}	1936	}
1897		1937
1898	Coro::cede;	1938	$f->resolve_delayed_derefs;
		1939
		1940	cf::cede_to_tick;
1899	# now do the right thing for maps	1941	# now do the right thing for maps
1900	$self->link_multipart_objects;	1942	$self->link_multipart_objects;
1901	$self->difficulty ($self->estimate_difficulty)	1943	$self->difficulty ($self->estimate_difficulty)
1902	unless $self->difficulty;	1944	unless $self->difficulty;
1903	Coro::cede;	1945	cf::cede_to_tick;
1904		1946
1905	unless ($self->{deny_activate}) {	1947	unless ($self->{deny_activate}) {
1906	$self->decay_objects;	1948	$self->decay_objects;
1907	$self->fix_auto_apply;	1949	$self->fix_auto_apply;
1908	$self->update_buttons;	1950	$self->update_buttons;
1909	Coro::cede;	1951	cf::cede_to_tick;
1910	$self->set_darkness_map;	1952	$self->set_darkness_map;
1911	Coro::cede;	1953	cf::cede_to_tick;
1912	$self->activate;	1954	$self->activate;
1913	}	1955	}
		1956
		1957	$self->{last_save} = $cf::RUNTIME;
		1958	$self->last_access ($cf::RUNTIME);
1914		1959
1915	$self->in_memory (cf::MAP_IN_MEMORY);	1960	$self->in_memory (cf::MAP_IN_MEMORY);
1916	}	1961	}
1917		1962
1918	$self->post_load;	1963	$self->post_load;
…		…
1929		1974
1930	$self	1975	$self
1931	}	1976	}
1932		1977
1933	# find and load all maps in the 3x3 area around a map	1978	# find and load all maps in the 3x3 area around a map
1934	sub load_diag {	1979	sub load_neighbours {
1935	my ($map) = @_;	1980	my ($map) = @_;
1936		1981
1937	my @diag; # diagonal neighbours	1982	my @neigh; # diagonal neighbours
1938		1983
1939	for (0 .. 3) {	1984	for (0 .. 3) {
1940	my $neigh = $map->tile_path ($_)	1985	my $neigh = $map->tile_path ($_)
1941	or next;	1986	or next;
1942	$neigh = find $neigh, $map	1987	$neigh = find $neigh, $map
1943	or next;	1988	or next;
1944	$neigh->load;	1989	$neigh->load;
1945		1990
		1991	push @neigh,
1946	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],	1992	[$neigh->tile_path (($_ + 3) % 4), $neigh],
1947	[$neigh->tile_path (($_ + 1) % 4), $neigh];	1993	[$neigh->tile_path (($_ + 1) % 4), $neigh];
1948	}	1994	}
1949		1995
1950	for (@diag) {	1996	for (grep defined $_->[0], @neigh) {
		1997	my ($path, $origin) = @$_;
1951	my $neigh = find @$_	1998	my $neigh = find $path, $origin
1952	or next;	1999	or next;
1953	$neigh->load;	2000	$neigh->load;
1954	}	2001	}
1955	}	2002	}
1956		2003
…		…
1961	}	2008	}
1962		2009
1963	sub do_load_sync {	2010	sub do_load_sync {
1964	my ($map) = @_;	2011	my ($map) = @_;
1965		2012
		2013	cf::LOG cf::llevDebug \| cf::logBacktrace, "do_load_sync"
		2014	if $Coro::current == $Coro::main;
		2015
1966	cf::sync_job { $map->load };	2016	cf::sync_job { $map->load };
1967	}	2017	}
1968		2018
1969	our %MAP_PREFETCH;	2019	our %MAP_PREFETCH;
1970	our $MAP_PREFETCHER = undef;	2020	our $MAP_PREFETCHER = undef;
1971		2021
1972	sub find_async {	2022	sub find_async {
1973	my ($path, $origin) = @_;	2023	my ($path, $origin, $load) = @_;
1974		2024
1975	$path = normalise $path, $origin && $origin->{path};	2025	$path = normalise $path, $origin && $origin->{path};
1976		2026
1977	if (my $map = $cf::MAP{$path}) {	2027	if (my $map = $cf::MAP{$path}) {
1978	return $map if $map->in_memory == cf::MAP_IN_MEMORY;	2028	return $map if !$load \|\| $map->in_memory == cf::MAP_IN_MEMORY;
1979	}	2029	}
1980		2030
1981	undef $MAP_PREFETCH{$path};	2031	$MAP_PREFETCH{$path} \|= $load;
		2032
1982	$MAP_PREFETCHER \|\|= cf::async {	2033	$MAP_PREFETCHER \|\|= cf::async {
1983	while (%MAP_PREFETCH) {	2034	while (%MAP_PREFETCH) {
1984	for my $path (keys %MAP_PREFETCH) {	2035	while (my ($k, $v) = each %MAP_PREFETCH) {
1985	if (my $map = find $path) {	2036	if (my $map = find $k) {
1986	$map->load;	2037	$map->load if $v;
1987	}	2038	}
1988		2039
1989	delete $MAP_PREFETCH{$path};	2040	delete $MAP_PREFETCH{$k};
1990	}	2041	}
1991	}	2042	}
1992	undef $MAP_PREFETCHER;	2043	undef $MAP_PREFETCHER;
1993	};	2044	};
1994	$MAP_PREFETCHER->prio (6);	2045	$MAP_PREFETCHER->prio (6);
…		…
1997	}	2048	}
1998		2049
1999	sub save {	2050	sub save {
2000	my ($self) = @_;	2051	my ($self) = @_;
2001		2052
2002	my $lock = cf::lock_acquire "map_data:" . $self->path;	2053	my $lock = cf::lock_acquire "map_data:$self->{path}";
2003		2054
2004	$self->{last_save} = $cf::RUNTIME;	2055	$self->{last_save} = $cf::RUNTIME;
2005		2056
2006	return unless $self->dirty;	2057	return unless $self->dirty;
2007		2058
…		…
2030	my ($self) = @_;	2081	my ($self) = @_;
2031		2082
2032	# save first because save cedes	2083	# save first because save cedes
2033	$self->save;	2084	$self->save;
2034		2085
2035	my $lock = cf::lock_acquire "map_data:" . $self->path;	2086	my $lock = cf::lock_acquire "map_data:$self->{path}";
2036		2087
2037	return if $self->players;	2088	return if $self->players;
2038	return if $self->in_memory != cf::MAP_IN_MEMORY;	2089	return if $self->in_memory != cf::MAP_IN_MEMORY;
2039	return if $self->{deny_save};	2090	return if $self->{deny_save};
2040		2091
		2092	$self->in_memory (cf::MAP_SWAPPED);
		2093
		2094	$self->deactivate;
		2095	$_->clear_links_to ($self) for values %cf::MAP;
2041	$self->clear;	2096	$self->clear;
2042	$self->in_memory (cf::MAP_SWAPPED);
2043	}	2097	}
2044		2098
2045	sub reset_at {	2099	sub reset_at {
2046	my ($self) = @_;	2100	my ($self) = @_;
2047		2101
…		…
2079	if $uniq;	2133	if $uniq;
2080	}	2134	}
2081		2135
2082	delete $cf::MAP{$self->path};	2136	delete $cf::MAP{$self->path};
2083		2137
		2138	$self->deactivate;
		2139	$_->clear_links_to ($self) for values %cf::MAP;
2084	$self->clear;	2140	$self->clear;
2085
2086	$_->clear_links_to ($self) for values %cf::MAP;
2087		2141
2088	$self->unlink_save;	2142	$self->unlink_save;
2089	$self->destroy;	2143	$self->destroy;
2090	}	2144	}
2091		2145
2092	my $nuke_counter = "aaaa";	2146	my $nuke_counter = "aaaa";
2093		2147
2094	sub nuke {	2148	sub nuke {
2095	my ($self) = @_;	2149	my ($self) = @_;
2096		2150
		2151	{
		2152	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2153
2097	delete $cf::MAP{$self->path};	2154	delete $cf::MAP{$self->path};
2098		2155
2099	$self->unlink_save;	2156	$self->unlink_save;
2100		2157
2101	bless $self, "cf::map";	2158	bless $self, "cf::map";
2102	delete $self->{deny_reset};	2159	delete $self->{deny_reset};
2103	$self->{deny_save} = 1;	2160	$self->{deny_save} = 1;
2104	$self->reset_timeout (1);	2161	$self->reset_timeout (1);
2105	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2162	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2106		2163
2107	$cf::MAP{$self->path} = $self;	2164	$cf::MAP{$self->path} = $self;
		2165	}
2108		2166
2109	$self->reset; # polite request, might not happen	2167	$self->reset; # polite request, might not happen
2110	}	2168	}
2111		2169
2112	=item $maps = cf::map::tmp_maps	2170	=item $maps = cf::map::tmp_maps
…		…
2188		2246
2189	sub inv_recursive {	2247	sub inv_recursive {
2190	inv_recursive_ inv $_[0]	2248	inv_recursive_ inv $_[0]
2191	}	2249	}
2192		2250
		2251	=item $ref = $ob->ref
		2252
		2253	creates and returns a persistent reference to an objetc that can be stored as a string.
		2254
		2255	=item $ob = cf::object::deref ($refstring)
		2256
		2257	returns the objetc referenced by refstring. may return undef when it cnanot find the object,
		2258	even if the object actually exists. May block.
		2259
		2260	=cut
		2261
		2262	sub deref {
		2263	my ($ref) = @_;
		2264
		2265	# temporary compatibility#TODO#remove
		2266	$ref =~ s{^<}{player/<};
		2267
		2268	if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
		2269	my ($uuid, $name) = ($1, $2);
		2270	my $pl = $cf::PLAYER_LOADING{$name} \|\| cf::player::find $name
		2271	or return;
		2272	$pl->ob->uuid eq $uuid
		2273	or return;
		2274
		2275	$pl->ob
		2276	} else {
		2277	warn "$ref: cannot resolve object reference\n";
		2278	undef
		2279	}
		2280	}
		2281
2193	package cf;	2282	package cf;
2194		2283
2195	=back	2284	=back
2196		2285
2197	=head3 cf::object::player	2286	=head3 cf::object::player
…		…
2219		2308
2220	} else {	2309	} else {
2221	my $pl = $self->contr;	2310	my $pl = $self->contr;
2222		2311
2223	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2312	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2224	my $diag = $pl->{npc_dialog};	2313	my $dialog = $pl->{npc_dialog};
2225	$diag->{pl}->ext_reply (	2314	$dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2226	$diag->{id},
2227	msgtype => "reply",
2228	msg => $diag->{pl}->expand_cfpod ($msg),
2229	add_topics => []
2230	);
2231		2315
2232	} else {	2316	} else {
2233	$msg = $npc->name . " says: $msg" if $npc;	2317	$msg = $npc->name . " says: $msg" if $npc;
2234	$self->message ($msg, $flags);	2318	$self->message ($msg, $flags);
2235	}	2319	}
2236	}	2320	}
		2321	}
		2322
		2323	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2324
		2325	=cut
		2326
		2327	sub cf::object::send_msg {
		2328	my $pl = shift->contr
		2329	or return;
		2330	$pl->send_msg (@_);
2237	}	2331	}
2238		2332
2239	=item $player_object->may ("access")	2333	=item $player_object->may ("access")
2240		2334
2241	Returns wether the given player is authorized to access resource "access"	2335	Returns wether the given player is authorized to access resource "access"
…		…
2320	# use -1 or undef as default coordinates, not 0, 0	2414	# use -1 or undef as default coordinates, not 0, 0
2321	($x, $y) = ($map->enter_x, $map->enter_y)	2415	($x, $y) = ($map->enter_x, $map->enter_y)
2322	if $x <=0 && $y <= 0;	2416	if $x <=0 && $y <= 0;
2323		2417
2324	$map->load;	2418	$map->load;
2325	$map->load_diag;	2419	$map->load_neighbours;
2326		2420
2327	return unless $self->contr->active;	2421	return unless $self->contr->active;
2328	$self->activate_recursive;	2422	$self->activate_recursive;
2329		2423
2330	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2424	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
…		…
2501	the message, with C<log> being the default. If C<$color> is negative, suppress	2595	the message, with C<log> being the default. If C<$color> is negative, suppress
2502	the message unless the client supports the msg packet.	2596	the message unless the client supports the msg packet.
2503		2597
2504	=cut	2598	=cut
2505		2599
		2600	our %CHANNEL = (
		2601	"c/identify" => {
		2602	id => "identify",
		2603	title => "Identify",
		2604	reply => undef,
		2605	tooltip => "Items recently identified",
		2606	},
		2607	"c/examine" => {
		2608	id => "examine",
		2609	title => "Examine",
		2610	reply => undef,
		2611	tooltip => "Signs and other items you examined",
		2612	},
		2613	);
		2614
2506	sub cf::client::send_msg {	2615	sub cf::client::send_msg {
2507	my ($self, $channel, $msg, $color, @extra) = @_;	2616	my ($self, $channel, $msg, $color, @extra) = @_;
2508		2617
2509	$msg = $self->pl->expand_cfpod ($msg);	2618	$msg = $self->pl->expand_cfpod ($msg);
2510		2619
2511	$color &= ~cf::NDI_UNIQUE; # just in case...	2620	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2621
		2622	# check predefined channels, for the benefit of C
		2623	$channel = $CHANNEL{$channel} if $CHANNEL{$channel};
2512		2624
2513	if (ref $channel) {	2625	if (ref $channel) {
2514	# send meta info to client, if not yet sent	2626	# send meta info to client, if not yet sent
2515	unless (exists $self->{channel}{$channel->{id}}) {	2627	unless (exists $self->{channel}{$channel->{id}}) {
2516	$self->{channel}{$channel->{id}} = $channel;	2628	$self->{channel}{$channel->{id}} = $channel;
2517	$self->ext_event (channel_info => %$channel);	2629	$self->ext_msg (channel_info => $channel)
		2630	if $self->can_msg;
2518	}	2631	}
2519		2632
2520	$channel = $channel->{id};	2633	$channel = $channel->{id};
2521	}	2634	}
2522		2635
2523	return unless @extra \|\| length $msg;	2636	return unless @extra \|\| length $msg;
2524		2637
2525	if ($self->can_msg) {	2638	if ($self->can_msg) {
		2639	# default colour, mask it out
		2640	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2641	if $color & cf::NDI_DEF;
		2642
2526	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra]));	2643	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2644	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2527	} else {	2645	} else {
2528	# replace some tags by gcfclient-compatible ones
2529	for ($msg) {
2530	1 while
2531	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2532	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2533	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2534	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2535	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2536	}
2537
2538	if ($color >= 0) {	2646	if ($color >= 0) {
		2647	# replace some tags by gcfclient-compatible ones
		2648	for ($msg) {
		2649	1 while
		2650	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2651	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2652	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2653	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2654	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2655	}
		2656
		2657	$color &= cf::NDI_COLOR_MASK;
		2658
		2659	utf8::encode $msg;
		2660
2539	if (0 && $msg =~ /\[/) {	2661	if (0 && $msg =~ /\[/) {
		2662	# COMMAND/INFO
2540	$self->send_packet ("drawextinfo $color 4 0 $msg")	2663	$self->send_packet ("drawextinfo $color 10 8 $msg")
2541	} else {	2664	} else {
2542	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2665	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2543	$self->send_packet ("drawinfo $color $msg")	2666	$self->send_packet ("drawinfo $color $msg")
2544	}	2667	}
2545	}	2668	}
2546	}	2669	}
2547	}	2670	}
2548		2671
2549	=item $client->ext_event ($type, %msg)	2672	=item $client->ext_msg ($type, @msg)
2550		2673
2551	Sends an ext event to the client.	2674	Sends an ext event to the client.
2552		2675
2553	=cut	2676	=cut
2554		2677
2555	sub cf::client::ext_event($$%) {	2678	sub cf::client::ext_msg($$@) {
2556	my ($self, $type, %msg) = @_;	2679	my ($self, $type, @msg) = @_;
2557		2680
2558	return unless $self->extcmd;	2681	if ($self->extcmd == 2) {
2559		2682	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2683	} elsif ($self->extcmd == 1) { # TODO: remove
2560	$msg{msgtype} = "event_$type";	2684	push @msg, msgtype => "event_$type";
2561	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2685	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2686	}
		2687	}
		2688
		2689	=item $client->ext_reply ($msgid, @msg)
		2690
		2691	Sends an ext reply to the client.
		2692
		2693	=cut
		2694
		2695	sub cf::client::ext_reply($$@) {
		2696	my ($self, $id, @msg) = @_;
		2697
		2698	if ($self->extcmd == 2) {
		2699	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
		2700	} elsif ($self->extcmd == 1) {
		2701	#TODO: version 1, remove
		2702	unshift @msg, msgtype => "reply", msgid => $id;
		2703	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2704	}
2562	}	2705	}
2563		2706
2564	=item $success = $client->query ($flags, "text", \&cb)	2707	=item $success = $client->query ($flags, "text", \&cb)
2565		2708
2566	Queues a query to the client, calling the given callback with	2709	Queues a query to the client, calling the given callback with
…		…
2621	my ($ns, $buf) = @_;	2764	my ($ns, $buf) = @_;
2622		2765
2623	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2766	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2624		2767
2625	if (ref $msg) {	2768	if (ref $msg) {
		2769	my ($type, $reply, @payload) =
		2770	"ARRAY" eq ref $msg
		2771	? @$msg
		2772	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2773
		2774	my @reply;
		2775
2626	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2776	if (my $cb = $EXTICMD{$type}) {
2627	if (my %reply = $cb->($ns, $msg)) {	2777	@reply = $cb->($ns, @payload);
2628	$reply{msgid} = $msg->{msgid};
2629	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2630	}
2631	}	2778	}
		2779
		2780	$ns->ext_reply ($reply, @reply)
		2781	if $reply;
		2782
2632	} else {	2783	} else {
2633	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2784	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2634	}	2785	}
2635		2786
2636	cf::override;	2787	cf::override;
…		…
2683	our $safe = new Safe "safe";	2834	our $safe = new Safe "safe";
2684	our $safe_hole = new Safe::Hole;	2835	our $safe_hole = new Safe::Hole;
2685		2836
2686	$SIG{FPE} = 'IGNORE';	2837	$SIG{FPE} = 'IGNORE';
2687		2838
2688	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2839	$safe->permit_only (Opcode::opset qw(
		2840	:base_core :base_mem :base_orig :base_math
		2841	grepstart grepwhile mapstart mapwhile
		2842	sort time
		2843	));
2689		2844
2690	# here we export the classes and methods available to script code	2845	# here we export the classes and methods available to script code
2691		2846
2692	=pod	2847	=pod
2693		2848
2694	The following functions and methods are available within a safe environment:	2849	The following functions and methods are available within a safe environment:
2695		2850
2696	cf::object	2851	cf::object
2697	contr pay_amount pay_player map x y force_find force_add	2852	contr pay_amount pay_player map x y force_find force_add
2698	insert remove	2853	insert remove name archname title slaying race decrease_ob_nr
2699		2854
2700	cf::object::player	2855	cf::object::player
2701	player	2856	player
2702		2857
2703	cf::player	2858	cf::player
…		…
2708		2863
2709	=cut	2864	=cut
2710		2865
2711	for (	2866	for (
2712	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2867	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2868	insert remove inv name archname title slaying race
2713	insert remove)],	2869	decrease_ob_nr)],
2714	["cf::object::player" => qw(player)],	2870	["cf::object::player" => qw(player)],
2715	["cf::player" => qw(peaceful)],	2871	["cf::player" => qw(peaceful)],
2716	["cf::map" => qw(trigger)],	2872	["cf::map" => qw(trigger)],
2717	) {	2873	) {
2718	no strict 'refs';	2874	no strict 'refs';
…		…
2794	# the server's init and main functions	2950	# the server's init and main functions
2795		2951
2796	sub load_facedata($) {	2952	sub load_facedata($) {
2797	my ($path) = @_;	2953	my ($path) = @_;
2798		2954
		2955	# HACK to clear player env face cache, we need some signal framework
		2956	# for this (global event?)
		2957	%ext::player_env::MUSIC_FACE_CACHE = ();
		2958
		2959	my $enc = JSON::XS->new->utf8->canonical->relaxed;
		2960
2799	warn "loading facedata from $path\n";	2961	warn "loading facedata from $path\n";
2800		2962
2801	my $facedata;	2963	my $facedata;
2802	0 < aio_load $path, $facedata	2964	0 < aio_load $path, $facedata
2803	or die "$path: $!";	2965	or die "$path: $!";
2804		2966
2805	$facedata = Coro::Storable::thaw $facedata;	2967	$facedata = Coro::Storable::thaw $facedata;
2806		2968
2807	$facedata->{version} == 2	2969	$facedata->{version} == 2
2808	or cf::cleanup "$path: version mismatch, cannot proceed.";	2970	or cf::cleanup "$path: version mismatch, cannot proceed.";
		2971
		2972	# patch in the exptable
		2973	$facedata->{resource}{"res/exp_table"} = {
		2974	type => FT_RSRC,
		2975	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
		2976	};
		2977	cf::cede_to_tick;
2809		2978
2810	{	2979	{
2811	my $faces = $facedata->{faceinfo};	2980	my $faces = $facedata->{faceinfo};
2812		2981
2813	while (my ($face, $info) = each %$faces) {	2982	while (my ($face, $info) = each %$faces) {
2814	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2983	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2815	cf::face::set_visibility $idx, $info->{visibility};	2984	cf::face::set_visibility $idx, $info->{visibility};
2816	cf::face::set_magicmap $idx, $info->{magicmap};	2985	cf::face::set_magicmap $idx, $info->{magicmap};
2817	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2986	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2818	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2987	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2819		2988
2820	cf::cede_to_tick;	2989	cf::cede_to_tick;
2821	}	2990	}
2822		2991
2823	while (my ($face, $info) = each %$faces) {	2992	while (my ($face, $info) = each %$faces) {
…		…
2848		3017
2849	{	3018	{
2850	# TODO: for gcfclient pleasure, we should give resources	3019	# TODO: for gcfclient pleasure, we should give resources
2851	# that gcfclient doesn't grok a >10000 face index.	3020	# that gcfclient doesn't grok a >10000 face index.
2852	my $res = $facedata->{resource};	3021	my $res = $facedata->{resource};
2853	my $enc = JSON::XS->new->utf8->canonical;	3022
		3023	my $soundconf = delete $res->{"res/sound.conf"};
2854		3024
2855	while (my ($name, $info) = each %$res) {	3025	while (my ($name, $info) = each %$res) {
2856	my $meta = $enc->encode ({
2857	name => $name,
2858	type => $info->{type},
2859	copyright => $info->{copyright}, #TODO#
2860	});
2861
2862	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	3026	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		3027	my $data;
2863		3028
2864	if ($name =~ /\.jpg$/) {	3029	if ($info->{type} & 1) {
2865	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack	3030	# prepend meta info
2866	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack	3031
		3032	my $meta = $enc->encode ({
		3033	name => $name,
		3034	%{ $info->{meta} \|\| {} },
		3035	});
		3036
		3037	$data = pack "(w/a)", $meta, $info->{data};
2867	} else {	3038	} else {
2868	my $data = pack "(w/a)", $meta, $info->{data};	3039	$data = $info->{data};
2869	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2870
2871	cf::face::set_type $idx, 1;
2872	cf::face::set_data $idx, 0, $data, $chk;
2873	}	3040	}
2874		3041
		3042	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
		3043	cf::face::set_type $idx, $info->{type};
		3044
2875	cf::cede_to_tick;	3045	cf::cede_to_tick;
2876	}	3046	}
		3047
		3048	if ($soundconf) {
		3049	$soundconf = $enc->decode (delete $soundconf->{data});
		3050
		3051	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3052	my $sound = $soundconf->{compat}[$_]
		3053	or next;
		3054
		3055	my $face = cf::face::find "sound/$sound->[1]";
		3056	cf::sound::set $sound->[0] => $face;
		3057	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3058	}
		3059
		3060	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3061	my $face = cf::face::find "sound/$v";
		3062	cf::sound::set $k => $face;
		3063	}
		3064	}
2877	}	3065	}
2878		3066
2879	1	3067	1
2880	}	3068	}
2881		3069
		3070	register_exticmd fx_want => sub {
		3071	my ($ns, $want) = @_;
		3072
		3073	while (my ($k, $v) = each %$want) {
		3074	$ns->fx_want ($k, $v);
		3075	}
		3076	};
		3077
2882	sub reload_regions {	3078	sub reload_regions {
		3079	# HACK to clear player env face cache, we need some signal framework
		3080	# for this (global event?)
		3081	%ext::player_env::MUSIC_FACE_CACHE = ();
		3082
2883	load_resource_file "$MAPDIR/regions"	3083	load_resource_file "$MAPDIR/regions"
2884	or die "unable to load regions file\n";	3084	or die "unable to load regions file\n";
2885		3085
2886	for (cf::region::list) {	3086	for (cf::region::list) {
2887	$_->{match} = qr/$_->{match}/	3087	$_->{match} = qr/$_->{match}/
…		…
2923		3123
2924	sub init {	3124	sub init {
2925	reload_resources;	3125	reload_resources;
2926	}	3126	}
2927		3127
2928	sub cfg_load {	3128	sub reload_config {
2929	open my $fh, "<:utf8", "$CONFDIR/config"	3129	open my $fh, "<:utf8", "$CONFDIR/config"
2930	or return;	3130	or return;
2931		3131
2932	local $/;	3132	local $/;
2933	*CFG = YAML::Syck::Load <$fh>;	3133	*CFG = YAML::Syck::Load <$fh>;
…		…
2953	(async {	3153	(async {
2954	Event::one_event;	3154	Event::one_event;
2955	})->prio (Coro::PRIO_MAX);	3155	})->prio (Coro::PRIO_MAX);
2956	};	3156	};
2957		3157
2958	cfg_load;	3158	reload_config;
2959	db_init;	3159	db_init;
2960	load_extensions;	3160	load_extensions;
2961		3161
2962	$TICK_WATCHER->start;	3162	$TICK_WATCHER->start;
2963	Event::loop;	3163	Event::loop;
…		…
3156	warn "reloading cf.pm";	3356	warn "reloading cf.pm";
3157	require cf;	3357	require cf;
3158	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3358	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3159		3359
3160	warn "loading config and database again";	3360	warn "loading config and database again";
3161	cf::cfg_load;	3361	cf::reload_config;
3162		3362
3163	warn "loading extensions";	3363	warn "loading extensions";
3164	cf::load_extensions;	3364	cf::load_extensions;
3165		3365
3166	warn "reattaching attachments to objects/players";	3366	warn "reattaching attachments to objects/players";
…		…
3259	or die;	3459	or die;
3260		3460
3261	$map->width (50);	3461	$map->width (50);
3262	$map->height (50);	3462	$map->height (50);
3263	$map->alloc;	3463	$map->alloc;
3264	$map->_load_objects ("/tmp/x.map", 1);	3464	$map->_load_objects ("/tmp/x.map", 1); #TODO: does not work
3265	my $t = Event::time - $t;	3465	my $t = Event::time - $t;
3266		3466
3267	#next unless $t < 0.0013;#d#	3467	#next unless $t < 0.0013;#d#
3268	if ($t < $min) {	3468	if ($t < $min) {
3269	$min = $t;	3469	$min = $t;

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.315 by root, Mon Jul 23 17:53:55 2007 UTC vs. Revision 1.361 by root, Sun Sep 9 12:52:48 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.315 by root, Mon Jul 23 17:53:55 2007 UTC vs.
Revision 1.361 by root, Sun Sep 9 12:52:48 2007 UTC