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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC vs.
Revision 1.356 by root, Tue Sep 4 05:43:21 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
…		…
166	=item cf::wait_for_tick, cf::wait_for_tick_begin	167	=item cf::wait_for_tick, cf::wait_for_tick_begin
167		168
168	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	169	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
169	returns directly I<after> the tick processing (and consequently, can only wake one process	170	returns directly I<after> the tick processing (and consequently, can only wake one process
170	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	171	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
		172
		173	=item @cf::INVOKE_RESULTS
		174
		175	This array contains the results of the last C<invoke ()> call. When
		176	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
		177	that call.
171		178
172	=back	179	=back
173		180
174	=cut	181	=cut
175		182
…		…
265	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
266	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,
267	for example when the coroutine gets canceled), the lock is automatically	274	for example when the coroutine gets canceled), the lock is automatically
268	returned.	275	returned.
269		276
		277	Locks are not recursive, locking from the same coro twice results in a
		278	deadlocked coro.
		279
270	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
271	uses map_find and cf::map::load uses map_load).	281	uses map_find and cf::map::load uses map_load).
272		282
273	=item $locked = cf::lock_active $string	283	=item $locked = cf::lock_active $string
274		284
…		…
314	my $guard = Coro::guard {	324	my $guard = Coro::guard {
315	$TICK_WATCHER->start;	325	$TICK_WATCHER->start;
316	};	326	};
317	$TICK_WATCHER->stop;	327	$TICK_WATCHER->stop;
318	$guard	328	$guard
		329	}
		330
		331	=item cf::get_slot $time[, $priority[, $name]]
		332
		333	Allocate $time seconds of blocking CPU time at priority C<$priority>:
		334	This call blocks and returns only when you have at least C<$time> seconds
		335	of cpu time till the next tick. The slot is only valid till the next cede.
		336
		337	The optional C<$name> can be used to identify the job to run. It might be
		338	used for statistical purposes and should identify the same time-class.
		339
		340	Useful for short background jobs.
		341
		342	=cut
		343
		344	our @SLOT_QUEUE;
		345	our $SLOT_QUEUE;
		346
		347	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
		348	$SLOT_QUEUE = Coro::async {
		349	my $signal = new Coro::Signal;
		350
		351	while () {
		352	next_job:
		353	my $avail = cf::till_tick;
		354	if ($avail > 0.01) {
		355	for (0 .. $#SLOT_QUEUE) {
		356	if ($SLOT_QUEUE[$_][0] < $avail) {
		357	my $job = splice @SLOT_QUEUE, $_, 1, ();
		358	$job->[2]->send;
		359	Coro::cede;
		360	goto next_job;
		361	}
		362	}
		363	}
		364
		365	if (@SLOT_QUEUE) {
		366	# we do not use wait_For_tick() as it returns immediately when tick is inactive
		367	push @cf::WAIT_FOR_TICK, $signal;
		368	$signal->wait;
		369	} else {
		370	Coro::schedule;
		371	}
		372	}
		373	};
		374
		375	sub get_slot($;$$) {
		376	my ($time, $pri, $name) = @_;
		377
		378	$time = $TICK * .6 if $time > $TICK * .6;
		379	my $sig = new Coro::Signal;
		380
		381	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
		382	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
		383	$SLOT_QUEUE->ready;
		384	$sig->wait;
319	}	385	}
320		386
321	=item cf::async { BLOCK }	387	=item cf::async { BLOCK }
322		388
323	Currently the same as Coro::async_pool, meaning you cannot use	389	Currently the same as Coro::async_pool, meaning you cannot use
…		…
410	Coro::Storable. May, of course, block. Note that the executed sub may	476	Coro::Storable. May, of course, block. Note that the executed sub may
411	never block itself or use any form of Event handling.	477	never block itself or use any form of Event handling.
412		478
413	=cut	479	=cut
414		480
415	sub _store_scalar {
416	open my $fh, ">", \my $buf
417	or die "fork_call: cannot open fh-to-buf in child : $!";
418	Storable::store_fd $_[0], $fh;
419	close $fh;
420
421	$buf
422	}
423
424	sub fork_call(&@) {	481	sub fork_call(&@) {
425	my ($cb, @args) = @_;	482	my ($cb, @args) = @_;
426		483
427	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC	484	# we seemingly have to make a local copy of the whole thing,
428	# or die "socketpair: $!";	485	# otherwise perl prematurely frees the stuff :/
429	pipe my $fh1, my $fh2	486	# TODO: investigate and fix (likely this will be rather laborious)
430	or die "pipe: $!";
431		487
432	if (my $pid = fork) {	488	my @res = Coro::Util::fork_eval {
433	close $fh2;
434
435	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
436	warn "pst<$res>" unless $res =~ /^pst/;
437	$res = Coro::Storable::thaw $res;
438
439	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
440
441	Carp::confess $$res unless "ARRAY" eq ref $res;
442
443	return wantarray ? @$res : $res->[-1];
444	} else {
445	reset_signals;	489	reset_signals;
446	local $SIG{__WARN__};	490	&$cb
447	local $SIG{__DIE__};	491	}, @args;
448	# just in case, this hack effectively disables event
449	# in the child. cleaner and slower would be canceling all watchers,
450	# but this works for the time being.
451	local $Coro::idle;
452	$Coro::current->prio (Coro::PRIO_MAX);
453		492
454	eval {	493	wantarray ? @res : $res[-1]
455	close $fh1;
456
457	my @res = eval { $cb->(@args) };
458
459	syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
460	close $fh2;
461	};
462
463	warn $@ if $@;
464	_exit 0;
465	}
466	}	494	}
467		495
468	=item $value = cf::db_get $family => $key	496	=item $value = cf::db_get $family => $key
469		497
470	Returns a single value from the environment database.	498	Returns a single value from the environment database.
…		…
550	if (1) {	578	if (1) {
551	$md5 =	579	$md5 =
552	join "\x00",	580	join "\x00",
553	$processversion,	581	$processversion,
554	map {	582	map {
555	Coro::cede;	583	cf::cede_to_tick;
556	($src->[$_], Digest::MD5::md5_hex $data[$_])	584	($src->[$_], Digest::MD5::md5_hex $data[$_])
557	} 0.. $#$src;	585	} 0.. $#$src;
558		586
559		587
560	my $dbmd5 = db_get cache => "$id/md5";	588	my $dbmd5 = db_get cache => "$id/md5";
…		…
866	";	894	";
867	die if $@;	895	die if $@;
868	}	896	}
869		897
870	our $override;	898	our $override;
871	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	899	our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
872		900
873	sub override {	901	sub override {
874	$override = 1;	902	$override = 1;
875	@invoke_results = ();	903	@INVOKE_RESULTS = (@_);
876	}	904	}
877		905
878	sub do_invoke {	906	sub do_invoke {
879	my $event = shift;	907	my $event = shift;
880	my $callbacks = shift;	908	my $callbacks = shift;
881		909
882	@invoke_results = ();	910	@INVOKE_RESULTS = ();
883		911
884	local $override;	912	local $override;
885		913
886	for (@$callbacks) {	914	for (@$callbacks) {
887	eval { &{$_->[1]} };	915	eval { &{$_->[1]} };
…		…
904		932
905	Generate an object-specific event with the given arguments.	933	Generate an object-specific event with the given arguments.
906		934
907	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be	935	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
908	removed in future versions), and there is no public API to access override	936	removed in future versions), and there is no public API to access override
909	results (if you must, access C<@cf::invoke_results> directly).	937	results (if you must, access C<@cf::INVOKE_RESULTS> directly).
910		938
911	=back	939	=back
912		940
913	=cut	941	=cut
914		942
915	#############################################################################	943	#############################################################################
916	# object support	944	# object support
		945	#
		946
		947	sub _can_merge {
		948	my ($ob1, $ob2) = @_;
		949
		950	local $Storable::canonical = 1;
		951	my $fob1 = Storable::freeze $ob1;
		952	my $fob2 = Storable::freeze $ob2;
		953
		954	$fob1 eq $fob2
		955	}
917		956
918	sub reattach {	957	sub reattach {
919	# basically do the same as instantiate, without calling instantiate	958	# basically do the same as instantiate, without calling instantiate
920	my ($obj) = @_;	959	my ($obj) = @_;
921		960
…		…
965	},	1004	},
966	);	1005	);
967		1006
968	sub object_freezer_save {	1007	sub object_freezer_save {
969	my ($filename, $rdata, $objs) = @_;	1008	my ($filename, $rdata, $objs) = @_;
		1009
		1010	my $guard = cf::lock_acquire "io";
970		1011
971	sync_job {	1012	sync_job {
972	if (length $$rdata) {	1013	if (length $$rdata) {
973	warn sprintf "saving %s (%d,%d)\n",	1014	warn sprintf "saving %s (%d,%d)\n",
974	$filename, length $$rdata, scalar @$objs;	1015	$filename, length $$rdata, scalar @$objs;
…		…
998	}	1039	}
999	} else {	1040	} else {
1000	aio_unlink $filename;	1041	aio_unlink $filename;
1001	aio_unlink "$filename.pst";	1042	aio_unlink "$filename.pst";
1002	}	1043	}
1003	}	1044	};
		1045
		1046	undef $guard;
1004	}	1047	}
1005		1048
1006	sub object_freezer_as_string {	1049	sub object_freezer_as_string {
1007	my ($rdata, $objs) = @_;	1050	my ($rdata, $objs) = @_;
1008		1051
…		…
1013		1056
1014	sub object_thawer_load {	1057	sub object_thawer_load {
1015	my ($filename) = @_;	1058	my ($filename) = @_;
1016		1059
1017	my ($data, $av);	1060	my ($data, $av);
		1061
		1062	my $guard = cf::lock_acquire "io";
1018		1063
1019	(aio_load $filename, $data) >= 0	1064	(aio_load $filename, $data) >= 0
1020	or return;	1065	or return;
1021		1066
1022	unless (aio_stat "$filename.pst") {	1067	unless (aio_stat "$filename.pst") {
1023	(aio_load "$filename.pst", $av) >= 0	1068	(aio_load "$filename.pst", $av) >= 0
1024	or return;	1069	or return;
		1070
		1071	undef $guard;
1025	$av = eval { (Storable::thaw $av)->{objs} };	1072	$av = eval { (Storable::thaw $av)->{objs} };
1026	}	1073	}
1027		1074
1028	warn sprintf "loading %s (%d)\n",	1075	warn sprintf "loading %s (%d)\n",
1029	$filename, length $data, scalar @{$av \|\| []};	1076	$filename, length $data, scalar @{$av \|\| []};
		1077
1030	return ($data, $av);	1078	($data, $av)
1031	}	1079	}
1032		1080
1033	=head2 COMMAND CALLBACKS	1081	=head2 COMMAND CALLBACKS
1034		1082
1035	=over 4	1083	=over 4
…		…
1108	my ($pl, $buf) = @_;	1156	my ($pl, $buf) = @_;
1109		1157
1110	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1158	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1111		1159
1112	if (ref $msg) {	1160	if (ref $msg) {
		1161	my ($type, $reply, @payload) =
		1162	"ARRAY" eq ref $msg
		1163	? @$msg
		1164	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		1165
		1166	my @reply;
		1167
1113	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1168	if (my $cb = $EXTCMD{$type}) {
1114	if (my %reply = $cb->($pl, $msg)) {	1169	@reply = $cb->($pl, @payload);
1115	$pl->ext_reply ($msg->{msgid}, %reply);
1116	}
1117	}	1170	}
		1171
		1172	$pl->ext_reply ($reply, @reply)
		1173	if $reply;
		1174
1118	} else {	1175	} else {
1119	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1176	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1120	}	1177	}
1121		1178
1122	cf::override;	1179	cf::override;
…		…
1256	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";	1313	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1257	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";	1314	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1258	aio_unlink +(playerdir $login) . "/$login.pl.pst";	1315	aio_unlink +(playerdir $login) . "/$login.pl.pst";
1259	aio_unlink +(playerdir $login) . "/$login.pl";	1316	aio_unlink +(playerdir $login) . "/$login.pl";
1260		1317
1261	my $pl = load_pl path $login	1318	my $f = new_from_file cf::object::thawer path $login
1262	or return;	1319	or return;
		1320
		1321	$f->next;
		1322	my $pl = cf::player::load_pl $f
		1323	or return;
		1324	local $cf::PLAYER_LOADING{$login} = $pl;
		1325	$f->resolve_delayed_derefs;
1263	$cf::PLAYER{$login} = $pl	1326	$cf::PLAYER{$login} = $pl
1264	}	1327	}
1265	}	1328	}
1266	}	1329	}
1267		1330
…		…
1277		1340
1278	aio_mkdir playerdir $pl, 0770;	1341	aio_mkdir playerdir $pl, 0770;
1279	$pl->{last_save} = $cf::RUNTIME;	1342	$pl->{last_save} = $cf::RUNTIME;
1280		1343
1281	$pl->save_pl ($path);	1344	$pl->save_pl ($path);
1282	Coro::cede;	1345	cf::cede_to_tick;
1283	}	1346	}
1284		1347
1285	sub new($) {	1348	sub new($) {
1286	my ($login) = @_;	1349	my ($login) = @_;
1287		1350
…		…
1291	$self->{deny_save} = 1;	1354	$self->{deny_save} = 1;
1292		1355
1293	$cf::PLAYER{$login} = $self;	1356	$cf::PLAYER{$login} = $self;
1294		1357
1295	$self	1358	$self
		1359	}
		1360
		1361	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1362
		1363	=cut
		1364
		1365	sub send_msg {
		1366	my $ns = shift->ns
		1367	or return;
		1368	$ns->send_msg (@_);
1296	}	1369	}
1297		1370
1298	=item $pl->quit_character	1371	=item $pl->quit_character
1299		1372
1300	Nukes the player without looking back. If logged in, the connection will	1373	Nukes the player without looking back. If logged in, the connection will
…		…
1355	or return [];	1428	or return [];
1356		1429
1357	my @logins;	1430	my @logins;
1358		1431
1359	for my $login (@$dirs) {	1432	for my $login (@$dirs) {
		1433	my $path = path $login;
		1434
		1435	# a .pst is a dead give-away for a valid player
		1436	unless (-e "$path.pst") {
1360	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;	1437	my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1361	aio_read $fh, 0, 512, my $buf, 0 or next;	1438	aio_read $fh, 0, 512, my $buf, 0 or next;
1362	$buf !~ /^password -------------$/m or next; # official not-valid tag	1439	$buf !~ /^password -------------$/m or next; # official not-valid tag
		1440	}
1363		1441
1364	utf8::decode $login;	1442	utf8::decode $login;
1365	push @logins, $login;	1443	push @logins, $login;
1366	}	1444	}
1367		1445
…		…
1405	sub expand_cfpod {	1483	sub expand_cfpod {
1406	((my $self), (local $_)) = @_;	1484	((my $self), (local $_)) = @_;
1407		1485
1408	# escape & and <	1486	# escape & and <
1409	s/&/&/g;	1487	s/&/&/g;
1410	s/(?<![BIUGH])</</g;	1488	s/(?<![BIUGHT])</</g;
1411		1489
1412	# this is buggy, it needs to properly take care of nested <'s	1490	# this is buggy, it needs to properly take care of nested <'s
1413		1491
1414	1 while	1492	1 while
1415	# replace B<>, I<>, U<> etc.	1493	# replace B<>, I<>, U<> etc.
1416	s/B<([^\>]*)>/<b>$1<\/b>/	1494	s/B<([^\>]*)>/<b>$1<\/b>/
1417	\|\| s/I<([^\>]*)>/<i>$1<\/i>/	1495	\|\| s/I<([^\>]*)>/<i>$1<\/i>/
1418	\|\| s/U<([^\>]*)>/<u>$1<\/u>/	1496	\|\| s/U<([^\>]*)>/<u>$1<\/u>/
		1497	\|\| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1419	# replace G<male\|female> tags	1498	# replace G<male\|female> tags
1420	\|\| s{G<([^>\|])\\|([^>])>}{	1499	\|\| s{G<([^>\|])\\|([^>])>}{
1421	$self->gender ? $2 : $1	1500	$self->gender ? $2 : $1
1422	}ge	1501	}ge
1423	# replace H<hint text>	1502	# replace H<hint text>
…		…
1444	sub hintmode {	1523	sub hintmode {
1445	$_[0]{hintmode} = $_[1] if @_ > 1;	1524	$_[0]{hintmode} = $_[1] if @_ > 1;
1446	$_[0]{hintmode}	1525	$_[0]{hintmode}
1447	}	1526	}
1448		1527
1449	=item $player->ext_reply ($msgid, %msg)	1528	=item $player->ext_reply ($msgid, @msg)
1450		1529
1451	Sends an ext reply to the player.	1530	Sends an ext reply to the player.
1452		1531
1453	=cut	1532	=cut
1454		1533
1455	sub ext_reply($$%) {	1534	sub ext_reply($$@) {
1456	my ($self, $id, %msg) = @_;	1535	my ($self, $id, @msg) = @_;
1457		1536
1458	$msg{msgid} = $id;	1537	$self->ns->ext_reply ($id, @msg)
1459	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1460	}	1538	}
1461		1539
1462	=item $player->ext_event ($type, %msg)	1540	=item $player->ext_msg ($type, @msg)
1463		1541
1464	Sends an ext event to the client.	1542	Sends an ext event to the client.
1465		1543
1466	=cut	1544	=cut
1467		1545
1468	sub ext_event($$%) {	1546	sub ext_msg($$@) {
1469	my ($self, $type, %msg) = @_;	1547	my ($self, $type, @msg) = @_;
1470		1548
1471	$self->ns->ext_event ($type, %msg);	1549	$self->ns->ext_msg ($type, @msg);
1472	}	1550	}
1473		1551
1474	=head3 cf::region	1552	=head3 cf::region
1475		1553
1476	=over 4	1554	=over 4
…		…
1692		1770
1693	sub load_header_from($) {	1771	sub load_header_from($) {
1694	my ($self, $path) = @_;	1772	my ($self, $path) = @_;
1695		1773
1696	utf8::encode $path;	1774	utf8::encode $path;
1697	#aio_open $path, O_RDONLY, 0	1775	my $f = new_from_file cf::object::thawer $path
1698	# or return;
1699
1700	$self->_load_header ($path)
1701	or return;	1776	or return;
		1777
		1778	$self->_load_header ($f)
		1779	or return;
		1780
		1781	local $MAP_LOADING{$self->{path}} = $self;
		1782	$f->resolve_delayed_derefs;
1702		1783
1703	$self->{load_path} = $path;	1784	$self->{load_path} = $path;
1704		1785
1705	1	1786	1
1706	}	1787	}
…		…
1795	local $self->{deny_reset} = 1; # loading can take a long time	1876	local $self->{deny_reset} = 1; # loading can take a long time
1796		1877
1797	my $path = $self->{path};	1878	my $path = $self->{path};
1798		1879
1799	{	1880	{
		1881	my $guard1 = cf::lock_acquire "map_data:$path";
1800	my $guard = cf::lock_acquire "map_load:$path";	1882	my $guard2 = cf::lock_acquire "map_load:$path";
1801		1883
1802	return if $self->in_memory != cf::MAP_SWAPPED;	1884	return if $self->in_memory != cf::MAP_SWAPPED;
1803		1885
1804	$self->in_memory (cf::MAP_LOADING);	1886	$self->in_memory (cf::MAP_LOADING);
1805		1887
1806	$self->alloc;	1888	$self->alloc;
1807		1889
1808	$self->pre_load;	1890	$self->pre_load;
1809	Coro::cede;	1891	cf::cede_to_tick;
1810		1892
		1893	my $f = new_from_file cf::object::thawer $self->{load_path};
		1894	$f->skip_block;
1811	$self->_load_objects ($self->{load_path}, 1)	1895	$self->_load_objects ($f)
1812	or return;	1896	or return;
1813		1897
1814	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	1898	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1815	if delete $self->{load_original};	1899	if delete $self->{load_original};
1816		1900
1817	if (my $uniq = $self->uniq_path) {	1901	if (my $uniq = $self->uniq_path) {
1818	utf8::encode $uniq;	1902	utf8::encode $uniq;
1819	if (aio_open $uniq, O_RDONLY, 0) {	1903	unless (aio_stat $uniq) {
		1904	if (my $f = new_from_file cf::object::thawer $uniq) {
1820	$self->clear_unique_items;	1905	$self->clear_unique_items;
1821	$self->_load_objects ($uniq, 0);	1906	$self->_load_objects ($f);
		1907	$f->resolve_delayed_derefs;
		1908	}
1822	}	1909	}
1823	}	1910	}
1824		1911
1825	Coro::cede;	1912	$f->resolve_delayed_derefs;
		1913
		1914	cf::cede_to_tick;
1826	# now do the right thing for maps	1915	# now do the right thing for maps
1827	$self->link_multipart_objects;	1916	$self->link_multipart_objects;
1828	$self->difficulty ($self->estimate_difficulty)	1917	$self->difficulty ($self->estimate_difficulty)
1829	unless $self->difficulty;	1918	unless $self->difficulty;
1830	Coro::cede;	1919	cf::cede_to_tick;
1831		1920
1832	unless ($self->{deny_activate}) {	1921	unless ($self->{deny_activate}) {
1833	$self->decay_objects;	1922	$self->decay_objects;
1834	$self->fix_auto_apply;	1923	$self->fix_auto_apply;
1835	$self->update_buttons;	1924	$self->update_buttons;
1836	Coro::cede;	1925	cf::cede_to_tick;
1837	$self->set_darkness_map;	1926	$self->set_darkness_map;
1838	Coro::cede;	1927	cf::cede_to_tick;
1839	$self->activate;	1928	$self->activate;
1840	}	1929	}
		1930
		1931	$self->{last_save} = $cf::RUNTIME;
		1932	$self->last_access ($cf::RUNTIME);
1841		1933
1842	$self->in_memory (cf::MAP_IN_MEMORY);	1934	$self->in_memory (cf::MAP_IN_MEMORY);
1843	}	1935	}
1844		1936
1845	$self->post_load;	1937	$self->post_load;
…		…
1856		1948
1857	$self	1949	$self
1858	}	1950	}
1859		1951
1860	# find and load all maps in the 3x3 area around a map	1952	# find and load all maps in the 3x3 area around a map
1861	sub load_diag {	1953	sub load_neighbours {
1862	my ($map) = @_;	1954	my ($map) = @_;
1863		1955
1864	my @diag; # diagonal neighbours	1956	my @neigh; # diagonal neighbours
1865		1957
1866	for (0 .. 3) {	1958	for (0 .. 3) {
1867	my $neigh = $map->tile_path ($_)	1959	my $neigh = $map->tile_path ($_)
1868	or next;	1960	or next;
1869	$neigh = find $neigh, $map	1961	$neigh = find $neigh, $map
1870	or next;	1962	or next;
1871	$neigh->load;	1963	$neigh->load;
1872		1964
		1965	push @neigh,
1873	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],	1966	[$neigh->tile_path (($_ + 3) % 4), $neigh],
1874	[$neigh->tile_path (($_ + 1) % 4), $neigh];	1967	[$neigh->tile_path (($_ + 1) % 4), $neigh];
1875	}	1968	}
1876		1969
1877	for (@diag) {	1970	for (grep defined $_->[0], @neigh) {
		1971	my ($path, $origin) = @$_;
1878	my $neigh = find @$_	1972	my $neigh = find $path, $origin
1879	or next;	1973	or next;
1880	$neigh->load;	1974	$neigh->load;
1881	}	1975	}
1882	}	1976	}
1883		1977
…		…
1888	}	1982	}
1889		1983
1890	sub do_load_sync {	1984	sub do_load_sync {
1891	my ($map) = @_;	1985	my ($map) = @_;
1892		1986
		1987	cf::LOG cf::llevDebug \| cf::logBacktrace, "do_load_sync"
		1988	if $Coro::current == $Coro::main;
		1989
1893	cf::sync_job { $map->load };	1990	cf::sync_job { $map->load };
1894	}	1991	}
1895		1992
1896	our %MAP_PREFETCH;	1993	our %MAP_PREFETCH;
1897	our $MAP_PREFETCHER = undef;	1994	our $MAP_PREFETCHER = undef;
1898		1995
1899	sub find_async {	1996	sub find_async {
1900	my ($path, $origin) = @_;	1997	my ($path, $origin, $load) = @_;
1901		1998
1902	$path = normalise $path, $origin && $origin->{path};	1999	$path = normalise $path, $origin && $origin->{path};
1903		2000
1904	if (my $map = $cf::MAP{$path}) {	2001	if (my $map = $cf::MAP{$path}) {
1905	return $map if $map->in_memory == cf::MAP_IN_MEMORY;	2002	return $map if !$load \|\| $map->in_memory == cf::MAP_IN_MEMORY;
1906	}	2003	}
1907		2004
1908	undef $MAP_PREFETCH{$path};	2005	$MAP_PREFETCH{$path} \|= $load;
		2006
1909	$MAP_PREFETCHER \|\|= cf::async {	2007	$MAP_PREFETCHER \|\|= cf::async {
1910	while (%MAP_PREFETCH) {	2008	while (%MAP_PREFETCH) {
1911	for my $path (keys %MAP_PREFETCH) {	2009	while (my ($k, $v) = each %MAP_PREFETCH) {
1912	if (my $map = find $path) {	2010	if (my $map = find $k) {
1913	$map->load;	2011	$map->load if $v;
1914	}	2012	}
1915		2013
1916	delete $MAP_PREFETCH{$path};	2014	delete $MAP_PREFETCH{$k};
1917	}	2015	}
1918	}	2016	}
1919	undef $MAP_PREFETCHER;	2017	undef $MAP_PREFETCHER;
1920	};	2018	};
1921	$MAP_PREFETCHER->prio (6);	2019	$MAP_PREFETCHER->prio (6);
…		…
1924	}	2022	}
1925		2023
1926	sub save {	2024	sub save {
1927	my ($self) = @_;	2025	my ($self) = @_;
1928		2026
1929	my $lock = cf::lock_acquire "map_data:" . $self->path;	2027	my $lock = cf::lock_acquire "map_data:$self->{path}";
1930		2028
1931	$self->{last_save} = $cf::RUNTIME;	2029	$self->{last_save} = $cf::RUNTIME;
1932		2030
1933	return unless $self->dirty;	2031	return unless $self->dirty;
1934		2032
…		…
1957	my ($self) = @_;	2055	my ($self) = @_;
1958		2056
1959	# save first because save cedes	2057	# save first because save cedes
1960	$self->save;	2058	$self->save;
1961		2059
1962	my $lock = cf::lock_acquire "map_data:" . $self->path;	2060	my $lock = cf::lock_acquire "map_data:$self->{path}";
1963		2061
1964	return if $self->players;	2062	return if $self->players;
1965	return if $self->in_memory != cf::MAP_IN_MEMORY;	2063	return if $self->in_memory != cf::MAP_IN_MEMORY;
1966	return if $self->{deny_save};	2064	return if $self->{deny_save};
1967		2065
…		…
2019	my $nuke_counter = "aaaa";	2117	my $nuke_counter = "aaaa";
2020		2118
2021	sub nuke {	2119	sub nuke {
2022	my ($self) = @_;	2120	my ($self) = @_;
2023		2121
		2122	{
		2123	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2124
2024	delete $cf::MAP{$self->path};	2125	delete $cf::MAP{$self->path};
2025		2126
2026	$self->unlink_save;	2127	$self->unlink_save;
2027		2128
2028	bless $self, "cf::map";	2129	bless $self, "cf::map";
2029	delete $self->{deny_reset};	2130	delete $self->{deny_reset};
2030	$self->{deny_save} = 1;	2131	$self->{deny_save} = 1;
2031	$self->reset_timeout (1);	2132	$self->reset_timeout (1);
2032	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2133	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2033		2134
2034	$cf::MAP{$self->path} = $self;	2135	$cf::MAP{$self->path} = $self;
		2136	}
2035		2137
2036	$self->reset; # polite request, might not happen	2138	$self->reset; # polite request, might not happen
2037	}	2139	}
2038		2140
2039	=item $maps = cf::map::tmp_maps	2141	=item $maps = cf::map::tmp_maps
…		…
2115		2217
2116	sub inv_recursive {	2218	sub inv_recursive {
2117	inv_recursive_ inv $_[0]	2219	inv_recursive_ inv $_[0]
2118	}	2220	}
2119		2221
		2222	=item $ref = $ob->ref
		2223
		2224	creates and returns a persistent reference to an objetc that can be stored as a string.
		2225
		2226	=item $ob = cf::object::deref ($refstring)
		2227
		2228	returns the objetc referenced by refstring. may return undef when it cnanot find the object,
		2229	even if the object actually exists. May block.
		2230
		2231	=cut
		2232
		2233	sub deref {
		2234	my ($ref) = @_;
		2235
		2236	# temporary compatibility#TODO#remove
		2237	$ref =~ s{^<}{player/<};
		2238
		2239	if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
		2240	my ($uuid, $name) = ($1, $2);
		2241	my $pl = $cf::PLAYER_LOADING{$name} \|\| cf::player::find $name
		2242	or return;
		2243	$pl->ob->uuid eq $uuid
		2244	or return;
		2245
		2246	$pl->ob
		2247	} else {
		2248	warn "$ref: cannot resolve object reference\n";
		2249	undef
		2250	}
		2251	}
		2252
2120	package cf;	2253	package cf;
2121		2254
2122	=back	2255	=back
2123		2256
2124	=head3 cf::object::player	2257	=head3 cf::object::player
…		…
2146		2279
2147	} else {	2280	} else {
2148	my $pl = $self->contr;	2281	my $pl = $self->contr;
2149		2282
2150	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2283	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2151	my $diag = $pl->{npc_dialog};	2284	my $dialog = $pl->{npc_dialog};
2152	$diag->{pl}->ext_reply (	2285	$dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2153	$diag->{id},
2154	msgtype => "reply",
2155	msg => $diag->{pl}->expand_cfpod ($msg),
2156	add_topics => []
2157	);
2158		2286
2159	} else {	2287	} else {
2160	$msg = $npc->name . " says: $msg" if $npc;	2288	$msg = $npc->name . " says: $msg" if $npc;
2161	$self->message ($msg, $flags);	2289	$self->message ($msg, $flags);
2162	}	2290	}
2163	}	2291	}
		2292	}
		2293
		2294	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2295
		2296	=cut
		2297
		2298	sub cf::object::send_msg {
		2299	my $pl = shift->contr
		2300	or return;
		2301	$pl->send_msg (@_);
2164	}	2302	}
2165		2303
2166	=item $player_object->may ("access")	2304	=item $player_object->may ("access")
2167		2305
2168	Returns wether the given player is authorized to access resource "access"	2306	Returns wether the given player is authorized to access resource "access"
…		…
2247	# use -1 or undef as default coordinates, not 0, 0	2385	# use -1 or undef as default coordinates, not 0, 0
2248	($x, $y) = ($map->enter_x, $map->enter_y)	2386	($x, $y) = ($map->enter_x, $map->enter_y)
2249	if $x <=0 && $y <= 0;	2387	if $x <=0 && $y <= 0;
2250		2388
2251	$map->load;	2389	$map->load;
2252	$map->load_diag;	2390	$map->load_neighbours;
2253		2391
2254	return unless $self->contr->active;	2392	return unless $self->contr->active;
2255	$self->activate_recursive;	2393	$self->activate_recursive;
2256		2394
2257	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2395	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
…		…
2419		2557
2420	utf8::encode $text;	2558	utf8::encode $text;
2421	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2559	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2422	}	2560	}
2423		2561
2424	=item $client->send_msg ($color, $type, $msg, [extra...])	2562	=item $client->send_msg ($channel, $msg, $color, [extra...])
2425		2563
2426	Send a drawinfo or msg packet to the client, formatting the msg for the	2564	Send a drawinfo or msg packet to the client, formatting the msg for the
2427	client if neccessary. C<$type> should be a string identifying the type of	2565	client if neccessary. C<$type> should be a string identifying the type of
2428	the message, with C<log> being the default. If C<$color> is negative, suppress	2566	the message, with C<log> being the default. If C<$color> is negative, suppress
2429	the message unless the client supports the msg packet.	2567	the message unless the client supports the msg packet.
2430		2568
2431	=cut	2569	=cut
2432		2570
		2571	our %CHANNEL = (
		2572	"c/identify" => {
		2573	id => "identify",
		2574	title => "Identify",
		2575	reply => undef,
		2576	tooltip => "Items recently identified",
		2577	},
		2578	"c/examine" => {
		2579	id => "examine",
		2580	title => "Examine",
		2581	reply => undef,
		2582	tooltip => "Signs and other items you examined",
		2583	},
		2584	);
		2585
2433	sub cf::client::send_msg {	2586	sub cf::client::send_msg {
2434	my ($self, $color, $type, $msg, @extra) = @_;	2587	my ($self, $channel, $msg, $color, @extra) = @_;
2435		2588
2436	$msg = $self->pl->expand_cfpod ($msg);	2589	$msg = $self->pl->expand_cfpod ($msg);
2437		2590
		2591	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2592
		2593	# check predefined channels, for the benefit of C
		2594	$channel = $CHANNEL{$channel} if $CHANNEL{$channel};
		2595
		2596	if (ref $channel) {
		2597	# send meta info to client, if not yet sent
		2598	unless (exists $self->{channel}{$channel->{id}}) {
		2599	$self->{channel}{$channel->{id}} = $channel;
		2600	$self->ext_msg (channel_info => $channel)
		2601	if $self->can_msg;
		2602	}
		2603
		2604	$channel = $channel->{id};
		2605	}
		2606
2438	return unless @extra \|\| length $msg;	2607	return unless @extra \|\| length $msg;
2439		2608
2440	if ($self->can_msg) {	2609	if ($self->can_msg) {
		2610	# default colour, mask it out
		2611	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2612	if $color & cf::NDI_DEF;
		2613
2441	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));	2614	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2615	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2442	} else {	2616	} else {
2443	# replace some tags by gcfclient-compatible ones
2444	for ($msg) {
2445	1 while
2446	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2447	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2448	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2449	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2450	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2451	}
2452
2453	if ($color >= 0) {	2617	if ($color >= 0) {
		2618	# replace some tags by gcfclient-compatible ones
		2619	for ($msg) {
		2620	1 while
		2621	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2622	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2623	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2624	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2625	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2626	}
		2627
		2628	$color &= cf::NDI_COLOR_MASK;
		2629
		2630	utf8::encode $msg;
		2631
2454	if (0 && $msg =~ /\[/) {	2632	if (0 && $msg =~ /\[/) {
		2633	# COMMAND/INFO
2455	$self->send_packet ("drawextinfo $color 4 0 $msg")	2634	$self->send_packet ("drawextinfo $color 10 8 $msg")
2456	} else {	2635	} else {
2457	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2636	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2458	$self->send_packet ("drawinfo $color $msg")	2637	$self->send_packet ("drawinfo $color $msg")
2459	}	2638	}
2460	}	2639	}
2461	}	2640	}
2462	}	2641	}
2463		2642
2464	=item $client->ext_event ($type, %msg)	2643	=item $client->ext_msg ($type, @msg)
2465		2644
2466	Sends an ext event to the client.	2645	Sends an ext event to the client.
2467		2646
2468	=cut	2647	=cut
2469		2648
2470	sub cf::client::ext_event($$%) {	2649	sub cf::client::ext_msg($$@) {
2471	my ($self, $type, %msg) = @_;	2650	my ($self, $type, @msg) = @_;
2472		2651
2473	return unless $self->extcmd;	2652	if ($self->extcmd == 2) {
2474		2653	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2654	} elsif ($self->extcmd == 1) { # TODO: remove
2475	$msg{msgtype} = "event_$type";	2655	push @msg, msgtype => "event_$type";
2476	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2656	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2657	}
		2658	}
		2659
		2660	=item $client->ext_reply ($msgid, @msg)
		2661
		2662	Sends an ext reply to the client.
		2663
		2664	=cut
		2665
		2666	sub cf::client::ext_reply($$@) {
		2667	my ($self, $id, @msg) = @_;
		2668
		2669	if ($self->extcmd == 2) {
		2670	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
		2671	} elsif ($self->extcmd == 1) {
		2672	#TODO: version 1, remove
		2673	unshift @msg, msgtype => "reply", msgid => $id;
		2674	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2675	}
2477	}	2676	}
2478		2677
2479	=item $success = $client->query ($flags, "text", \&cb)	2678	=item $success = $client->query ($flags, "text", \&cb)
2480		2679
2481	Queues a query to the client, calling the given callback with	2680	Queues a query to the client, calling the given callback with
…		…
2536	my ($ns, $buf) = @_;	2735	my ($ns, $buf) = @_;
2537		2736
2538	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2737	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2539		2738
2540	if (ref $msg) {	2739	if (ref $msg) {
		2740	my ($type, $reply, @payload) =
		2741	"ARRAY" eq ref $msg
		2742	? @$msg
		2743	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2744
		2745	my @reply;
		2746
2541	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2747	if (my $cb = $EXTICMD{$type}) {
2542	if (my %reply = $cb->($ns, $msg)) {	2748	@reply = $cb->($ns, @payload);
2543	$reply{msgid} = $msg->{msgid};
2544	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2545	}
2546	}	2749	}
		2750
		2751	$ns->ext_reply ($reply, @reply)
		2752	if $reply;
		2753
2547	} else {	2754	} else {
2548	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2755	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2549	}	2756	}
2550		2757
2551	cf::override;	2758	cf::override;
…		…
2598	our $safe = new Safe "safe";	2805	our $safe = new Safe "safe";
2599	our $safe_hole = new Safe::Hole;	2806	our $safe_hole = new Safe::Hole;
2600		2807
2601	$SIG{FPE} = 'IGNORE';	2808	$SIG{FPE} = 'IGNORE';
2602		2809
2603	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2810	$safe->permit_only (Opcode::opset qw(
		2811	:base_core :base_mem :base_orig :base_math
		2812	grepstart grepwhile mapstart mapwhile
		2813	sort time
		2814	));
2604		2815
2605	# here we export the classes and methods available to script code	2816	# here we export the classes and methods available to script code
2606		2817
2607	=pod	2818	=pod
2608		2819
2609	The following functions and methods are available within a safe environment:	2820	The following functions and methods are available within a safe environment:
2610		2821
2611	cf::object	2822	cf::object
2612	contr pay_amount pay_player map x y force_find force_add	2823	contr pay_amount pay_player map x y force_find force_add
2613	insert remove	2824	insert remove name archname title slaying race decrease_ob_nr
2614		2825
2615	cf::object::player	2826	cf::object::player
2616	player	2827	player
2617		2828
2618	cf::player	2829	cf::player
…		…
2623		2834
2624	=cut	2835	=cut
2625		2836
2626	for (	2837	for (
2627	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2838	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2839	insert remove inv name archname title slaying race
2628	insert remove)],	2840	decrease_ob_nr)],
2629	["cf::object::player" => qw(player)],	2841	["cf::object::player" => qw(player)],
2630	["cf::player" => qw(peaceful)],	2842	["cf::player" => qw(peaceful)],
2631	["cf::map" => qw(trigger)],	2843	["cf::map" => qw(trigger)],
2632	) {	2844	) {
2633	no strict 'refs';	2845	no strict 'refs';
…		…
2709	# the server's init and main functions	2921	# the server's init and main functions
2710		2922
2711	sub load_facedata($) {	2923	sub load_facedata($) {
2712	my ($path) = @_;	2924	my ($path) = @_;
2713		2925
		2926	# HACK to clear player env face cache, we need some signal framework
		2927	# for this (global event?)
		2928	%ext::player_env::MUSIC_FACE_CACHE = ();
		2929
		2930	my $enc = JSON::XS->new->utf8->canonical->relaxed;
		2931
2714	warn "loading facedata from $path\n";	2932	warn "loading facedata from $path\n";
2715		2933
2716	my $facedata;	2934	my $facedata;
2717	0 < aio_load $path, $facedata	2935	0 < aio_load $path, $facedata
2718	or die "$path: $!";	2936	or die "$path: $!";
2719		2937
2720	$facedata = Coro::Storable::thaw $facedata;	2938	$facedata = Coro::Storable::thaw $facedata;
2721		2939
2722	$facedata->{version} == 2	2940	$facedata->{version} == 2
2723	or cf::cleanup "$path: version mismatch, cannot proceed.";	2941	or cf::cleanup "$path: version mismatch, cannot proceed.";
		2942
		2943	# patch in the exptable
		2944	$facedata->{resource}{"res/exp_table"} = {
		2945	type => FT_RSRC,
		2946	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
		2947	};
		2948	cf::cede_to_tick;
2724		2949
2725	{	2950	{
2726	my $faces = $facedata->{faceinfo};	2951	my $faces = $facedata->{faceinfo};
2727		2952
2728	while (my ($face, $info) = each %$faces) {	2953	while (my ($face, $info) = each %$faces) {
2729	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2954	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2730	cf::face::set_visibility $idx, $info->{visibility};	2955	cf::face::set_visibility $idx, $info->{visibility};
2731	cf::face::set_magicmap $idx, $info->{magicmap};	2956	cf::face::set_magicmap $idx, $info->{magicmap};
2732	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2957	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2733	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2958	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2734		2959
2735	cf::cede_to_tick;	2960	cf::cede_to_tick;
2736	}	2961	}
2737		2962
2738	while (my ($face, $info) = each %$faces) {	2963	while (my ($face, $info) = each %$faces) {
…		…
2763		2988
2764	{	2989	{
2765	# TODO: for gcfclient pleasure, we should give resources	2990	# TODO: for gcfclient pleasure, we should give resources
2766	# that gcfclient doesn't grok a >10000 face index.	2991	# that gcfclient doesn't grok a >10000 face index.
2767	my $res = $facedata->{resource};	2992	my $res = $facedata->{resource};
2768	my $enc = JSON::XS->new->utf8->canonical;	2993
		2994	my $soundconf = delete $res->{"res/sound.conf"};
2769		2995
2770	while (my ($name, $info) = each %$res) {	2996	while (my ($name, $info) = each %$res) {
2771	my $meta = $enc->encode ({
2772	name => $name,
2773	type => $info->{type},
2774	copyright => $info->{copyright}, #TODO#
2775	});
2776
2777	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	2997	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		2998	my $data;
2778		2999
2779	if ($name =~ /\.jpg$/) {	3000	if ($info->{type} & 1) {
2780	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack	3001	# prepend meta info
2781	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack	3002
		3003	my $meta = $enc->encode ({
		3004	name => $name,
		3005	%{ $info->{meta} \|\| {} },
		3006	});
		3007
		3008	$data = pack "(w/a)", $meta, $info->{data};
2782	} else {	3009	} else {
2783	my $data = pack "(w/a)", $meta, $info->{data};	3010	$data = $info->{data};
2784	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2785
2786	cf::face::set_type $idx, 1;
2787	cf::face::set_data $idx, 0, $data, $chk;
2788	}	3011	}
2789		3012
		3013	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
		3014	cf::face::set_type $idx, $info->{type};
		3015
2790	cf::cede_to_tick;	3016	cf::cede_to_tick;
2791	}	3017	}
		3018
		3019	if ($soundconf) {
		3020	$soundconf = $enc->decode (delete $soundconf->{data});
		3021
		3022	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3023	my $sound = $soundconf->{compat}[$_]
		3024	or next;
		3025
		3026	my $face = cf::face::find "sound/$sound->[1]";
		3027	cf::sound::set $sound->[0] => $face;
		3028	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3029	}
		3030
		3031	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3032	my $face = cf::face::find "sound/$v";
		3033	cf::sound::set $k => $face;
		3034	}
		3035	}
2792	}	3036	}
2793		3037
2794	1	3038	1
2795	}	3039	}
2796		3040
		3041	register_exticmd fx_want => sub {
		3042	my ($ns, $want) = @_;
		3043
		3044	while (my ($k, $v) = each %$want) {
		3045	$ns->fx_want ($k, $v);
		3046	}
		3047	};
		3048
2797	sub reload_regions {	3049	sub reload_regions {
		3050	# HACK to clear player env face cache, we need some signal framework
		3051	# for this (global event?)
		3052	%ext::player_env::MUSIC_FACE_CACHE = ();
		3053
2798	load_resource_file "$MAPDIR/regions"	3054	load_resource_file "$MAPDIR/regions"
2799	or die "unable to load regions file\n";	3055	or die "unable to load regions file\n";
2800		3056
2801	for (cf::region::list) {	3057	for (cf::region::list) {
2802	$_->{match} = qr/$_->{match}/	3058	$_->{match} = qr/$_->{match}/
…		…
2838		3094
2839	sub init {	3095	sub init {
2840	reload_resources;	3096	reload_resources;
2841	}	3097	}
2842		3098
2843	sub cfg_load {	3099	sub reload_config {
2844	open my $fh, "<:utf8", "$CONFDIR/config"	3100	open my $fh, "<:utf8", "$CONFDIR/config"
2845	or return;	3101	or return;
2846		3102
2847	local $/;	3103	local $/;
2848	*CFG = YAML::Syck::Load <$fh>;	3104	*CFG = YAML::Syck::Load <$fh>;
…		…
2868	(async {	3124	(async {
2869	Event::one_event;	3125	Event::one_event;
2870	})->prio (Coro::PRIO_MAX);	3126	})->prio (Coro::PRIO_MAX);
2871	};	3127	};
2872		3128
2873	cfg_load;	3129	reload_config;
2874	db_init;	3130	db_init;
2875	load_extensions;	3131	load_extensions;
2876		3132
2877	$TICK_WATCHER->start;	3133	$TICK_WATCHER->start;
2878	Event::loop;	3134	Event::loop;
…		…
3071	warn "reloading cf.pm";	3327	warn "reloading cf.pm";
3072	require cf;	3328	require cf;
3073	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3329	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3074		3330
3075	warn "loading config and database again";	3331	warn "loading config and database again";
3076	cf::cfg_load;	3332	cf::reload_config;
3077		3333
3078	warn "loading extensions";	3334	warn "loading extensions";
3079	cf::load_extensions;	3335	cf::load_extensions;
3080		3336
3081	warn "reattaching attachments to objects/players";	3337	warn "reattaching attachments to objects/players";
…		…
3174	or die;	3430	or die;
3175		3431
3176	$map->width (50);	3432	$map->width (50);
3177	$map->height (50);	3433	$map->height (50);
3178	$map->alloc;	3434	$map->alloc;
3179	$map->_load_objects ("/tmp/x.map", 1);	3435	$map->_load_objects ("/tmp/x.map", 1); #TODO: does not work
3180	my $t = Event::time - $t;	3436	my $t = Event::time - $t;
3181		3437
3182	#next unless $t < 0.0013;#d#	3438	#next unless $t < 0.0013;#d#
3183	if ($t < $min) {	3439	if ($t < $min) {
3184	$min = $t;	3440	$min = $t;

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC vs. Revision 1.356 by root, Tue Sep 4 05:43:21 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC vs.
Revision 1.356 by root, Tue Sep 4 05:43:21 2007 UTC