[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.358 by root, Fri Sep 7 18:10:52 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
275	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.
276		286
277	=cut	287	=cut
278		288
279	our %LOCK;	289	our %LOCK;
		290	our %LOCKER;#d#
280		291
281	sub lock_wait($) {	292	sub lock_wait($) {
282	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#
283		299
284	# wait for lock, if any	300	# wait for lock, if any
285	while ($LOCK{$key}) {	301	while ($LOCK{$key}) {
286	push @{ $LOCK{$key} }, $Coro::current;	302	push @{ $LOCK{$key} }, $Coro::current;
287	Coro::schedule;	303	Coro::schedule;
…		…
293		309
294	# wait, to be sure we are not locked	310	# wait, to be sure we are not locked
295	lock_wait $key;	311	lock_wait $key;
296		312
297	$LOCK{$key} = [];	313	$LOCK{$key} = [];
		314	$LOCKER{$key} = $Coro::current;#d#
298		315
299	Coro::guard {	316	Coro::guard {
		317	delete $LOCKER{$key};#d#
300	# wake up all waiters, to be on the safe side	318	# wake up all waiters, to be on the safe side
301	$_->ready for @{ delete $LOCK{$key} };	319	$_->ready for @{ delete $LOCK{$key} };
302	}	320	}
303	}	321	}
304		322
…		…
314	my $guard = Coro::guard {	332	my $guard = Coro::guard {
315	$TICK_WATCHER->start;	333	$TICK_WATCHER->start;
316	};	334	};
317	$TICK_WATCHER->stop;	335	$TICK_WATCHER->stop;
318	$guard	336	$guard
		337	}
		338
		339	=item cf::get_slot $time[, $priority[, $name]]
		340
		341	Allocate $time seconds of blocking CPU time at priority C<$priority>:
		342	This call blocks and returns only when you have at least C<$time> seconds
		343	of cpu time till the next tick. The slot is only valid till the next cede.
		344
		345	The optional C<$name> can be used to identify the job to run. It might be
		346	used for statistical purposes and should identify the same time-class.
		347
		348	Useful for short background jobs.
		349
		350	=cut
		351
		352	our @SLOT_QUEUE;
		353	our $SLOT_QUEUE;
		354
		355	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
		356	$SLOT_QUEUE = Coro::async {
		357	my $signal = new Coro::Signal;
		358
		359	while () {
		360	next_job:
		361	my $avail = cf::till_tick;
		362	if ($avail > 0.01) {
		363	for (0 .. $#SLOT_QUEUE) {
		364	if ($SLOT_QUEUE[$_][0] < $avail) {
		365	my $job = splice @SLOT_QUEUE, $_, 1, ();
		366	$job->[2]->send;
		367	Coro::cede;
		368	goto next_job;
		369	}
		370	}
		371	}
		372
		373	if (@SLOT_QUEUE) {
		374	# we do not use wait_For_tick() as it returns immediately when tick is inactive
		375	push @cf::WAIT_FOR_TICK, $signal;
		376	$signal->wait;
		377	} else {
		378	Coro::schedule;
		379	}
		380	}
		381	};
		382
		383	sub get_slot($;$$) {
		384	my ($time, $pri, $name) = @_;
		385
		386	$time = $TICK * .6 if $time > $TICK * .6;
		387	my $sig = new Coro::Signal;
		388
		389	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
		390	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
		391	$SLOT_QUEUE->ready;
		392	$sig->wait;
319	}	393	}
320		394
321	=item cf::async { BLOCK }	395	=item cf::async { BLOCK }
322		396
323	Currently the same as Coro::async_pool, meaning you cannot use	397	Currently the same as Coro::async_pool, meaning you cannot use
…		…
410	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
411	never block itself or use any form of Event handling.	485	never block itself or use any form of Event handling.
412		486
413	=cut	487	=cut
414		488
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(&@) {	489	sub fork_call(&@) {
425	my ($cb, @args) = @_;	490	my ($cb, @args) = @_;
426		491
427	# 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,
428	# or die "socketpair: $!";	493	# otherwise perl prematurely frees the stuff :/
429	pipe my $fh1, my $fh2	494	# TODO: investigate and fix (likely this will be rather laborious)
430	or die "pipe: $!";
431		495
432	if (my $pid = fork) {	496	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;	497	reset_signals;
446	local $SIG{__WARN__};	498	&$cb
447	local $SIG{__DIE__};	499	}, @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		500
454	eval {	501	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	}	502	}
467		503
468	=item $value = cf::db_get $family => $key	504	=item $value = cf::db_get $family => $key
469		505
470	Returns a single value from the environment database.	506	Returns a single value from the environment database.
…		…
550	if (1) {	586	if (1) {
551	$md5 =	587	$md5 =
552	join "\x00",	588	join "\x00",
553	$processversion,	589	$processversion,
554	map {	590	map {
555	Coro::cede;	591	cf::cede_to_tick;
556	($src->[$_], Digest::MD5::md5_hex $data[$_])	592	($src->[$_], Digest::MD5::md5_hex $data[$_])
557	} 0.. $#$src;	593	} 0.. $#$src;
558		594
559		595
560	my $dbmd5 = db_get cache => "$id/md5";	596	my $dbmd5 = db_get cache => "$id/md5";
…		…
866	";	902	";
867	die if $@;	903	die if $@;
868	}	904	}
869		905
870	our $override;	906	our $override;
871	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	907	our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
872		908
873	sub override {	909	sub override {
874	$override = 1;	910	$override = 1;
875	@invoke_results = ();	911	@INVOKE_RESULTS = (@_);
876	}	912	}
877		913
878	sub do_invoke {	914	sub do_invoke {
879	my $event = shift;	915	my $event = shift;
880	my $callbacks = shift;	916	my $callbacks = shift;
881		917
882	@invoke_results = ();	918	@INVOKE_RESULTS = ();
883		919
884	local $override;	920	local $override;
885		921
886	for (@$callbacks) {	922	for (@$callbacks) {
887	eval { &{$_->[1]} };	923	eval { &{$_->[1]} };
…		…
904		940
905	Generate an object-specific event with the given arguments.	941	Generate an object-specific event with the given arguments.
906		942
907	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be	943	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	944	removed in future versions), and there is no public API to access override
909	results (if you must, access C<@cf::invoke_results> directly).	945	results (if you must, access C<@cf::INVOKE_RESULTS> directly).
910		946
911	=back	947	=back
912		948
913	=cut	949	=cut
914		950
915	#############################################################################	951	#############################################################################
916	# object support	952	# object support
		953	#
		954
		955	sub _can_merge {
		956	my ($ob1, $ob2) = @_;
		957
		958	local $Storable::canonical = 1;
		959	my $fob1 = Storable::freeze $ob1;
		960	my $fob2 = Storable::freeze $ob2;
		961
		962	$fob1 eq $fob2
		963	}
917		964
918	sub reattach {	965	sub reattach {
919	# basically do the same as instantiate, without calling instantiate	966	# basically do the same as instantiate, without calling instantiate
920	my ($obj) = @_;	967	my ($obj) = @_;
921		968
…		…
965	},	1012	},
966	);	1013	);
967		1014
968	sub object_freezer_save {	1015	sub object_freezer_save {
969	my ($filename, $rdata, $objs) = @_;	1016	my ($filename, $rdata, $objs) = @_;
		1017
		1018	my $guard = cf::lock_acquire "io";
970		1019
971	sync_job {	1020	sync_job {
972	if (length $$rdata) {	1021	if (length $$rdata) {
973	warn sprintf "saving %s (%d,%d)\n",	1022	warn sprintf "saving %s (%d,%d)\n",
974	$filename, length $$rdata, scalar @$objs;	1023	$filename, length $$rdata, scalar @$objs;
…		…
998	}	1047	}
999	} else {	1048	} else {
1000	aio_unlink $filename;	1049	aio_unlink $filename;
1001	aio_unlink "$filename.pst";	1050	aio_unlink "$filename.pst";
1002	}	1051	}
1003	}	1052	};
		1053
		1054	undef $guard;
1004	}	1055	}
1005		1056
1006	sub object_freezer_as_string {	1057	sub object_freezer_as_string {
1007	my ($rdata, $objs) = @_;	1058	my ($rdata, $objs) = @_;
1008		1059
…		…
1013		1064
1014	sub object_thawer_load {	1065	sub object_thawer_load {
1015	my ($filename) = @_;	1066	my ($filename) = @_;
1016		1067
1017	my ($data, $av);	1068	my ($data, $av);
		1069
		1070	my $guard = cf::lock_acquire "io";
1018		1071
1019	(aio_load $filename, $data) >= 0	1072	(aio_load $filename, $data) >= 0
1020	or return;	1073	or return;
1021		1074
1022	unless (aio_stat "$filename.pst") {	1075	unless (aio_stat "$filename.pst") {
1023	(aio_load "$filename.pst", $av) >= 0	1076	(aio_load "$filename.pst", $av) >= 0
1024	or return;	1077	or return;
		1078
		1079	undef $guard;
1025	$av = eval { (Storable::thaw $av)->{objs} };	1080	$av = eval { (Storable::thaw $av)->{objs} };
1026	}	1081	}
1027		1082
1028	warn sprintf "loading %s (%d)\n",	1083	warn sprintf "loading %s (%d)\n",
1029	$filename, length $data, scalar @{$av \|\| []};	1084	$filename, length $data, scalar @{$av \|\| []};
		1085
1030	return ($data, $av);	1086	($data, $av)
1031	}	1087	}
1032		1088
1033	=head2 COMMAND CALLBACKS	1089	=head2 COMMAND CALLBACKS
1034		1090
1035	=over 4	1091	=over 4
…		…
1108	my ($pl, $buf) = @_;	1164	my ($pl, $buf) = @_;
1109		1165
1110	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1166	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1111		1167
1112	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
1113	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1176	if (my $cb = $EXTCMD{$type}) {
1114	if (my %reply = $cb->($pl, $msg)) {	1177	@reply = $cb->($pl, @payload);
1115	$pl->ext_reply ($msg->{msgid}, %reply);
1116	}
1117	}	1178	}
		1179
		1180	$pl->ext_reply ($reply, @reply)
		1181	if $reply;
		1182
1118	} else {	1183	} else {
1119	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1184	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1120	}	1185	}
1121		1186
1122	cf::override;	1187	cf::override;
…		…
1256	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";	1321	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1257	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";	1322	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1258	aio_unlink +(playerdir $login) . "/$login.pl.pst";	1323	aio_unlink +(playerdir $login) . "/$login.pl.pst";
1259	aio_unlink +(playerdir $login) . "/$login.pl";	1324	aio_unlink +(playerdir $login) . "/$login.pl";
1260		1325
1261	my $pl = load_pl path $login	1326	my $f = new_from_file cf::object::thawer path $login
1262	or return;	1327	or return;
		1328
		1329	$f->next;
		1330	my $pl = cf::player::load_pl $f
		1331	or return;
		1332	local $cf::PLAYER_LOADING{$login} = $pl;
		1333	$f->resolve_delayed_derefs;
1263	$cf::PLAYER{$login} = $pl	1334	$cf::PLAYER{$login} = $pl
1264	}	1335	}
1265	}	1336	}
1266	}	1337	}
1267		1338
…		…
1277		1348
1278	aio_mkdir playerdir $pl, 0770;	1349	aio_mkdir playerdir $pl, 0770;
1279	$pl->{last_save} = $cf::RUNTIME;	1350	$pl->{last_save} = $cf::RUNTIME;
1280		1351
1281	$pl->save_pl ($path);	1352	$pl->save_pl ($path);
1282	Coro::cede;	1353	cf::cede_to_tick;
1283	}	1354	}
1284		1355
1285	sub new($) {	1356	sub new($) {
1286	my ($login) = @_;	1357	my ($login) = @_;
1287		1358
…		…
1291	$self->{deny_save} = 1;	1362	$self->{deny_save} = 1;
1292		1363
1293	$cf::PLAYER{$login} = $self;	1364	$cf::PLAYER{$login} = $self;
1294		1365
1295	$self	1366	$self
		1367	}
		1368
		1369	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1370
		1371	=cut
		1372
		1373	sub send_msg {
		1374	my $ns = shift->ns
		1375	or return;
		1376	$ns->send_msg (@_);
1296	}	1377	}
1297		1378
1298	=item $pl->quit_character	1379	=item $pl->quit_character
1299		1380
1300	Nukes the player without looking back. If logged in, the connection will	1381	Nukes the player without looking back. If logged in, the connection will
…		…
1355	or return [];	1436	or return [];
1356		1437
1357	my @logins;	1438	my @logins;
1358		1439
1359	for my $login (@$dirs) {	1440	for my $login (@$dirs) {
		1441	my $path = path $login;
		1442
		1443	# a .pst is a dead give-away for a valid player
		1444	unless (-e "$path.pst") {
1360	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;	1445	my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1361	aio_read $fh, 0, 512, my $buf, 0 or next;	1446	aio_read $fh, 0, 512, my $buf, 0 or next;
1362	$buf !~ /^password -------------$/m or next; # official not-valid tag	1447	$buf !~ /^password -------------$/m or next; # official not-valid tag
		1448	}
1363		1449
1364	utf8::decode $login;	1450	utf8::decode $login;
1365	push @logins, $login;	1451	push @logins, $login;
1366	}	1452	}
1367		1453
…		…
1405	sub expand_cfpod {	1491	sub expand_cfpod {
1406	((my $self), (local $_)) = @_;	1492	((my $self), (local $_)) = @_;
1407		1493
1408	# escape & and <	1494	# escape & and <
1409	s/&/&/g;	1495	s/&/&/g;
1410	s/(?<![BIUGH])</</g;	1496	s/(?<![BIUGHT])</</g;
1411		1497
1412	# this is buggy, it needs to properly take care of nested <'s	1498	# this is buggy, it needs to properly take care of nested <'s
1413		1499
1414	1 while	1500	1 while
1415	# replace B<>, I<>, U<> etc.	1501	# replace B<>, I<>, U<> etc.
1416	s/B<([^\>]*)>/<b>$1<\/b>/	1502	s/B<([^\>]*)>/<b>$1<\/b>/
1417	\|\| s/I<([^\>]*)>/<i>$1<\/i>/	1503	\|\| s/I<([^\>]*)>/<i>$1<\/i>/
1418	\|\| s/U<([^\>]*)>/<u>$1<\/u>/	1504	\|\| s/U<([^\>]*)>/<u>$1<\/u>/
		1505	\|\| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1419	# replace G<male\|female> tags	1506	# replace G<male\|female> tags
1420	\|\| s{G<([^>\|])\\|([^>])>}{	1507	\|\| s{G<([^>\|])\\|([^>])>}{
1421	$self->gender ? $2 : $1	1508	$self->gender ? $2 : $1
1422	}ge	1509	}ge
1423	# replace H<hint text>	1510	# replace H<hint text>
…		…
1444	sub hintmode {	1531	sub hintmode {
1445	$_[0]{hintmode} = $_[1] if @_ > 1;	1532	$_[0]{hintmode} = $_[1] if @_ > 1;
1446	$_[0]{hintmode}	1533	$_[0]{hintmode}
1447	}	1534	}
1448		1535
1449	=item $player->ext_reply ($msgid, %msg)	1536	=item $player->ext_reply ($msgid, @msg)
1450		1537
1451	Sends an ext reply to the player.	1538	Sends an ext reply to the player.
1452		1539
1453	=cut	1540	=cut
1454		1541
1455	sub ext_reply($$%) {	1542	sub ext_reply($$@) {
1456	my ($self, $id, %msg) = @_;	1543	my ($self, $id, @msg) = @_;
1457		1544
1458	$msg{msgid} = $id;	1545	$self->ns->ext_reply ($id, @msg)
1459	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1460	}	1546	}
1461		1547
1462	=item $player->ext_event ($type, %msg)	1548	=item $player->ext_msg ($type, @msg)
1463		1549
1464	Sends an ext event to the client.	1550	Sends an ext event to the client.
1465		1551
1466	=cut	1552	=cut
1467		1553
1468	sub ext_event($$%) {	1554	sub ext_msg($$@) {
1469	my ($self, $type, %msg) = @_;	1555	my ($self, $type, @msg) = @_;
1470		1556
1471	$self->ns->ext_event ($type, %msg);	1557	$self->ns->ext_msg ($type, @msg);
1472	}	1558	}
1473		1559
1474	=head3 cf::region	1560	=head3 cf::region
1475		1561
1476	=over 4	1562	=over 4
…		…
1692		1778
1693	sub load_header_from($) {	1779	sub load_header_from($) {
1694	my ($self, $path) = @_;	1780	my ($self, $path) = @_;
1695		1781
1696	utf8::encode $path;	1782	utf8::encode $path;
1697	#aio_open $path, O_RDONLY, 0	1783	my $f = new_from_file cf::object::thawer $path
1698	# or return;
1699
1700	$self->_load_header ($path)
1701	or return;	1784	or return;
		1785
		1786	$self->_load_header ($f)
		1787	or return;
		1788
		1789	local $MAP_LOADING{$self->{path}} = $self;
		1790	$f->resolve_delayed_derefs;
1702		1791
1703	$self->{load_path} = $path;	1792	$self->{load_path} = $path;
1704		1793
1705	1	1794	1
1706	}	1795	}
…		…
1760	sub find {	1849	sub find {
1761	my ($path, $origin) = @_;	1850	my ($path, $origin) = @_;
1762		1851
1763	$path = normalise $path, $origin && $origin->path;	1852	$path = normalise $path, $origin && $origin->path;
1764		1853
		1854	cf::lock_wait "map_data:$path";#d#remove
1765	cf::lock_wait "map_find:$path";	1855	cf::lock_wait "map_find:$path";
1766		1856
1767	$cf::MAP{$path} \|\| do {	1857	$cf::MAP{$path} \|\| do {
1768	my $guard = cf::lock_acquire "map_find:$path";	1858	my $guard1 = cf::lock_acquire "map_find:$path";
		1859	my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
		1860
1769	my $map = new_from_path cf::map $path	1861	my $map = new_from_path cf::map $path
1770	or return;	1862	or return;
1771		1863
1772	$map->{last_save} = $cf::RUNTIME;	1864	$map->{last_save} = $cf::RUNTIME;
1773		1865
…		…
1775	or return;	1867	or return;
1776		1868
1777	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)	1869	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1778	# doing this can freeze the server in a sync job, obviously	1870	# doing this can freeze the server in a sync job, obviously
1779	#$cf::WAIT_FOR_TICK->wait;	1871	#$cf::WAIT_FOR_TICK->wait;
		1872	undef $guard1;
		1873	undef $guard2;
1780	$map->reset;	1874	$map->reset;
1781	undef $guard;
1782	return find $path;	1875	return find $path;
1783	}	1876	}
1784		1877
1785	$cf::MAP{$path} = $map	1878	$cf::MAP{$path} = $map
1786	}	1879	}
…		…
1795	local $self->{deny_reset} = 1; # loading can take a long time	1888	local $self->{deny_reset} = 1; # loading can take a long time
1796		1889
1797	my $path = $self->{path};	1890	my $path = $self->{path};
1798		1891
1799	{	1892	{
1800	my $guard = cf::lock_acquire "map_load:$path";	1893	my $guard = cf::lock_acquire "map_data:$path";
1801		1894
		1895	return unless $self->valid;
1802	return if $self->in_memory != cf::MAP_SWAPPED;	1896	return if $self->in_memory != cf::MAP_SWAPPED;
1803		1897
1804	$self->in_memory (cf::MAP_LOADING);	1898	$self->in_memory (cf::MAP_LOADING);
1805		1899
1806	$self->alloc;	1900	$self->alloc;
1807		1901
1808	$self->pre_load;	1902	$self->pre_load;
1809	Coro::cede;	1903	cf::cede_to_tick;
1810		1904
		1905	my $f = new_from_file cf::object::thawer $self->{load_path};
		1906	$f->skip_block;
1811	$self->_load_objects ($self->{load_path}, 1)	1907	$self->_load_objects ($f)
1812	or return;	1908	or return;
1813		1909
1814	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	1910	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1815	if delete $self->{load_original};	1911	if delete $self->{load_original};
1816		1912
1817	if (my $uniq = $self->uniq_path) {	1913	if (my $uniq = $self->uniq_path) {
1818	utf8::encode $uniq;	1914	utf8::encode $uniq;
1819	if (aio_open $uniq, O_RDONLY, 0) {	1915	unless (aio_stat $uniq) {
		1916	if (my $f = new_from_file cf::object::thawer $uniq) {
1820	$self->clear_unique_items;	1917	$self->clear_unique_items;
1821	$self->_load_objects ($uniq, 0);	1918	$self->_load_objects ($f);
		1919	$f->resolve_delayed_derefs;
		1920	}
1822	}	1921	}
1823	}	1922	}
1824		1923
1825	Coro::cede;	1924	$f->resolve_delayed_derefs;
		1925
		1926	cf::cede_to_tick;
1826	# now do the right thing for maps	1927	# now do the right thing for maps
1827	$self->link_multipart_objects;	1928	$self->link_multipart_objects;
1828	$self->difficulty ($self->estimate_difficulty)	1929	$self->difficulty ($self->estimate_difficulty)
1829	unless $self->difficulty;	1930	unless $self->difficulty;
1830	Coro::cede;	1931	cf::cede_to_tick;
1831		1932
1832	unless ($self->{deny_activate}) {	1933	unless ($self->{deny_activate}) {
1833	$self->decay_objects;	1934	$self->decay_objects;
1834	$self->fix_auto_apply;	1935	$self->fix_auto_apply;
1835	$self->update_buttons;	1936	$self->update_buttons;
1836	Coro::cede;	1937	cf::cede_to_tick;
1837	$self->set_darkness_map;	1938	$self->set_darkness_map;
1838	Coro::cede;	1939	cf::cede_to_tick;
1839	$self->activate;	1940	$self->activate;
1840	}	1941	}
		1942
		1943	$self->{last_save} = $cf::RUNTIME;
		1944	$self->last_access ($cf::RUNTIME);
1841		1945
1842	$self->in_memory (cf::MAP_IN_MEMORY);	1946	$self->in_memory (cf::MAP_IN_MEMORY);
1843	}	1947	}
1844		1948
1845	$self->post_load;	1949	$self->post_load;
…		…
1856		1960
1857	$self	1961	$self
1858	}	1962	}
1859		1963
1860	# find and load all maps in the 3x3 area around a map	1964	# find and load all maps in the 3x3 area around a map
1861	sub load_diag {	1965	sub load_neighbours {
1862	my ($map) = @_;	1966	my ($map) = @_;
1863		1967
1864	my @diag; # diagonal neighbours	1968	my @neigh; # diagonal neighbours
1865		1969
1866	for (0 .. 3) {	1970	for (0 .. 3) {
1867	my $neigh = $map->tile_path ($_)	1971	my $neigh = $map->tile_path ($_)
1868	or next;	1972	or next;
1869	$neigh = find $neigh, $map	1973	$neigh = find $neigh, $map
1870	or next;	1974	or next;
1871	$neigh->load;	1975	$neigh->load;
1872		1976
		1977	push @neigh,
1873	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],	1978	[$neigh->tile_path (($_ + 3) % 4), $neigh],
1874	[$neigh->tile_path (($_ + 1) % 4), $neigh];	1979	[$neigh->tile_path (($_ + 1) % 4), $neigh];
1875	}	1980	}
1876		1981
1877	for (@diag) {	1982	for (grep defined $_->[0], @neigh) {
		1983	my ($path, $origin) = @$_;
1878	my $neigh = find @$_	1984	my $neigh = find $path, $origin
1879	or next;	1985	or next;
1880	$neigh->load;	1986	$neigh->load;
1881	}	1987	}
1882	}	1988	}
1883		1989
…		…
1888	}	1994	}
1889		1995
1890	sub do_load_sync {	1996	sub do_load_sync {
1891	my ($map) = @_;	1997	my ($map) = @_;
1892		1998
		1999	cf::LOG cf::llevDebug \| cf::logBacktrace, "do_load_sync"
		2000	if $Coro::current == $Coro::main;
		2001
1893	cf::sync_job { $map->load };	2002	cf::sync_job { $map->load };
1894	}	2003	}
1895		2004
1896	our %MAP_PREFETCH;	2005	our %MAP_PREFETCH;
1897	our $MAP_PREFETCHER = undef;	2006	our $MAP_PREFETCHER = undef;
1898		2007
1899	sub find_async {	2008	sub find_async {
1900	my ($path, $origin) = @_;	2009	my ($path, $origin, $load) = @_;
1901		2010
1902	$path = normalise $path, $origin && $origin->{path};	2011	$path = normalise $path, $origin && $origin->{path};
1903		2012
1904	if (my $map = $cf::MAP{$path}) {	2013	if (my $map = $cf::MAP{$path}) {
1905	return $map if $map->in_memory == cf::MAP_IN_MEMORY;	2014	return $map if !$load \|\| $map->in_memory == cf::MAP_IN_MEMORY;
1906	}	2015	}
1907		2016
1908	undef $MAP_PREFETCH{$path};	2017	$MAP_PREFETCH{$path} \|= $load;
		2018
1909	$MAP_PREFETCHER \|\|= cf::async {	2019	$MAP_PREFETCHER \|\|= cf::async {
1910	while (%MAP_PREFETCH) {	2020	while (%MAP_PREFETCH) {
1911	for my $path (keys %MAP_PREFETCH) {	2021	while (my ($k, $v) = each %MAP_PREFETCH) {
1912	if (my $map = find $path) {	2022	if (my $map = find $k) {
1913	$map->load;	2023	$map->load if $v;
1914	}	2024	}
1915		2025
1916	delete $MAP_PREFETCH{$path};	2026	delete $MAP_PREFETCH{$k};
1917	}	2027	}
1918	}	2028	}
1919	undef $MAP_PREFETCHER;	2029	undef $MAP_PREFETCHER;
1920	};	2030	};
1921	$MAP_PREFETCHER->prio (6);	2031	$MAP_PREFETCHER->prio (6);
…		…
1924	}	2034	}
1925		2035
1926	sub save {	2036	sub save {
1927	my ($self) = @_;	2037	my ($self) = @_;
1928		2038
1929	my $lock = cf::lock_acquire "map_data:" . $self->path;	2039	my $lock = cf::lock_acquire "map_data:$self->{path}";
1930		2040
1931	$self->{last_save} = $cf::RUNTIME;	2041	$self->{last_save} = $cf::RUNTIME;
1932		2042
1933	return unless $self->dirty;	2043	return unless $self->dirty;
1934		2044
…		…
1957	my ($self) = @_;	2067	my ($self) = @_;
1958		2068
1959	# save first because save cedes	2069	# save first because save cedes
1960	$self->save;	2070	$self->save;
1961		2071
1962	my $lock = cf::lock_acquire "map_data:" . $self->path;	2072	my $lock = cf::lock_acquire "map_data:$self->{path}";
1963		2073
1964	return if $self->players;	2074	return if $self->players;
1965	return if $self->in_memory != cf::MAP_IN_MEMORY;	2075	return if $self->in_memory != cf::MAP_IN_MEMORY;
1966	return if $self->{deny_save};	2076	return if $self->{deny_save};
1967		2077
		2078	$self->deactivate;
1968	$self->clear;	2079	$self->clear;
1969	$self->in_memory (cf::MAP_SWAPPED);	2080	$self->in_memory (cf::MAP_SWAPPED);
1970	}	2081	}
1971		2082
1972	sub reset_at {	2083	sub reset_at {
…		…
2006	if $uniq;	2117	if $uniq;
2007	}	2118	}
2008		2119
2009	delete $cf::MAP{$self->path};	2120	delete $cf::MAP{$self->path};
2010		2121
		2122	$self->deactivate;
2011	$self->clear;	2123	$self->clear;
2012		2124
2013	$_->clear_links_to ($self) for values %cf::MAP;	2125	$_->clear_links_to ($self) for values %cf::MAP;
2014		2126
2015	$self->unlink_save;	2127	$self->unlink_save;
…		…
2019	my $nuke_counter = "aaaa";	2131	my $nuke_counter = "aaaa";
2020		2132
2021	sub nuke {	2133	sub nuke {
2022	my ($self) = @_;	2134	my ($self) = @_;
2023		2135
		2136	{
		2137	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2138
2024	delete $cf::MAP{$self->path};	2139	delete $cf::MAP{$self->path};
2025		2140
2026	$self->unlink_save;	2141	$self->unlink_save;
2027		2142
2028	bless $self, "cf::map";	2143	bless $self, "cf::map";
2029	delete $self->{deny_reset};	2144	delete $self->{deny_reset};
2030	$self->{deny_save} = 1;	2145	$self->{deny_save} = 1;
2031	$self->reset_timeout (1);	2146	$self->reset_timeout (1);
2032	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2147	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2033		2148
2034	$cf::MAP{$self->path} = $self;	2149	$cf::MAP{$self->path} = $self;
		2150	}
2035		2151
2036	$self->reset; # polite request, might not happen	2152	$self->reset; # polite request, might not happen
2037	}	2153	}
2038		2154
2039	=item $maps = cf::map::tmp_maps	2155	=item $maps = cf::map::tmp_maps
…		…
2115		2231
2116	sub inv_recursive {	2232	sub inv_recursive {
2117	inv_recursive_ inv $_[0]	2233	inv_recursive_ inv $_[0]
2118	}	2234	}
2119		2235
		2236	=item $ref = $ob->ref
		2237
		2238	creates and returns a persistent reference to an objetc that can be stored as a string.
		2239
		2240	=item $ob = cf::object::deref ($refstring)
		2241
		2242	returns the objetc referenced by refstring. may return undef when it cnanot find the object,
		2243	even if the object actually exists. May block.
		2244
		2245	=cut
		2246
		2247	sub deref {
		2248	my ($ref) = @_;
		2249
		2250	# temporary compatibility#TODO#remove
		2251	$ref =~ s{^<}{player/<};
		2252
		2253	if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
		2254	my ($uuid, $name) = ($1, $2);
		2255	my $pl = $cf::PLAYER_LOADING{$name} \|\| cf::player::find $name
		2256	or return;
		2257	$pl->ob->uuid eq $uuid
		2258	or return;
		2259
		2260	$pl->ob
		2261	} else {
		2262	warn "$ref: cannot resolve object reference\n";
		2263	undef
		2264	}
		2265	}
		2266
2120	package cf;	2267	package cf;
2121		2268
2122	=back	2269	=back
2123		2270
2124	=head3 cf::object::player	2271	=head3 cf::object::player
…		…
2146		2293
2147	} else {	2294	} else {
2148	my $pl = $self->contr;	2295	my $pl = $self->contr;
2149		2296
2150	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2297	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2151	my $diag = $pl->{npc_dialog};	2298	my $dialog = $pl->{npc_dialog};
2152	$diag->{pl}->ext_reply (	2299	$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		2300
2159	} else {	2301	} else {
2160	$msg = $npc->name . " says: $msg" if $npc;	2302	$msg = $npc->name . " says: $msg" if $npc;
2161	$self->message ($msg, $flags);	2303	$self->message ($msg, $flags);
2162	}	2304	}
2163	}	2305	}
		2306	}
		2307
		2308	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2309
		2310	=cut
		2311
		2312	sub cf::object::send_msg {
		2313	my $pl = shift->contr
		2314	or return;
		2315	$pl->send_msg (@_);
2164	}	2316	}
2165		2317
2166	=item $player_object->may ("access")	2318	=item $player_object->may ("access")
2167		2319
2168	Returns wether the given player is authorized to access resource "access"	2320	Returns wether the given player is authorized to access resource "access"
…		…
2247	# use -1 or undef as default coordinates, not 0, 0	2399	# use -1 or undef as default coordinates, not 0, 0
2248	($x, $y) = ($map->enter_x, $map->enter_y)	2400	($x, $y) = ($map->enter_x, $map->enter_y)
2249	if $x <=0 && $y <= 0;	2401	if $x <=0 && $y <= 0;
2250		2402
2251	$map->load;	2403	$map->load;
2252	$map->load_diag;	2404	$map->load_neighbours;
2253		2405
2254	return unless $self->contr->active;	2406	return unless $self->contr->active;
2255	$self->activate_recursive;	2407	$self->activate_recursive;
2256		2408
2257	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2409	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
…		…
2419		2571
2420	utf8::encode $text;	2572	utf8::encode $text;
2421	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2573	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2422	}	2574	}
2423		2575
2424	=item $client->send_msg ($color, $type, $msg, [extra...])	2576	=item $client->send_msg ($channel, $msg, $color, [extra...])
2425		2577
2426	Send a drawinfo or msg packet to the client, formatting the msg for the	2578	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	2579	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	2580	the message, with C<log> being the default. If C<$color> is negative, suppress
2429	the message unless the client supports the msg packet.	2581	the message unless the client supports the msg packet.
2430		2582
2431	=cut	2583	=cut
2432		2584
		2585	our %CHANNEL = (
		2586	"c/identify" => {
		2587	id => "identify",
		2588	title => "Identify",
		2589	reply => undef,
		2590	tooltip => "Items recently identified",
		2591	},
		2592	"c/examine" => {
		2593	id => "examine",
		2594	title => "Examine",
		2595	reply => undef,
		2596	tooltip => "Signs and other items you examined",
		2597	},
		2598	);
		2599
2433	sub cf::client::send_msg {	2600	sub cf::client::send_msg {
2434	my ($self, $color, $type, $msg, @extra) = @_;	2601	my ($self, $channel, $msg, $color, @extra) = @_;
2435		2602
2436	$msg = $self->pl->expand_cfpod ($msg);	2603	$msg = $self->pl->expand_cfpod ($msg);
2437		2604
		2605	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2606
		2607	# check predefined channels, for the benefit of C
		2608	$channel = $CHANNEL{$channel} if $CHANNEL{$channel};
		2609
		2610	if (ref $channel) {
		2611	# send meta info to client, if not yet sent
		2612	unless (exists $self->{channel}{$channel->{id}}) {
		2613	$self->{channel}{$channel->{id}} = $channel;
		2614	$self->ext_msg (channel_info => $channel)
		2615	if $self->can_msg;
		2616	}
		2617
		2618	$channel = $channel->{id};
		2619	}
		2620
2438	return unless @extra \|\| length $msg;	2621	return unless @extra \|\| length $msg;
2439		2622
2440	if ($self->can_msg) {	2623	if ($self->can_msg) {
		2624	# default colour, mask it out
		2625	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2626	if $color & cf::NDI_DEF;
		2627
2441	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));	2628	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2629	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2442	} else {	2630	} 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) {	2631	if ($color >= 0) {
		2632	# replace some tags by gcfclient-compatible ones
		2633	for ($msg) {
		2634	1 while
		2635	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2636	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2637	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2638	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2639	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2640	}
		2641
		2642	$color &= cf::NDI_COLOR_MASK;
		2643
		2644	utf8::encode $msg;
		2645
2454	if (0 && $msg =~ /\[/) {	2646	if (0 && $msg =~ /\[/) {
		2647	# COMMAND/INFO
2455	$self->send_packet ("drawextinfo $color 4 0 $msg")	2648	$self->send_packet ("drawextinfo $color 10 8 $msg")
2456	} else {	2649	} else {
2457	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2650	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2458	$self->send_packet ("drawinfo $color $msg")	2651	$self->send_packet ("drawinfo $color $msg")
2459	}	2652	}
2460	}	2653	}
2461	}	2654	}
2462	}	2655	}
2463		2656
2464	=item $client->ext_event ($type, %msg)	2657	=item $client->ext_msg ($type, @msg)
2465		2658
2466	Sends an ext event to the client.	2659	Sends an ext event to the client.
2467		2660
2468	=cut	2661	=cut
2469		2662
2470	sub cf::client::ext_event($$%) {	2663	sub cf::client::ext_msg($$@) {
2471	my ($self, $type, %msg) = @_;	2664	my ($self, $type, @msg) = @_;
2472		2665
2473	return unless $self->extcmd;	2666	if ($self->extcmd == 2) {
2474		2667	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2668	} elsif ($self->extcmd == 1) { # TODO: remove
2475	$msg{msgtype} = "event_$type";	2669	push @msg, msgtype => "event_$type";
2476	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2670	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2671	}
		2672	}
		2673
		2674	=item $client->ext_reply ($msgid, @msg)
		2675
		2676	Sends an ext reply to the client.
		2677
		2678	=cut
		2679
		2680	sub cf::client::ext_reply($$@) {
		2681	my ($self, $id, @msg) = @_;
		2682
		2683	if ($self->extcmd == 2) {
		2684	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
		2685	} elsif ($self->extcmd == 1) {
		2686	#TODO: version 1, remove
		2687	unshift @msg, msgtype => "reply", msgid => $id;
		2688	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2689	}
2477	}	2690	}
2478		2691
2479	=item $success = $client->query ($flags, "text", \&cb)	2692	=item $success = $client->query ($flags, "text", \&cb)
2480		2693
2481	Queues a query to the client, calling the given callback with	2694	Queues a query to the client, calling the given callback with
…		…
2536	my ($ns, $buf) = @_;	2749	my ($ns, $buf) = @_;
2537		2750
2538	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2751	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2539		2752
2540	if (ref $msg) {	2753	if (ref $msg) {
		2754	my ($type, $reply, @payload) =
		2755	"ARRAY" eq ref $msg
		2756	? @$msg
		2757	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2758
		2759	my @reply;
		2760
2541	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2761	if (my $cb = $EXTICMD{$type}) {
2542	if (my %reply = $cb->($ns, $msg)) {	2762	@reply = $cb->($ns, @payload);
2543	$reply{msgid} = $msg->{msgid};
2544	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2545	}
2546	}	2763	}
		2764
		2765	$ns->ext_reply ($reply, @reply)
		2766	if $reply;
		2767
2547	} else {	2768	} else {
2548	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2769	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2549	}	2770	}
2550		2771
2551	cf::override;	2772	cf::override;
…		…
2598	our $safe = new Safe "safe";	2819	our $safe = new Safe "safe";
2599	our $safe_hole = new Safe::Hole;	2820	our $safe_hole = new Safe::Hole;
2600		2821
2601	$SIG{FPE} = 'IGNORE';	2822	$SIG{FPE} = 'IGNORE';
2602		2823
2603	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2824	$safe->permit_only (Opcode::opset qw(
		2825	:base_core :base_mem :base_orig :base_math
		2826	grepstart grepwhile mapstart mapwhile
		2827	sort time
		2828	));
2604		2829
2605	# here we export the classes and methods available to script code	2830	# here we export the classes and methods available to script code
2606		2831
2607	=pod	2832	=pod
2608		2833
2609	The following functions and methods are available within a safe environment:	2834	The following functions and methods are available within a safe environment:
2610		2835
2611	cf::object	2836	cf::object
2612	contr pay_amount pay_player map x y force_find force_add	2837	contr pay_amount pay_player map x y force_find force_add
2613	insert remove	2838	insert remove name archname title slaying race decrease_ob_nr
2614		2839
2615	cf::object::player	2840	cf::object::player
2616	player	2841	player
2617		2842
2618	cf::player	2843	cf::player
…		…
2623		2848
2624	=cut	2849	=cut
2625		2850
2626	for (	2851	for (
2627	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2852	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2853	insert remove inv name archname title slaying race
2628	insert remove)],	2854	decrease_ob_nr)],
2629	["cf::object::player" => qw(player)],	2855	["cf::object::player" => qw(player)],
2630	["cf::player" => qw(peaceful)],	2856	["cf::player" => qw(peaceful)],
2631	["cf::map" => qw(trigger)],	2857	["cf::map" => qw(trigger)],
2632	) {	2858	) {
2633	no strict 'refs';	2859	no strict 'refs';
…		…
2709	# the server's init and main functions	2935	# the server's init and main functions
2710		2936
2711	sub load_facedata($) {	2937	sub load_facedata($) {
2712	my ($path) = @_;	2938	my ($path) = @_;
2713		2939
		2940	# HACK to clear player env face cache, we need some signal framework
		2941	# for this (global event?)
		2942	%ext::player_env::MUSIC_FACE_CACHE = ();
		2943
		2944	my $enc = JSON::XS->new->utf8->canonical->relaxed;
		2945
2714	warn "loading facedata from $path\n";	2946	warn "loading facedata from $path\n";
2715		2947
2716	my $facedata;	2948	my $facedata;
2717	0 < aio_load $path, $facedata	2949	0 < aio_load $path, $facedata
2718	or die "$path: $!";	2950	or die "$path: $!";
2719		2951
2720	$facedata = Coro::Storable::thaw $facedata;	2952	$facedata = Coro::Storable::thaw $facedata;
2721		2953
2722	$facedata->{version} == 2	2954	$facedata->{version} == 2
2723	or cf::cleanup "$path: version mismatch, cannot proceed.";	2955	or cf::cleanup "$path: version mismatch, cannot proceed.";
		2956
		2957	# patch in the exptable
		2958	$facedata->{resource}{"res/exp_table"} = {
		2959	type => FT_RSRC,
		2960	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
		2961	};
		2962	cf::cede_to_tick;
2724		2963
2725	{	2964	{
2726	my $faces = $facedata->{faceinfo};	2965	my $faces = $facedata->{faceinfo};
2727		2966
2728	while (my ($face, $info) = each %$faces) {	2967	while (my ($face, $info) = each %$faces) {
2729	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2968	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2730	cf::face::set_visibility $idx, $info->{visibility};	2969	cf::face::set_visibility $idx, $info->{visibility};
2731	cf::face::set_magicmap $idx, $info->{magicmap};	2970	cf::face::set_magicmap $idx, $info->{magicmap};
2732	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2971	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2733	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2972	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2734		2973
2735	cf::cede_to_tick;	2974	cf::cede_to_tick;
2736	}	2975	}
2737		2976
2738	while (my ($face, $info) = each %$faces) {	2977	while (my ($face, $info) = each %$faces) {
…		…
2763		3002
2764	{	3003	{
2765	# TODO: for gcfclient pleasure, we should give resources	3004	# TODO: for gcfclient pleasure, we should give resources
2766	# that gcfclient doesn't grok a >10000 face index.	3005	# that gcfclient doesn't grok a >10000 face index.
2767	my $res = $facedata->{resource};	3006	my $res = $facedata->{resource};
2768	my $enc = JSON::XS->new->utf8->canonical;	3007
		3008	my $soundconf = delete $res->{"res/sound.conf"};
2769		3009
2770	while (my ($name, $info) = each %$res) {	3010	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;	3011	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		3012	my $data;
2778		3013
2779	if ($name =~ /\.jpg$/) {	3014	if ($info->{type} & 1) {
2780	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack	3015	# prepend meta info
2781	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack	3016
		3017	my $meta = $enc->encode ({
		3018	name => $name,
		3019	%{ $info->{meta} \|\| {} },
		3020	});
		3021
		3022	$data = pack "(w/a)", $meta, $info->{data};
2782	} else {	3023	} else {
2783	my $data = pack "(w/a)", $meta, $info->{data};	3024	$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	}	3025	}
2789		3026
		3027	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
		3028	cf::face::set_type $idx, $info->{type};
		3029
2790	cf::cede_to_tick;	3030	cf::cede_to_tick;
2791	}	3031	}
		3032
		3033	if ($soundconf) {
		3034	$soundconf = $enc->decode (delete $soundconf->{data});
		3035
		3036	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3037	my $sound = $soundconf->{compat}[$_]
		3038	or next;
		3039
		3040	my $face = cf::face::find "sound/$sound->[1]";
		3041	cf::sound::set $sound->[0] => $face;
		3042	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3043	}
		3044
		3045	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3046	my $face = cf::face::find "sound/$v";
		3047	cf::sound::set $k => $face;
		3048	}
		3049	}
2792	}	3050	}
2793		3051
2794	1	3052	1
2795	}	3053	}
2796		3054
		3055	register_exticmd fx_want => sub {
		3056	my ($ns, $want) = @_;
		3057
		3058	while (my ($k, $v) = each %$want) {
		3059	$ns->fx_want ($k, $v);
		3060	}
		3061	};
		3062
2797	sub reload_regions {	3063	sub reload_regions {
		3064	# HACK to clear player env face cache, we need some signal framework
		3065	# for this (global event?)
		3066	%ext::player_env::MUSIC_FACE_CACHE = ();
		3067
2798	load_resource_file "$MAPDIR/regions"	3068	load_resource_file "$MAPDIR/regions"
2799	or die "unable to load regions file\n";	3069	or die "unable to load regions file\n";
2800		3070
2801	for (cf::region::list) {	3071	for (cf::region::list) {
2802	$_->{match} = qr/$_->{match}/	3072	$_->{match} = qr/$_->{match}/
…		…
2838		3108
2839	sub init {	3109	sub init {
2840	reload_resources;	3110	reload_resources;
2841	}	3111	}
2842		3112
2843	sub cfg_load {	3113	sub reload_config {
2844	open my $fh, "<:utf8", "$CONFDIR/config"	3114	open my $fh, "<:utf8", "$CONFDIR/config"
2845	or return;	3115	or return;
2846		3116
2847	local $/;	3117	local $/;
2848	*CFG = YAML::Syck::Load <$fh>;	3118	*CFG = YAML::Syck::Load <$fh>;
…		…
2868	(async {	3138	(async {
2869	Event::one_event;	3139	Event::one_event;
2870	})->prio (Coro::PRIO_MAX);	3140	})->prio (Coro::PRIO_MAX);
2871	};	3141	};
2872		3142
2873	cfg_load;	3143	reload_config;
2874	db_init;	3144	db_init;
2875	load_extensions;	3145	load_extensions;
2876		3146
2877	$TICK_WATCHER->start;	3147	$TICK_WATCHER->start;
2878	Event::loop;	3148	Event::loop;
…		…
3071	warn "reloading cf.pm";	3341	warn "reloading cf.pm";
3072	require cf;	3342	require cf;
3073	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3343	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3074		3344
3075	warn "loading config and database again";	3345	warn "loading config and database again";
3076	cf::cfg_load;	3346	cf::reload_config;
3077		3347
3078	warn "loading extensions";	3348	warn "loading extensions";
3079	cf::load_extensions;	3349	cf::load_extensions;
3080		3350
3081	warn "reattaching attachments to objects/players";	3351	warn "reattaching attachments to objects/players";
…		…
3174	or die;	3444	or die;
3175		3445
3176	$map->width (50);	3446	$map->width (50);
3177	$map->height (50);	3447	$map->height (50);
3178	$map->alloc;	3448	$map->alloc;
3179	$map->_load_objects ("/tmp/x.map", 1);	3449	$map->_load_objects ("/tmp/x.map", 1); #TODO: does not work
3180	my $t = Event::time - $t;	3450	my $t = Event::time - $t;
3181		3451
3182	#next unless $t < 0.0013;#d#	3452	#next unless $t < 0.0013;#d#
3183	if ($t < $min) {	3453	if ($t < $min) {
3184	$min = $t;	3454	$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.358 by root, Fri Sep 7 18:10:52 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.358 by root, Fri Sep 7 18:10:52 2007 UTC