ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/deliantra/server/lib/cf.pm

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.282 by elmex, Tue Jun 19 18:15:34 2007 UTC vs.
Revision 1.385 by root, Fri Oct 12 19:13:26 2007 UTC

…		…
4	use strict;	4	use strict;
5		5
6	use Symbol;	6	use Symbol;
7	use List::Util;	7	use List::Util;
8	use Socket;	8	use Socket;
9	use Storable;
10	use Event;	9	use Event;
11	use Opcode;	10	use Opcode;
12	use Safe;	11	use Safe;
13	use Safe::Hole;	12	use Safe::Hole;
		13	use Storable ();
14		14
15	use Coro 3.61 ();	15	use Coro 4.1 ();
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
		26	use JSON::XS ();
25	use BDB ();	27	use BDB ();
26	use Data::Dumper;	28	use Data::Dumper;
27	use Digest::MD5;	29	use Digest::MD5;
28	use Fcntl;	30	use Fcntl;
29	use YAML::Syck ();	31	use YAML::Syck ();
30	use IO::AIO 2.32 ();	32	use IO::AIO 2.51 ();
31	use Time::HiRes;	33	use Time::HiRes;
32	use Compress::LZF;	34	use Compress::LZF;
		35	use Digest::MD5 ();
33		36
34	# configure various modules to our taste	37	# configure various modules to our taste
35	#	38	#
36	$Storable::canonical = 1; # reduce rsync transfers	39	$Storable::canonical = 1; # reduce rsync transfers
37	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator	40	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
…		…
49	our %COMMAND = ();	52	our %COMMAND = ();
50	our %COMMAND_TIME = ();	53	our %COMMAND_TIME = ();
51		54
52	our @EXTS = (); # list of extension package names	55	our @EXTS = (); # list of extension package names
53	our %EXTCMD = ();	56	our %EXTCMD = ();
		57	our %EXTICMD = ();
54	our %EXT_CORO = (); # coroutines bound to extensions	58	our %EXT_CORO = (); # coroutines bound to extensions
55	our %EXT_MAP = (); # pluggable maps	59	our %EXT_MAP = (); # pluggable maps
56		60
57	our $RELOAD; # number of reloads so far	61	our $RELOAD; # number of reloads so far
58	our @EVENT;	62	our @EVENT;
…		…
76	our $NEXT_TICK;	80	our $NEXT_TICK;
77	our $NOW;	81	our $NOW;
78	our $USE_FSYNC = 1; # use fsync to write maps - default off	82	our $USE_FSYNC = 1; # use fsync to write maps - default off
79		83
80	our $BDB_POLL_WATCHER;	84	our $BDB_POLL_WATCHER;
		85	our $BDB_DEADLOCK_WATCHER;
		86	our $BDB_CHECKPOINT_WATCHER;
		87	our $BDB_TRICKLE_WATCHER;
81	our $DB_ENV;	88	our $DB_ENV;
82		89
83	our %CFG;	90	our %CFG;
84		91
85	our $UPTIME; $UPTIME ||= time;	92	our $UPTIME; $UPTIME ||= time;
86	our $RUNTIME;	93	our $RUNTIME;
87		94
88	our %PLAYER; # all users	95	our (%PLAYER, %PLAYER_LOADING); # all users
89	our %MAP; # all maps	96	our (%MAP, %MAP_LOADING ); # all maps
90	our $LINK_MAP; # the special {link} map, which is always available	97	our $LINK_MAP; # the special {link} map, which is always available
91		98
92	# used to convert map paths into valid unix filenames by replacing / by ∕	99	# used to convert map paths into valid unix filenames by replacing / by ∕
93	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons	100	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94		101
…		…
164		171
165	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	172	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
166	returns directly I<after> the tick processing (and consequently, can only wake one process	173	returns directly I<after> the tick processing (and consequently, can only wake one process
167	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	174	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
168		175
		176	=item @cf::INVOKE_RESULTS
		177
		178	This array contains the results of the last C<invoke ()> call. When
		179	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
		180	that call.
		181
169	=back	182	=back
170		183
171	=cut	184	=cut
172		185
173	BEGIN {	186	BEGIN {
…		…
177	$msg .= "\n"	190	$msg .= "\n"
178	unless $msg =~ /\n$/;	191	unless $msg =~ /\n$/;
179		192
180	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;	193	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181		194
182	utf8::encode $msg;
183	LOG llevError, $msg;	195	LOG llevError, $msg;
184	};	196	};
185	}	197	}
186		198
187	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	199	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
…		…
236	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;	248	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
237	$d	249	$d
238	} || "[unable to dump $_[0]: '$@']";	250	} || "[unable to dump $_[0]: '$@']";
239	}	251	}
240		252
241	use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
242
243	=item $ref = cf::from_json $json	253	=item $ref = cf::from_json $json
244		254
245	Converts a JSON string into the corresponding perl data structure.	255	Converts a JSON string into the corresponding perl data structure.
246		256
247	=item $json = cf::to_json $ref	257	=item $json = cf::to_json $ref
248		258
249	Converts a perl data structure into its JSON representation.	259	Converts a perl data structure into its JSON representation.
		260
		261	=cut
		262
		263	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
		264
		265	sub to_json ($) { $json_coder->encode ($_[0]) }
		266	sub from_json ($) { $json_coder->decode ($_[0]) }
250		267
251	=item cf::lock_wait $string	268	=item cf::lock_wait $string
252		269
253	Wait until the given lock is available. See cf::lock_acquire.	270	Wait until the given lock is available. See cf::lock_acquire.
254		271
…		…
257	Wait until the given lock is available and then acquires it and returns	274	Wait until the given lock is available and then acquires it and returns
258	a Coro::guard object. If the guard object gets destroyed (goes out of scope,	275	a Coro::guard object. If the guard object gets destroyed (goes out of scope,
259	for example when the coroutine gets canceled), the lock is automatically	276	for example when the coroutine gets canceled), the lock is automatically
260	returned.	277	returned.
261		278
		279	Locks are *not* recursive, locking from the same coro twice results in a
		280	deadlocked coro.
		281
262	Lock names should begin with a unique identifier (for example, cf::map::find	282	Lock names should begin with a unique identifier (for example, cf::map::find
263	uses map_find and cf::map::load uses map_load).	283	uses map_find and cf::map::load uses map_load).
264		284
265	=item $locked = cf::lock_active $string	285	=item $locked = cf::lock_active $string
266		286
267	Return true if the lock is currently active, i.e. somebody has locked it.	287	Return true if the lock is currently active, i.e. somebody has locked it.
268		288
269	=cut	289	=cut
270		290
271	our %LOCK;	291	our %LOCK;
		292	our %LOCKER;#d#
272		293
273	sub lock_wait($) {	294	sub lock_wait($) {
274	my ($key) = @_;	295	my ($key) = @_;
		296
		297	if ($LOCKER{$key} == $Coro::current) {#d#
		298	Carp::cluck "lock_wait($key) for already-acquired lock";#d#
		299	return;#d#
		300	}#d#
275		301
276	# wait for lock, if any	302	# wait for lock, if any
277	while ($LOCK{$key}) {	303	while ($LOCK{$key}) {
278	push @{ $LOCK{$key} }, $Coro::current;	304	push @{ $LOCK{$key} }, $Coro::current;
279	Coro::schedule;	305	Coro::schedule;
…		…
285		311
286	# wait, to be sure we are not locked	312	# wait, to be sure we are not locked
287	lock_wait $key;	313	lock_wait $key;
288		314
289	$LOCK{$key} = [];	315	$LOCK{$key} = [];
		316	$LOCKER{$key} = $Coro::current;#d#
290		317
291	Coro::guard {	318	Coro::guard {
		319	delete $LOCKER{$key};#d#
292	# wake up all waiters, to be on the safe side	320	# wake up all waiters, to be on the safe side
293	$_->ready for @{ delete $LOCK{$key} };	321	$_->ready for @{ delete $LOCK{$key} };
294	}	322	}
295	}	323	}
296		324
…		…
308	};	336	};
309	$TICK_WATCHER->stop;	337	$TICK_WATCHER->stop;
310	$guard	338	$guard
311	}	339	}
312		340
		341	=item cf::get_slot $time[, $priority[, $name]]
		342
		343	Allocate $time seconds of blocking CPU time at priority C<$priority>:
		344	This call blocks and returns only when you have at least C<$time> seconds
		345	of cpu time till the next tick. The slot is only valid till the next cede.
		346
		347	The optional C<$name> can be used to identify the job to run. It might be
		348	used for statistical purposes and should identify the same time-class.
		349
		350	Useful for short background jobs.
		351
		352	=cut
		353
		354	our @SLOT_QUEUE;
		355	our $SLOT_QUEUE;
		356
		357	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
		358	$SLOT_QUEUE = Coro::async {
		359	$Coro::current->desc ("timeslot manager");
		360
		361	my $signal = new Coro::Signal;
		362
		363	while () {
		364	next_job:
		365	my $avail = cf::till_tick;
		366	if ($avail > 0.01) {
		367	for (0 .. $#SLOT_QUEUE) {
		368	if ($SLOT_QUEUE[$_][0] < $avail) {
		369	my $job = splice @SLOT_QUEUE, $_, 1, ();
		370	$job->[2]->send;
		371	Coro::cede;
		372	goto next_job;
		373	}
		374	}
		375	}
		376
		377	if (@SLOT_QUEUE) {
		378	# we do not use wait_for_tick() as it returns immediately when tick is inactive
		379	push @cf::WAIT_FOR_TICK, $signal;
		380	$signal->wait;
		381	} else {
		382	Coro::schedule;
		383	}
		384	}
		385	};
		386
		387	sub get_slot($;$$) {
		388	my ($time, $pri, $name) = @_;
		389
		390	$time = $TICK * .6 if $time > $TICK * .6;
		391	my $sig = new Coro::Signal;
		392
		393	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
		394	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
		395	$SLOT_QUEUE->ready;
		396	$sig->wait;
		397	}
		398
313	=item cf::async { BLOCK }	399	=item cf::async { BLOCK }
314		400
315	Currently the same as Coro::async_pool, meaning you cannot use	401	Currently the same as Coro::async_pool, meaning you cannot use
316	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only	402	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
317	thing you are allowed to do is call C<prio> on it.	403	thing you are allowed to do is call C<prio> on it.
…		…
341	my $time = Event::time;	427	my $time = Event::time;
342		428
343	# this is the main coro, too bad, we have to block	429	# this is the main coro, too bad, we have to block
344	# till the operation succeeds, freezing the server :/	430	# till the operation succeeds, freezing the server :/
345		431
		432	LOG llevError, Carp::longmess "sync job";#d#
		433
346	# TODO: use suspend/resume instead	434	# TODO: use suspend/resume instead
347	# (but this is cancel-safe)	435	# (but this is cancel-safe)
348	my $freeze_guard = freeze_mainloop;	436	my $freeze_guard = freeze_mainloop;
349		437
350	my $busy = 1;	438	my $busy = 1;
351	my @res;	439	my @res;
352		440
353	(async {	441	(async {
		442	$Coro::current->desc ("sync job coro");
354	@res = eval { $job->() };	443	@res = eval { $job->() };
355	warn $@ if $@;	444	warn $@ if $@;
356	undef $busy;	445	undef $busy;
357	})->prio (Coro::PRIO_MAX);	446	})->prio (Coro::PRIO_MAX);
358		447
…		…
405	=cut	494	=cut
406		495
407	sub fork_call(&@) {	496	sub fork_call(&@) {
408	my ($cb, @args) = @_;	497	my ($cb, @args) = @_;
409		498
410	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC	499	# we seemingly have to make a local copy of the whole thing,
411	# or die "socketpair: $!";	500	# otherwise perl prematurely frees the stuff :/
412	pipe my $fh1, my $fh2	501	# TODO: investigate and fix (likely this will be rather laborious)
413	or die "pipe: $!";
414		502
415	if (my $pid = fork) {	503	my @res = Coro::Util::fork_eval {
416	close $fh2;
417
418	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
419	$res = Coro::Storable::thaw $res;
420
421	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
422
423	die $$res unless "ARRAY" eq ref $res;
424
425	return wantarray ? @$res : $res->[-1];
426	} else {
427	reset_signals;	504	reset_signals;
428	local $SIG{__WARN__};	505	&$cb
429	local $SIG{__DIE__};	506	}, @args;
430	eval {
431	close $fh1;
432		507
433	my @res = eval { $cb->(@args) };	508	wantarray ? @res : $res[-1]
434	syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
435	};
436
437	warn $@ if $@;
438	_exit 0;
439	}
440	}	509	}
441		510
442	=item $value = cf::db_get $family => $key	511	=item $value = cf::db_get $family => $key
443		512
444	Returns a single value from the environment database.	513	Returns a single value from the environment database.
…		…
446	=item cf::db_put $family => $key => $value	515	=item cf::db_put $family => $key => $value
447		516
448	Stores the given C<$value> in the family. It can currently store binary	517	Stores the given C<$value> in the family. It can currently store binary
449	data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).	518	data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
450		519
		520	=item $db = cf::db_table "name"
		521
		522	Create and/or open a new database table. The string must not be "db" and must be unique
		523	within each server.
		524
451	=cut	525	=cut
		526
		527	sub db_table($) {
		528	my ($name) = @_;
		529	my $db = BDB::db_create $DB_ENV;
		530
		531	eval {
		532	$db->set_flags (BDB::CHKSUM);
		533
		534	utf8::encode $name;
		535	BDB::db_open $db, undef, $name, undef, BDB::BTREE,
		536	BDB::CREATE | BDB::AUTO_COMMIT, 0666;
		537	cf::cleanup "db_open(db): $!" if $!;
		538	};
		539	cf::cleanup "db_open(db): $@" if $@;
		540
		541	$db
		542	}
452		543
453	our $DB;	544	our $DB;
454		545
455	sub db_init {	546	sub db_init {
456	unless ($DB) {
457	$DB = BDB::db_create $DB_ENV;
458
459	cf::sync_job {	547	cf::sync_job {
460	eval {	548	$DB ||= db_table "db";
461	$DB->set_flags (BDB::CHKSUM);
462
463	BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
464	BDB::CREATE | BDB::AUTO_COMMIT, 0666;
465	cf::cleanup "db_open(db): $!" if $!;
466	};
467	cf::cleanup "db_open(db): $@" if $@;
468	};
469	}	549	};
470	}	550	}
471		551
472	sub db_get($$) {	552	sub db_get($$) {
473	my $key = "$_[0]/$_[1]";	553	my $key = "$_[0]/$_[1]";
474		554
…		…
524	if (1) {	604	if (1) {
525	$md5 =	605	$md5 =
526	join "\x00",	606	join "\x00",
527	$processversion,	607	$processversion,
528	map {	608	map {
529	Coro::cede;	609	cf::cede_to_tick;
530	($src->[$_], Digest::MD5::md5_hex $data[$_])	610	($src->[$_], Digest::MD5::md5_hex $data[$_])
531	} 0.. $#$src;	611	} 0.. $#$src;
532		612
533		613
534	my $dbmd5 = db_get cache => "$id/md5";	614	my $dbmd5 = db_get cache => "$id/md5";
…		…
840	";	920	";
841	die if $@;	921	die if $@;
842	}	922	}
843		923
844	our $override;	924	our $override;
845	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	925	our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
846		926
847	sub override {	927	sub override {
848	$override = 1;	928	$override = 1;
849	@invoke_results = ();	929	@INVOKE_RESULTS = (@_);
850	}	930	}
851		931
852	sub do_invoke {	932	sub do_invoke {
853	my $event = shift;	933	my $event = shift;
854	my $callbacks = shift;	934	my $callbacks = shift;
855		935
856	@invoke_results = ();	936	@INVOKE_RESULTS = ();
857		937
858	local $override;	938	local $override;
859		939
860	for (@$callbacks) {	940	for (@$callbacks) {
861	eval { &{$_->[1]} };	941	eval { &{$_->[1]} };
…		…
878		958
879	Generate an object-specific event with the given arguments.	959	Generate an object-specific event with the given arguments.
880		960
881	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be	961	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
882	removed in future versions), and there is no public API to access override	962	removed in future versions), and there is no public API to access override
883	results (if you must, access C<@cf::invoke_results> directly).	963	results (if you must, access C<@cf::INVOKE_RESULTS> directly).
884		964
885	=back	965	=back
886		966
887	=cut	967	=cut
888		968
889	#############################################################################	969	#############################################################################
890	# object support	970	# object support
		971	#
		972
		973	sub _can_merge {
		974	my ($ob1, $ob2) = @_;
		975
		976	return 1;#d#
		977
		978	#todo#d# kill yourself and do some recursive checking manually without storable
		979	sync_job {
		980	my $guard = Coro::Storable::guard;
		981	local $Storable::canonical = 1;
		982	my $fob1 = Storable::freeze $ob1;
		983	my $fob2 = Storable::freeze $ob2;
		984	$fob1 eq $fob2
		985	}
		986	}
891		987
892	sub reattach {	988	sub reattach {
893	# basically do the same as instantiate, without calling instantiate	989	# basically do the same as instantiate, without calling instantiate
894	my ($obj) = @_;	990	my ($obj) = @_;
895		991
…		…
942	sub object_freezer_save {	1038	sub object_freezer_save {
943	my ($filename, $rdata, $objs) = @_;	1039	my ($filename, $rdata, $objs) = @_;
944		1040
945	sync_job {	1041	sync_job {
946	if (length $$rdata) {	1042	if (length $$rdata) {
		1043	utf8::decode (my $decname = $filename);
947	warn sprintf "saving %s (%d,%d)\n",	1044	warn sprintf "saving %s (%d,%d)\n",
948	$filename, length $$rdata, scalar @$objs;	1045	$decname, length $$rdata, scalar @$objs;
949		1046
950	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {	1047	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
951	chmod SAVE_MODE, $fh;	1048	chmod SAVE_MODE, $fh;
952	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1049	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
953	aio_fsync $fh if $cf::USE_FSYNC;	1050	aio_fsync $fh if $cf::USE_FSYNC;
954	close $fh;	1051	close $fh;
955		1052
956	if (@$objs) {	1053	if (@$objs) {
957	if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {	1054	if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
958	chmod SAVE_MODE, $fh;	1055	chmod SAVE_MODE, $fh;
959	my $data = Storable::nfreeze { version => 1, objs => $objs };	1056	my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs };
960	aio_write $fh, 0, (length $data), $data, 0;	1057	aio_write $fh, 0, (length $data), $data, 0;
961	aio_fsync $fh if $cf::USE_FSYNC;	1058	aio_fsync $fh if $cf::USE_FSYNC;
962	close $fh;	1059	close $fh;
963	aio_rename "$filename.pst~", "$filename.pst";	1060	aio_rename "$filename.pst~", "$filename.pst";
964	}	1061	}
…		…
972	}	1069	}
973	} else {	1070	} else {
974	aio_unlink $filename;	1071	aio_unlink $filename;
975	aio_unlink "$filename.pst";	1072	aio_unlink "$filename.pst";
976	}	1073	}
977	}	1074	};
978	}	1075	}
979		1076
980	sub object_freezer_as_string {	1077	sub object_freezer_as_string {
981	my ($rdata, $objs) = @_;	1078	my ($rdata, $objs) = @_;
982		1079
…		…
994	or return;	1091	or return;
995		1092
996	unless (aio_stat "$filename.pst") {	1093	unless (aio_stat "$filename.pst") {
997	(aio_load "$filename.pst", $av) >= 0	1094	(aio_load "$filename.pst", $av) >= 0
998	or return;	1095	or return;
999	$av = eval { (Storable::thaw $av)->{objs} };
1000	}
1001		1096
		1097	my $st = eval { Coro::Storable::thaw $av }
		1098	|| eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
		1099	$av = $st->{objs};
		1100	}
		1101
		1102	utf8::decode (my $decname = $filename);
1002	warn sprintf "loading %s (%d)\n",	1103	warn sprintf "loading %s (%d,%d)\n",
1003	$filename, length $data, scalar @{$av || []};	1104	$decname, length $data, scalar @{$av || []};
		1105
1004	return ($data, $av);	1106	($data, $av)
1005	}	1107	}
1006		1108
1007	=head2 COMMAND CALLBACKS	1109	=head2 COMMAND CALLBACKS
1008		1110
1009	=over 4	1111	=over 4
…		…
1029	push @{ $COMMAND{$name} }, [$caller, $cb];	1131	push @{ $COMMAND{$name} }, [$caller, $cb];
1030	}	1132	}
1031		1133
1032	=item cf::register_extcmd $name => \&callback($pl,$packet);	1134	=item cf::register_extcmd $name => \&callback($pl,$packet);
1033		1135
1034	Register a callback fro execution when the client sends an extcmd packet.	1136	Register a callback for execution when the client sends an (synchronous)
		1137	extcmd packet. Ext commands will be processed in the order they are
		1138	received by the server, like other user commands. The first argument is
		1139	the logged-in player. Ext commands can only be processed after a player
		1140	has logged in successfully.
1035		1141
1036	If the callback returns something, it is sent back as if reply was being	1142	If the callback returns something, it is sent back as if reply was being
1037	called.	1143	called.
1038		1144
		1145	=item cf::register_exticmd $name => \&callback($ns,$packet);
		1146
		1147	Register a callback for execution when the client sends an (asynchronous)
		1148	exticmd packet. Exti commands are processed by the server as soon as they
		1149	are received, i.e. out of order w.r.t. other commands. The first argument
		1150	is a client socket. Exti commands can be received anytime, even before
		1151	log-in.
		1152
		1153	If the callback returns something, it is sent back as if reply was being
		1154	called.
		1155
1039	=cut	1156	=cut
1040		1157
1041	sub register_extcmd {	1158	sub register_extcmd {
1042	my ($name, $cb) = @_;	1159	my ($name, $cb) = @_;
1043		1160
1044	$EXTCMD{$name} = $cb;	1161	$EXTCMD{$name} = $cb;
		1162	}
		1163
		1164	sub register_exticmd {
		1165	my ($name, $cb) = @_;
		1166
		1167	$EXTICMD{$name} = $cb;
1045	}	1168	}
1046		1169
1047	cf::player->attach (	1170	cf::player->attach (
1048	on_command => sub {	1171	on_command => sub {
1049	my ($pl, $name, $params) = @_;	1172	my ($pl, $name, $params) = @_;
…		…
1058	cf::override;	1181	cf::override;
1059	},	1182	},
1060	on_extcmd => sub {	1183	on_extcmd => sub {
1061	my ($pl, $buf) = @_;	1184	my ($pl, $buf) = @_;
1062		1185
1063	my $msg = eval { from_json $buf };	1186	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1064		1187
1065	if (ref $msg) {	1188	if (ref $msg) {
		1189	my ($type, $reply, @payload) =
		1190	"ARRAY" eq ref $msg
		1191	? @$msg
		1192	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		1193
		1194	my @reply;
		1195
1066	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1196	if (my $cb = $EXTCMD{$type}) {
1067	if (my %reply = $cb->($pl, $msg)) {	1197	@reply = $cb->($pl, @payload);
1068	$pl->ext_reply ($msg->{msgid}, %reply);
1069	}
1070	}	1198	}
		1199
		1200	$pl->ext_reply ($reply, @reply)
		1201	if $reply;
		1202
1071	} else {	1203	} else {
1072	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1204	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1073	}	1205	}
1074		1206
1075	cf::override;	1207	cf::override;
…		…
1165		1297
1166	=head3 cf::player	1298	=head3 cf::player
1167		1299
1168	=over 4	1300	=over 4
1169		1301
		1302	=item cf::player::num_playing
		1303
		1304	Returns the official number of playing players, as per the Crossfire metaserver rules.
		1305
		1306	=cut
		1307
		1308	sub num_playing {
		1309	scalar grep
		1310	$_->ob->map
		1311	&& !$_->hidden
		1312	&& !$_->ob->flag (cf::FLAG_WIZ),
		1313	cf::player::list
		1314	}
		1315
1170	=item cf::player::find $login	1316	=item cf::player::find $login
1171		1317
1172	Returns the given player object, loading it if necessary (might block).	1318	Returns the given player object, loading it if necessary (might block).
1173		1319
1174	=cut	1320	=cut
…		…
1209	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";	1355	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1210	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";	1356	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1211	aio_unlink +(playerdir $login) . "/$login.pl.pst";	1357	aio_unlink +(playerdir $login) . "/$login.pl.pst";
1212	aio_unlink +(playerdir $login) . "/$login.pl";	1358	aio_unlink +(playerdir $login) . "/$login.pl";
1213		1359
1214	my $pl = load_pl path $login	1360	my $f = new_from_file cf::object::thawer path $login
1215	or return;	1361	or return;
		1362
		1363	my $pl = cf::player::load_pl $f
		1364	or return;
		1365	local $cf::PLAYER_LOADING{$login} = $pl;
		1366	$f->resolve_delayed_derefs;
1216	$cf::PLAYER{$login} = $pl	1367	$cf::PLAYER{$login} = $pl
1217	}	1368	}
1218	}	1369	}
1219	}	1370	}
1220		1371
…		…
1230		1381
1231	aio_mkdir playerdir $pl, 0770;	1382	aio_mkdir playerdir $pl, 0770;
1232	$pl->{last_save} = $cf::RUNTIME;	1383	$pl->{last_save} = $cf::RUNTIME;
1233		1384
1234	$pl->save_pl ($path);	1385	$pl->save_pl ($path);
1235	Coro::cede;	1386	cf::cede_to_tick;
1236	}	1387	}
1237		1388
1238	sub new($) {	1389	sub new($) {
1239	my ($login) = @_;	1390	my ($login) = @_;
1240		1391
…		…
1244	$self->{deny_save} = 1;	1395	$self->{deny_save} = 1;
1245		1396
1246	$cf::PLAYER{$login} = $self;	1397	$cf::PLAYER{$login} = $self;
1247		1398
1248	$self	1399	$self
		1400	}
		1401
		1402	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1403
		1404	=cut
		1405
		1406	sub send_msg {
		1407	my $ns = shift->ns
		1408	or return;
		1409	$ns->send_msg (@_);
1249	}	1410	}
1250		1411
1251	=item $pl->quit_character	1412	=item $pl->quit_character
1252		1413
1253	Nukes the player without looking back. If logged in, the connection will	1414	Nukes the player without looking back. If logged in, the connection will
…		…
1308	or return [];	1469	or return [];
1309		1470
1310	my @logins;	1471	my @logins;
1311		1472
1312	for my $login (@$dirs) {	1473	for my $login (@$dirs) {
		1474	my $path = path $login;
		1475
		1476	# a .pst is a dead give-away for a valid player
		1477	unless (-e "$path.pst") {
1313	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;	1478	my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1314	aio_read $fh, 0, 512, my $buf, 0 or next;	1479	aio_read $fh, 0, 512, my $buf, 0 or next;
1315	$buf !~ /^password -------------$/m or next; # official not-valid tag	1480	$buf !~ /^password -------------$/m or next; # official not-valid tag
		1481	}
1316		1482
1317	utf8::decode $login;	1483	utf8::decode $login;
1318	push @logins, $login;	1484	push @logins, $login;
1319	}	1485	}
1320		1486
…		…
1347	}	1513	}
1348		1514
1349	\@paths	1515	\@paths
1350	}	1516	}
1351		1517
		1518	=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
		1519
		1520	Expand crossfire pod fragments into protocol xml.
		1521
		1522	=cut
		1523
		1524	sub expand_cfpod {
		1525	((my $self), (local $_)) = @_;
		1526
		1527	# escape & and <
		1528	s/&/&amp;/g;
		1529	s/(?<![BIUGHT])</&lt;/g;
		1530
		1531	# this is buggy, it needs to properly take care of nested <'s
		1532
		1533	1 while
		1534	# replace B<>, I<>, U<> etc.
		1535	s/B<([^\>]*)>/<b>$1<\/b>/
		1536	|| s/I<([^\>]*)>/<i>$1<\/i>/
		1537	|| s/U<([^\>]*)>/<u>$1<\/u>/
		1538	|| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
		1539	# replace G<male|female> tags
		1540	|| s{G<([^>|]*)\|([^>]*)>}{
		1541	$self->gender ? $2 : $1
		1542	}ge
		1543	# replace H<hint text>
		1544	|| s{H<([^\>]*)>}
		1545	{
		1546	("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
		1547	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
		1548	"")
		1549	[$self->{hintmode}]
		1550	}ge;
		1551
		1552	# create single paragraphs (very hackish)
		1553	s/(?<=\S)\n(?=\w)/ /g;
		1554
		1555	# compress some whitespace
		1556	s/\s+\n/\n/g; # ws line-ends
		1557	s/\n\n+/\n/g; # double lines
		1558	s/^\n+//; # beginning lines
		1559	s/\n+$//; # ending lines
		1560
		1561	$_
		1562	}
		1563
		1564	sub hintmode {
		1565	$_[0]{hintmode} = $_[1] if @_ > 1;
		1566	$_[0]{hintmode}
		1567	}
		1568
1352	=item $player->ext_reply ($msgid, %msg)	1569	=item $player->ext_reply ($msgid, @msg)
1353		1570
1354	Sends an ext reply to the player.	1571	Sends an ext reply to the player.
1355		1572
1356	=cut	1573	=cut
1357		1574
1358	sub ext_reply($$%) {	1575	sub ext_reply($$@) {
1359	my ($self, $id, %msg) = @_;	1576	my ($self, $id, @msg) = @_;
1360		1577
1361	$msg{msgid} = $id;	1578	$self->ns->ext_reply ($id, @msg)
1362
1363	$self->send ("ext " . cf::to_json \%msg);
1364	}	1579	}
1365		1580
1366	=item $player->ext_event ($type, %msg)	1581	=item $player->ext_msg ($type, @msg)
1367		1582
1368	Sends an ext event to the client.	1583	Sends an ext event to the client.
1369		1584
1370	=cut	1585	=cut
1371		1586
1372	sub ext_event($$%) {	1587	sub ext_msg($$@) {
1373	my ($self, $type, %msg) = @_;	1588	my ($self, $type, @msg) = @_;
1374		1589
1375	$self->ns->ext_event ($type, %msg);	1590	$self->ns->ext_msg ($type, @msg);
1376	}	1591	}
1377		1592
1378	=head3 cf::region	1593	=head3 cf::region
1379		1594
1380	=over 4	1595	=over 4
…		…
1393	my ($path) = @_;	1608	my ($path) = @_;
1394		1609
1395	my ($match, $specificity);	1610	my ($match, $specificity);
1396		1611
1397	for my $region (list) {	1612	for my $region (list) {
1398	if ($region->match && $path =~ $region->match) {	1613	if ($region->{match} && $path =~ $region->{match}) {
1399	($match, $specificity) = ($region, $region->specificity)	1614	($match, $specificity) = ($region, $region->specificity)
1400	if $region->specificity > $specificity;	1615	if $region->specificity > $specificity;
1401	}	1616	}
1402	}	1617	}
1403		1618
…		…
1523	$self->init; # pass $1 etc.	1738	$self->init; # pass $1 etc.
1524	return $self;	1739	return $self;
1525	}	1740	}
1526	}	1741	}
1527		1742
1528	Carp::carp "unable to resolve path '$path' (base '$base').";	1743	Carp::cluck "unable to resolve path '$path' (base '$base').";
1529	()	1744	()
1530	}	1745	}
1531		1746
1532	sub init {	1747	sub init {
1533	my ($self) = @_;	1748	my ($self) = @_;
…		…
1596		1811
1597	sub load_header_from($) {	1812	sub load_header_from($) {
1598	my ($self, $path) = @_;	1813	my ($self, $path) = @_;
1599		1814
1600	utf8::encode $path;	1815	utf8::encode $path;
1601	#aio_open $path, O_RDONLY, 0	1816	my $f = new_from_file cf::object::thawer $path
1602	# or return;
1603
1604	$self->_load_header ($path)
1605	or return;	1817	or return;
		1818
		1819	$self->_load_header ($f)
		1820	or return;
		1821
		1822	local $MAP_LOADING{$self->{path}} = $self;
		1823	$f->resolve_delayed_derefs;
1606		1824
1607	$self->{load_path} = $path;	1825	$self->{load_path} = $path;
1608		1826
1609	1	1827	1
1610	}	1828	}
…		…
1664	sub find {	1882	sub find {
1665	my ($path, $origin) = @_;	1883	my ($path, $origin) = @_;
1666		1884
1667	$path = normalise $path, $origin && $origin->path;	1885	$path = normalise $path, $origin && $origin->path;
1668		1886
		1887	cf::lock_wait "map_data:$path";#d#remove
1669	cf::lock_wait "map_find:$path";	1888	cf::lock_wait "map_find:$path";
1670		1889
1671	$cf::MAP{$path} || do {	1890	$cf::MAP{$path} || do {
1672	my $guard = cf::lock_acquire "map_find:$path";	1891	my $guard1 = cf::lock_acquire "map_find:$path";
		1892	my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
		1893
1673	my $map = new_from_path cf::map $path	1894	my $map = new_from_path cf::map $path
1674	or return;	1895	or return;
1675		1896
1676	$map->{last_save} = $cf::RUNTIME;	1897	$map->{last_save} = $cf::RUNTIME;
1677		1898
…		…
1679	or return;	1900	or return;
1680		1901
1681	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)	1902	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1682	# doing this can freeze the server in a sync job, obviously	1903	# doing this can freeze the server in a sync job, obviously
1683	#$cf::WAIT_FOR_TICK->wait;	1904	#$cf::WAIT_FOR_TICK->wait;
		1905	undef $guard1;
		1906	undef $guard2;
1684	$map->reset;	1907	$map->reset;
1685	undef $guard;
1686	return find $path;	1908	return find $path;
1687	}	1909	}
1688		1910
1689	$cf::MAP{$path} = $map	1911	$cf::MAP{$path} = $map
1690	}	1912	}
…		…
1699	local $self->{deny_reset} = 1; # loading can take a long time	1921	local $self->{deny_reset} = 1; # loading can take a long time
1700		1922
1701	my $path = $self->{path};	1923	my $path = $self->{path};
1702		1924
1703	{	1925	{
1704	my $guard = cf::lock_acquire "map_load:$path";	1926	my $guard = cf::lock_acquire "map_data:$path";
1705		1927
		1928	return unless $self->valid;
1706	return if $self->in_memory != cf::MAP_SWAPPED;	1929	return unless $self->in_memory == cf::MAP_SWAPPED;
1707		1930
1708	$self->in_memory (cf::MAP_LOADING);	1931	$self->in_memory (cf::MAP_LOADING);
1709		1932
1710	$self->alloc;	1933	$self->alloc;
1711		1934
1712	$self->pre_load;	1935	$self->pre_load;
1713	Coro::cede;	1936	cf::cede_to_tick;
1714		1937
		1938	my $f = new_from_file cf::object::thawer $self->{load_path};
		1939	$f->skip_block;
1715	$self->_load_objects ($self->{load_path}, 1)	1940	$self->_load_objects ($f)
1716	or return;	1941	or return;
1717		1942
1718	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	1943	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1719	if delete $self->{load_original};	1944	if delete $self->{load_original};
1720		1945
1721	if (my $uniq = $self->uniq_path) {	1946	if (my $uniq = $self->uniq_path) {
1722	utf8::encode $uniq;	1947	utf8::encode $uniq;
1723	if (aio_open $uniq, O_RDONLY, 0) {	1948	unless (aio_stat $uniq) {
		1949	if (my $f = new_from_file cf::object::thawer $uniq) {
1724	$self->clear_unique_items;	1950	$self->clear_unique_items;
1725	$self->_load_objects ($uniq, 0);	1951	$self->_load_objects ($f);
		1952	$f->resolve_delayed_derefs;
		1953	}
1726	}	1954	}
1727	}	1955	}
1728		1956
1729	Coro::cede;	1957	$f->resolve_delayed_derefs;
		1958
		1959	cf::cede_to_tick;
1730	# now do the right thing for maps	1960	# now do the right thing for maps
1731	$self->link_multipart_objects;	1961	$self->link_multipart_objects;
1732	$self->difficulty ($self->estimate_difficulty)	1962	$self->difficulty ($self->estimate_difficulty)
1733	unless $self->difficulty;	1963	unless $self->difficulty;
1734	Coro::cede;	1964	cf::cede_to_tick;
1735		1965
1736	unless ($self->{deny_activate}) {	1966	unless ($self->{deny_activate}) {
1737	$self->decay_objects;	1967	$self->decay_objects;
1738	$self->fix_auto_apply;	1968	$self->fix_auto_apply;
1739	$self->update_buttons;	1969	$self->update_buttons;
1740	Coro::cede;	1970	cf::cede_to_tick;
1741	$self->set_darkness_map;	1971	$self->set_darkness_map;
1742	Coro::cede;	1972	cf::cede_to_tick;
1743	$self->activate;	1973	$self->activate;
1744	}	1974	}
		1975
		1976	$self->{last_save} = $cf::RUNTIME;
		1977	$self->last_access ($cf::RUNTIME);
1745		1978
1746	$self->in_memory (cf::MAP_IN_MEMORY);	1979	$self->in_memory (cf::MAP_IN_MEMORY);
1747	}	1980	}
1748		1981
1749	$self->post_load;	1982	$self->post_load;
…		…
1760		1993
1761	$self	1994	$self
1762	}	1995	}
1763		1996
1764	# find and load all maps in the 3x3 area around a map	1997	# find and load all maps in the 3x3 area around a map
1765	sub load_diag {	1998	sub load_neighbours {
1766	my ($map) = @_;	1999	my ($map) = @_;
1767		2000
1768	my @diag; # diagonal neighbours	2001	my @neigh; # diagonal neighbours
1769		2002
1770	for (0 .. 3) {	2003	for (0 .. 3) {
1771	my $neigh = $map->tile_path ($_)	2004	my $neigh = $map->tile_path ($_)
1772	or next;	2005	or next;
1773	$neigh = find $neigh, $map	2006	$neigh = find $neigh, $map
1774	or next;	2007	or next;
1775	$neigh->load;	2008	$neigh->load;
1776		2009
		2010	push @neigh,
1777	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],	2011	[$neigh->tile_path (($_ + 3) % 4), $neigh],
1778	[$neigh->tile_path (($_ + 1) % 4), $neigh];	2012	[$neigh->tile_path (($_ + 1) % 4), $neigh];
1779	}	2013	}
1780		2014
1781	for (@diag) {	2015	for (grep defined $_->[0], @neigh) {
		2016	my ($path, $origin) = @$_;
1782	my $neigh = find @$_	2017	my $neigh = find $path, $origin
1783	or next;	2018	or next;
1784	$neigh->load;	2019	$neigh->load;
1785	}	2020	}
1786	}	2021	}
1787		2022
…		…
1792	}	2027	}
1793		2028
1794	sub do_load_sync {	2029	sub do_load_sync {
1795	my ($map) = @_;	2030	my ($map) = @_;
1796		2031
		2032	cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
		2033	if $Coro::current == $Coro::main;
		2034
1797	cf::sync_job { $map->load };	2035	cf::sync_job { $map->load };
1798	}	2036	}
1799		2037
1800	our %MAP_PREFETCH;	2038	our %MAP_PREFETCH;
1801	our $MAP_PREFETCHER = undef;	2039	our $MAP_PREFETCHER = undef;
1802		2040
1803	sub find_async {	2041	sub find_async {
1804	my ($path, $origin) = @_;	2042	my ($path, $origin, $load) = @_;
1805		2043
1806	$path = normalise $path, $origin && $origin->{path};	2044	$path = normalise $path, $origin && $origin->{path};
1807		2045
1808	if (my $map = $cf::MAP{$path}) {	2046	if (my $map = $cf::MAP{$path}) {
1809	return $map if $map->in_memory == cf::MAP_IN_MEMORY;	2047	return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1810	}	2048	}
1811		2049
1812	undef $MAP_PREFETCH{$path};	2050	$MAP_PREFETCH{$path} |= $load;
		2051
1813	$MAP_PREFETCHER ||= cf::async {	2052	$MAP_PREFETCHER ||= cf::async {
		2053	$Coro::current->{desc} = "map prefetcher";
		2054
1814	while (%MAP_PREFETCH) {	2055	while (%MAP_PREFETCH) {
1815	for my $path (keys %MAP_PREFETCH) {	2056	while (my ($k, $v) = each %MAP_PREFETCH) {
1816	my $map = find $path	2057	if (my $map = find $k) {
1817	or next;
1818	$map->load;	2058	$map->load if $v;
		2059	}
1819		2060
1820	delete $MAP_PREFETCH{$path};	2061	delete $MAP_PREFETCH{$k};
1821	}	2062	}
1822	}	2063	}
1823	undef $MAP_PREFETCHER;	2064	undef $MAP_PREFETCHER;
1824	};	2065	};
1825	$MAP_PREFETCHER->prio (6);	2066	$MAP_PREFETCHER->prio (6);
…		…
1828	}	2069	}
1829		2070
1830	sub save {	2071	sub save {
1831	my ($self) = @_;	2072	my ($self) = @_;
1832		2073
1833	my $lock = cf::lock_acquire "map_data:" . $self->path;	2074	my $lock = cf::lock_acquire "map_data:$self->{path}";
1834		2075
1835	$self->{last_save} = $cf::RUNTIME;	2076	$self->{last_save} = $cf::RUNTIME;
1836		2077
1837	return unless $self->dirty;	2078	return unless $self->dirty;
1838		2079
…		…
1844	return if $self->{deny_save};	2085	return if $self->{deny_save};
1845		2086
1846	local $self->{last_access} = $self->last_access;#d#	2087	local $self->{last_access} = $self->last_access;#d#
1847		2088
1848	cf::async {	2089	cf::async {
		2090	$Coro::current->{desc} = "map player save";
1849	$_->contr->save for $self->players;	2091	$_->contr->save for $self->players;
1850	};	2092	};
1851		2093
1852	if ($uniq) {	2094	if ($uniq) {
1853	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);	2095	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
…		…
1861	my ($self) = @_;	2103	my ($self) = @_;
1862		2104
1863	# save first because save cedes	2105	# save first because save cedes
1864	$self->save;	2106	$self->save;
1865		2107
1866	my $lock = cf::lock_acquire "map_data:" . $self->path;	2108	my $lock = cf::lock_acquire "map_data:$self->{path}";
1867		2109
1868	return if $self->players;	2110	return if $self->players;
1869	return if $self->in_memory != cf::MAP_IN_MEMORY;	2111	return if $self->in_memory != cf::MAP_IN_MEMORY;
1870	return if $self->{deny_save};	2112	return if $self->{deny_save};
1871		2113
		2114	$self->in_memory (cf::MAP_SWAPPED);
		2115
		2116	$self->deactivate;
		2117	$_->clear_links_to ($self) for values %cf::MAP;
1872	$self->clear;	2118	$self->clear;
1873	$self->in_memory (cf::MAP_SWAPPED);
1874	}	2119	}
1875		2120
1876	sub reset_at {	2121	sub reset_at {
1877	my ($self) = @_;	2122	my ($self) = @_;
1878		2123
…		…
1910	if $uniq;	2155	if $uniq;
1911	}	2156	}
1912		2157
1913	delete $cf::MAP{$self->path};	2158	delete $cf::MAP{$self->path};
1914		2159
		2160	$self->deactivate;
		2161	$_->clear_links_to ($self) for values %cf::MAP;
1915	$self->clear;	2162	$self->clear;
1916
1917	$_->clear_links_to ($self) for values %cf::MAP;
1918		2163
1919	$self->unlink_save;	2164	$self->unlink_save;
1920	$self->destroy;	2165	$self->destroy;
1921	}	2166	}
1922		2167
1923	my $nuke_counter = "aaaa";	2168	my $nuke_counter = "aaaa";
1924		2169
1925	sub nuke {	2170	sub nuke {
1926	my ($self) = @_;	2171	my ($self) = @_;
1927		2172
		2173	{
		2174	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2175
1928	delete $cf::MAP{$self->path};	2176	delete $cf::MAP{$self->path};
1929		2177
1930	$self->unlink_save;	2178	$self->unlink_save;
1931		2179
1932	bless $self, "cf::map";	2180	bless $self, "cf::map";
1933	delete $self->{deny_reset};	2181	delete $self->{deny_reset};
1934	$self->{deny_save} = 1;	2182	$self->{deny_save} = 1;
1935	$self->reset_timeout (1);	2183	$self->reset_timeout (1);
1936	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2184	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1937		2185
1938	$cf::MAP{$self->path} = $self;	2186	$cf::MAP{$self->path} = $self;
		2187	}
1939		2188
1940	$self->reset; # polite request, might not happen	2189	$self->reset; # polite request, might not happen
1941	}	2190	}
1942		2191
1943	=item $maps = cf::map::tmp_maps	2192	=item $maps = cf::map::tmp_maps
…		…
2019		2268
2020	sub inv_recursive {	2269	sub inv_recursive {
2021	inv_recursive_ inv $_[0]	2270	inv_recursive_ inv $_[0]
2022	}	2271	}
2023		2272
		2273	=item $ref = $ob->ref
		2274
		2275	creates and returns a persistent reference to an objetc that can be stored as a string.
		2276
		2277	=item $ob = cf::object::deref ($refstring)
		2278
		2279	returns the objetc referenced by refstring. may return undef when it cnanot find the object,
		2280	even if the object actually exists. May block.
		2281
		2282	=cut
		2283
		2284	sub deref {
		2285	my ($ref) = @_;
		2286
		2287	if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
		2288	my ($uuid, $name) = ($1, $2);
		2289	my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
		2290	or return;
		2291	$pl->ob->uuid eq $uuid
		2292	or return;
		2293
		2294	$pl->ob
		2295	} else {
		2296	warn "$ref: cannot resolve object reference\n";
		2297	undef
		2298	}
		2299	}
		2300
2024	package cf;	2301	package cf;
2025		2302
2026	=back	2303	=back
2027		2304
2028	=head3 cf::object::player	2305	=head3 cf::object::player
…		…
2050		2327
2051	} else {	2328	} else {
2052	my $pl = $self->contr;	2329	my $pl = $self->contr;
2053		2330
2054	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2331	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2055	my $diag = $pl->{npc_dialog};	2332	my $dialog = $pl->{npc_dialog};
2056	$diag->{pl}->ext_reply (	2333	$dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2057	$diag->{id}, msgtype => "reply", msg => $msg, add_topics => []
2058	);
2059		2334
2060	} else {	2335	} else {
2061	$msg = $npc->name . " says: $msg" if $npc;	2336	$msg = $npc->name . " says: $msg" if $npc;
2062	$self->message ($msg, $flags);	2337	$self->message ($msg, $flags);
2063	}	2338	}
2064	}	2339	}
		2340	}
		2341
		2342	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2343
		2344	=cut
		2345
		2346	sub cf::object::send_msg {
		2347	my $pl = shift->contr
		2348	or return;
		2349	$pl->send_msg (@_);
2065	}	2350	}
2066		2351
2067	=item $player_object->may ("access")	2352	=item $player_object->may ("access")
2068		2353
2069	Returns wether the given player is authorized to access resource "access"	2354	Returns wether the given player is authorized to access resource "access"
…		…
2148	# use -1 or undef as default coordinates, not 0, 0	2433	# use -1 or undef as default coordinates, not 0, 0
2149	($x, $y) = ($map->enter_x, $map->enter_y)	2434	($x, $y) = ($map->enter_x, $map->enter_y)
2150	if $x <=0 && $y <= 0;	2435	if $x <=0 && $y <= 0;
2151		2436
2152	$map->load;	2437	$map->load;
2153	$map->load_diag;	2438	$map->load_neighbours;
2154		2439
2155	return unless $self->contr->active;	2440	return unless $self->contr->active;
2156	$self->activate_recursive;	2441	$self->activate_recursive;
2157		2442
2158	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2443	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2159	$self->enter_map ($map, $x, $y);	2444	$self->enter_map ($map, $x, $y);
2160	}	2445	}
2161		2446
2162	=item $player_object->goto ($path, $x, $y[, $check->($map)])	2447	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2163		2448
2164	Moves the player to the given map-path and coordinates by first freezing	2449	Moves the player to the given map-path and coordinates by first freezing
2165	her, loading and preparing them map, calling the provided $check callback	2450	her, loading and preparing them map, calling the provided $check callback
2166	that has to return the map if sucecssful, and then unfreezes the player on	2451	that has to return the map if sucecssful, and then unfreezes the player on
2167	the new (success) or old (failed) map position.	2452	the new (success) or old (failed) map position. In either case, $done will
		2453	be called at the end of this process.
2168		2454
2169	=cut	2455	=cut
2170		2456
2171	our $GOTOGEN;	2457	our $GOTOGEN;
2172		2458
2173	sub cf::object::player::goto {	2459	sub cf::object::player::goto {
2174	my ($self, $path, $x, $y, $check) = @_;	2460	my ($self, $path, $x, $y, $check, $done) = @_;
2175		2461
2176	# do generation counting so two concurrent goto's will be executed in-order	2462	# do generation counting so two concurrent goto's will be executed in-order
2177	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2463	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2178		2464
2179	$self->enter_link;	2465	$self->enter_link;
2180		2466
2181	(async {	2467	(async {
		2468	$Coro::current->{desc} = "player::goto $path $x $y";
		2469
		2470	# *tag paths override both path and x|y
		2471	if ($path =~ /^\*(.*)$/) {
		2472	if (my @obs = grep $_->map, ext::map_tags::find $1) {
		2473	my $ob = $obs[rand @obs];
		2474
		2475	# see if we actually can go there
		2476	if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
		2477	$ob = $obs[rand @obs];
		2478	} else {
		2479	$self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
		2480	}
		2481	# else put us there anyways for now #d#
		2482
		2483	($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
		2484	} else {
		2485	($path, $x, $y) = (undef, undef, undef);
		2486	}
		2487	}
		2488
2182	my $map = eval {	2489	my $map = eval {
2183	my $map = cf::map::find $path;	2490	my $map = defined $path ? cf::map::find $path : undef;
2184		2491
2185	if ($map) {	2492	if ($map) {
2186	$map = $map->customise_for ($self);	2493	$map = $map->customise_for ($self);
2187	$map = $check->($map) if $check && $map;	2494	$map = $check->($map) if $check && $map;
2188	} else {	2495	} else {
2189	$self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);	2496	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2190	}	2497	}
2191		2498
2192	$map	2499	$map
2193	};	2500	};
2194		2501
…		…
2199		2506
2200	if ($gen == $self->{_goto_generation}) {	2507	if ($gen == $self->{_goto_generation}) {
2201	delete $self->{_goto_generation};	2508	delete $self->{_goto_generation};
2202	$self->leave_link ($map, $x, $y);	2509	$self->leave_link ($map, $x, $y);
2203	}	2510	}
		2511
		2512	$done->() if $done;
2204	})->prio (1);	2513	})->prio (1);
2205	}	2514	}
2206		2515
2207	=item $player_object->enter_exit ($exit_object)	2516	=item $player_object->enter_exit ($exit_object)
2208		2517
…		…
2277	my $hp = $exit->stats->hp;	2586	my $hp = $exit->stats->hp;
2278	my $sp = $exit->stats->sp;	2587	my $sp = $exit->stats->sp;
2279		2588
2280	$self->enter_link;	2589	$self->enter_link;
2281		2590
		2591	# if exit is damned, update players death & WoR home-position
		2592	$self->contr->savebed ($slaying, $hp, $sp)
		2593	if $exit->flag (FLAG_DAMNED);
		2594
2282	(async {	2595	(async {
		2596	$Coro::current->{desc} = "enter_exit $slaying $hp $sp";
		2597
2283	$self->deactivate_recursive; # just to be sure	2598	$self->deactivate_recursive; # just to be sure
2284	unless (eval {	2599	unless (eval {
2285	$self->goto ($slaying, $hp, $sp);	2600	$self->goto ($slaying, $hp, $sp);
2286		2601
2287	1;	2602	1;
…		…
2313		2628
2314	utf8::encode $text;	2629	utf8::encode $text;
2315	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);	2630	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2316	}	2631	}
2317		2632
		2633	=item $client->send_msg ($channel, $msg, $color, [extra...])
		2634
		2635	Send a drawinfo or msg packet to the client, formatting the msg for the
		2636	client if neccessary. C<$type> should be a string identifying the type of
		2637	the message, with C<log> being the default. If C<$color> is negative, suppress
		2638	the message unless the client supports the msg packet.
		2639
		2640	=cut
		2641
		2642	our %CHANNEL = (
		2643	"c/identify" => {
		2644	id => "infobox",
		2645	title => "Identify",
		2646	reply => undef,
		2647	tooltip => "Items recently identified",
		2648	},
		2649	"c/examine" => {
		2650	id => "infobox",
		2651	title => "Examine",
		2652	reply => undef,
		2653	tooltip => "Signs and other items you examined",
		2654	},
		2655	"c/lookat" => {
		2656	id => "infobox",
		2657	title => "Look",
		2658	reply => undef,
		2659	tooltip => "What you saw there",
		2660	},
		2661	);
		2662
		2663	sub cf::client::send_msg {
		2664	my ($self, $channel, $msg, $color, @extra) = @_;
		2665
		2666	$msg = $self->pl->expand_cfpod ($msg);
		2667
		2668	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2669
		2670	# check predefined channels, for the benefit of C
		2671	if ($CHANNEL{$channel}) {
		2672	$channel = $CHANNEL{$channel};
		2673
		2674	$self->ext_msg (channel_info => $channel)
		2675	if $self->can_msg;
		2676
		2677	$channel = $channel->{id};
		2678
		2679	} elsif (ref $channel) {
		2680	# send meta info to client, if not yet sent
		2681	unless (exists $self->{channel}{$channel->{id}}) {
		2682	$self->{channel}{$channel->{id}} = $channel;
		2683	$self->ext_msg (channel_info => $channel)
		2684	if $self->can_msg;
		2685	}
		2686
		2687	$channel = $channel->{id};
		2688	}
		2689
		2690	return unless @extra || length $msg;
		2691
		2692	if ($self->can_msg) {
		2693	# default colour, mask it out
		2694	$color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
		2695	if $color & cf::NDI_DEF;
		2696
		2697	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2698	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
		2699	} else {
		2700	if ($color >= 0) {
		2701	# replace some tags by gcfclient-compatible ones
		2702	for ($msg) {
		2703	1 while
		2704	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2705	|| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2706	|| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2707	|| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2708	|| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2709	}
		2710
		2711	$color &= cf::NDI_COLOR_MASK;
		2712
		2713	utf8::encode $msg;
		2714
		2715	if (0 && $msg =~ /\[/) {
		2716	# COMMAND/INFO
		2717	$self->send_packet ("drawextinfo $color 10 8 $msg")
		2718	} else {
		2719	$msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
		2720	$self->send_packet ("drawinfo $color $msg")
		2721	}
		2722	}
		2723	}
		2724	}
		2725
2318	=item $client->ext_event ($type, %msg)	2726	=item $client->ext_msg ($type, @msg)
2319		2727
2320	Sends an exti event to the client.	2728	Sends an ext event to the client.
2321		2729
2322	=cut	2730	=cut
2323		2731
2324	sub cf::client::ext_event($$%) {	2732	sub cf::client::ext_msg($$@) {
2325	my ($self, $type, %msg) = @_;	2733	my ($self, $type, @msg) = @_;
2326		2734
		2735	if ($self->extcmd == 2) {
		2736	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2737	} elsif ($self->extcmd == 1) { # TODO: remove
2327	$msg{msgtype} = "event_$type";	2738	push @msg, msgtype => "event_$type";
2328	$self->send_packet ("ext " . cf::to_json \%msg);	2739	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2740	}
		2741	}
		2742
		2743	=item $client->ext_reply ($msgid, @msg)
		2744
		2745	Sends an ext reply to the client.
		2746
		2747	=cut
		2748
		2749	sub cf::client::ext_reply($$@) {
		2750	my ($self, $id, @msg) = @_;
		2751
		2752	if ($self->extcmd == 2) {
		2753	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
		2754	} elsif ($self->extcmd == 1) {
		2755	#TODO: version 1, remove
		2756	unshift @msg, msgtype => "reply", msgid => $id;
		2757	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2758	}
2329	}	2759	}
2330		2760
2331	=item $success = $client->query ($flags, "text", \&cb)	2761	=item $success = $client->query ($flags, "text", \&cb)
2332		2762
2333	Queues a query to the client, calling the given callback with	2763	Queues a query to the client, calling the given callback with
2334	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,	2764	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2335	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.	2765	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2336		2766
2337	Queries can fail, so check the return code. Or don't, as queries will become	2767	Queries can fail, so check the return code. Or don't, as queries will
2338	reliable at some point in the future.	2768	become reliable at some point in the future.
2339		2769
2340	=cut	2770	=cut
2341		2771
2342	sub cf::client::query {	2772	sub cf::client::query {
2343	my ($self, $flags, $text, $cb) = @_;	2773	my ($self, $flags, $text, $cb) = @_;
…		…
2351	utf8::encode $text;	2781	utf8::encode $text;
2352	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];	2782	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2353		2783
2354	$self->send_packet ($self->{query_queue}[0][0])	2784	$self->send_packet ($self->{query_queue}[0][0])
2355	if @{ $self->{query_queue} } == 1;	2785	if @{ $self->{query_queue} } == 1;
		2786
		2787	1
2356	}	2788	}
2357		2789
2358	cf::client->attach (	2790	cf::client->attach (
		2791	on_connect => sub {
		2792	my ($ns) = @_;
		2793
		2794	$ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
		2795	},
2359	on_reply => sub {	2796	on_reply => sub {
2360	my ($ns, $msg) = @_;	2797	my ($ns, $msg) = @_;
2361		2798
2362	# this weird shuffling is so that direct followup queries	2799	# this weird shuffling is so that direct followup queries
2363	# get handled first	2800	# get handled first
…		…
2375	} else {	2812	} else {
2376	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;	2813	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2377	}	2814	}
2378	}	2815	}
2379	},	2816	},
		2817	on_exticmd => sub {
		2818	my ($ns, $buf) = @_;
		2819
		2820	my $msg = eval { $ns->{json_coder}->decode ($buf) };
		2821
		2822	if (ref $msg) {
		2823	my ($type, $reply, @payload) =
		2824	"ARRAY" eq ref $msg
		2825	? @$msg
		2826	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2827
		2828	my @reply;
		2829
		2830	if (my $cb = $EXTICMD{$type}) {
		2831	@reply = $cb->($ns, @payload);
		2832	}
		2833
		2834	$ns->ext_reply ($reply, @reply)
		2835	if $reply;
		2836
		2837	} else {
		2838	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
		2839	}
		2840
		2841	cf::override;
		2842	},
2380	);	2843	);
2381		2844
2382	=item $client->async (\&cb)	2845	=item $client->async (\&cb)
2383		2846
2384	Create a new coroutine, running the specified callback. The coroutine will	2847	Create a new coroutine, running the specified callback. The coroutine will
…		…
2425	our $safe = new Safe "safe";	2888	our $safe = new Safe "safe";
2426	our $safe_hole = new Safe::Hole;	2889	our $safe_hole = new Safe::Hole;
2427		2890
2428	$SIG{FPE} = 'IGNORE';	2891	$SIG{FPE} = 'IGNORE';
2429		2892
2430	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2893	$safe->permit_only (Opcode::opset qw(
		2894	:base_core :base_mem :base_orig :base_math
		2895	grepstart grepwhile mapstart mapwhile
		2896	sort time
		2897	));
2431		2898
2432	# here we export the classes and methods available to script code	2899	# here we export the classes and methods available to script code
2433		2900
2434	=pod	2901	=pod
2435		2902
2436	The following functions and methods are available within a safe environment:	2903	The following functions and methods are available within a safe environment:
2437		2904
2438	cf::object contr pay_amount pay_player map	2905	cf::object
		2906	contr pay_amount pay_player map x y force_find force_add destroy
		2907	insert remove name archname title slaying race decrease_ob_nr
		2908
2439	cf::object::player player	2909	cf::object::player
2440	cf::player peaceful	2910	player
2441	cf::map trigger	2911
		2912	cf::player
		2913	peaceful
		2914
		2915	cf::map
		2916	trigger
2442		2917
2443	=cut	2918	=cut
2444		2919
2445	for (	2920	for (
2446	["cf::object" => qw(contr pay_amount pay_player map)],	2921	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2922	insert remove inv name archname title slaying race
		2923	decrease_ob_nr destroy)],
2447	["cf::object::player" => qw(player)],	2924	["cf::object::player" => qw(player)],
2448	["cf::player" => qw(peaceful)],	2925	["cf::player" => qw(peaceful)],
2449	["cf::map" => qw(trigger)],	2926	["cf::map" => qw(trigger)],
2450	) {	2927	) {
2451	no strict 'refs';	2928	no strict 'refs';
…		…
2527	# the server's init and main functions	3004	# the server's init and main functions
2528		3005
2529	sub load_facedata($) {	3006	sub load_facedata($) {
2530	my ($path) = @_;	3007	my ($path) = @_;
2531		3008
		3009	# HACK to clear player env face cache, we need some signal framework
		3010	# for this (global event?)
		3011	%ext::player_env::MUSIC_FACE_CACHE = ();
		3012
		3013	my $enc = JSON::XS->new->utf8->canonical->relaxed;
		3014
2532	warn "loading facedata from $path\n";	3015	warn "loading facedata from $path\n";
2533		3016
2534	my $facedata;	3017	my $facedata;
2535	0 < aio_load $path, $facedata	3018	0 < aio_load $path, $facedata
2536	or die "$path: $!";	3019	or die "$path: $!";
…		…
2538	$facedata = Coro::Storable::thaw $facedata;	3021	$facedata = Coro::Storable::thaw $facedata;
2539		3022
2540	$facedata->{version} == 2	3023	$facedata->{version} == 2
2541	or cf::cleanup "$path: version mismatch, cannot proceed.";	3024	or cf::cleanup "$path: version mismatch, cannot proceed.";
2542		3025
		3026	# patch in the exptable
		3027	$facedata->{resource}{"res/exp_table"} = {
		3028	type => FT_RSRC,
		3029	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
		3030	};
		3031	cf::cede_to_tick;
		3032
2543	{	3033	{
2544	my $faces = $facedata->{faceinfo};	3034	my $faces = $facedata->{faceinfo};
2545		3035
2546	while (my ($face, $info) = each %$faces) {	3036	while (my ($face, $info) = each %$faces) {
2547	my $idx = (cf::face::find $face) || cf::face::alloc $face;	3037	my $idx = (cf::face::find $face) || cf::face::alloc $face;
2548	cf::face::set $idx, $info->{visibility}, $info->{magicmap};	3038	cf::face::set_visibility $idx, $info->{visibility};
		3039	cf::face::set_magicmap $idx, $info->{magicmap};
2549	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	3040	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2550	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	3041	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2551	Coro::cede;	3042
		3043	cf::cede_to_tick;
2552	}	3044	}
2553		3045
2554	while (my ($face, $info) = each %$faces) {	3046	while (my ($face, $info) = each %$faces) {
2555	next unless $info->{smooth};	3047	next unless $info->{smooth};
2556	my $idx = cf::face::find $face	3048	my $idx = cf::face::find $face
2557	or next;	3049	or next;
2558	if (my $smooth = cf::face::find $info->{smooth}) {	3050	if (my $smooth = cf::face::find $info->{smooth}) {
		3051	cf::face::set_smooth $idx, $smooth;
2559	cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};	3052	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2560	} else {	3053	} else {
2561	warn "smooth face '$info->{smooth}' not found for face '$face'";	3054	warn "smooth face '$info->{smooth}' not found for face '$face'";
2562	}	3055	}
2563	Coro::cede;	3056
		3057	cf::cede_to_tick;
2564	}	3058	}
2565	}	3059	}
2566		3060
2567	{	3061	{
2568	my $anims = $facedata->{animinfo};	3062	my $anims = $facedata->{animinfo};
2569		3063
2570	while (my ($anim, $info) = each %$anims) {	3064	while (my ($anim, $info) = each %$anims) {
2571	cf::anim::set $anim, $info->{frames}, $info->{facings};	3065	cf::anim::set $anim, $info->{frames}, $info->{facings};
2572	Coro::cede;	3066	cf::cede_to_tick;
2573	}	3067	}
2574		3068
2575	cf::anim::invalidate_all; # d'oh	3069	cf::anim::invalidate_all; # d'oh
2576	}	3070	}
2577		3071
		3072	{
		3073	# TODO: for gcfclient pleasure, we should give resources
		3074	# that gcfclient doesn't grok a >10000 face index.
		3075	my $res = $facedata->{resource};
		3076
		3077	my $soundconf = delete $res->{"res/sound.conf"};
		3078
		3079	while (my ($name, $info) = each %$res) {
		3080	my $idx = (cf::face::find $name) || cf::face::alloc $name;
		3081	my $data;
		3082
		3083	if ($info->{type} & 1) {
		3084	# prepend meta info
		3085
		3086	my $meta = $enc->encode ({
		3087	name => $name,
		3088	%{ $info->{meta} || {} },
		3089	});
		3090
		3091	$data = pack "(w/a*)*", $meta, $info->{data};
		3092	} else {
		3093	$data = $info->{data};
		3094	}
		3095
		3096	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
		3097	cf::face::set_type $idx, $info->{type};
		3098
		3099	cf::cede_to_tick;
		3100	}
		3101
		3102	if ($soundconf) {
		3103	$soundconf = $enc->decode (delete $soundconf->{data});
		3104
		3105	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3106	my $sound = $soundconf->{compat}[$_]
		3107	or next;
		3108
		3109	my $face = cf::face::find "sound/$sound->[1]";
		3110	cf::sound::set $sound->[0] => $face;
		3111	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3112	}
		3113
		3114	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3115	my $face = cf::face::find "sound/$v";
		3116	cf::sound::set $k => $face;
		3117	}
		3118	}
		3119	}
		3120
2578	1	3121	1
2579	}	3122	}
2580		3123
		3124	register_exticmd fx_want => sub {
		3125	my ($ns, $want) = @_;
		3126
		3127	while (my ($k, $v) = each %$want) {
		3128	$ns->fx_want ($k, $v);
		3129	}
		3130	};
		3131
2581	sub reload_regions {	3132	sub reload_regions {
		3133	# HACK to clear player env face cache, we need some signal framework
		3134	# for this (global event?)
		3135	%ext::player_env::MUSIC_FACE_CACHE = ();
		3136
2582	load_resource_file "$MAPDIR/regions"	3137	load_resource_file "$MAPDIR/regions"
2583	or die "unable to load regions file\n";	3138	or die "unable to load regions file\n";
		3139
		3140	for (cf::region::list) {
		3141	$_->{match} = qr/$_->{match}/
		3142	if exists $_->{match};
		3143	}
2584	}	3144	}
2585		3145
2586	sub reload_facedata {	3146	sub reload_facedata {
2587	load_facedata "$DATADIR/facedata"	3147	load_facedata "$DATADIR/facedata"
2588	or die "unable to load facedata\n";	3148	or die "unable to load facedata\n";
2589	}	3149	}
2590		3150
2591	sub reload_archetypes {	3151	sub reload_archetypes {
		3152	load_resource_file "$DATADIR/archetypes"
		3153	or die "unable to load archetypes\n";
		3154	#d# NEED to laod twice to resolve forward references
		3155	# this really needs to be done in an extra post-pass
		3156	# (which needs to be synchronous, so solve it differently)
2592	load_resource_file "$DATADIR/archetypes"	3157	load_resource_file "$DATADIR/archetypes"
2593	or die "unable to load archetypes\n";	3158	or die "unable to load archetypes\n";
2594	}	3159	}
2595		3160
2596	sub reload_treasures {	3161	sub reload_treasures {
…		…
2612		3177
2613	sub init {	3178	sub init {
2614	reload_resources;	3179	reload_resources;
2615	}	3180	}
2616		3181
2617	sub cfg_load {	3182	sub reload_config {
2618	open my $fh, "<:utf8", "$CONFDIR/config"	3183	open my $fh, "<:utf8", "$CONFDIR/config"
2619	or return;	3184	or return;
2620		3185
2621	local $/;	3186	local $/;
2622	*CFG = YAML::Syck::Load <$fh>;	3187	*CFG = YAML::Syck::Load <$fh>;
…		…
2638	sub main {	3203	sub main {
2639	# we must not ever block the main coroutine	3204	# we must not ever block the main coroutine
2640	local $Coro::idle = sub {	3205	local $Coro::idle = sub {
2641	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#	3206	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2642	(async {	3207	(async {
		3208	$Coro::current->{desc} = "IDLE BUG HANDLER";
2643	Event::one_event;	3209	Event::one_event;
2644	})->prio (Coro::PRIO_MAX);	3210	})->prio (Coro::PRIO_MAX);
2645	};	3211	};
2646		3212
2647	cfg_load;	3213	reload_config;
2648	db_init;	3214	db_init;
2649	load_extensions;	3215	load_extensions;
2650		3216
2651	$TICK_WATCHER->start;	3217	$TICK_WATCHER->start;
2652	Event::loop;	3218	Event::loop;
…		…
2719	# and maps saved/destroyed asynchronously.	3285	# and maps saved/destroyed asynchronously.
2720	warn "begin emergency player save\n";	3286	warn "begin emergency player save\n";
2721	for my $login (keys %cf::PLAYER) {	3287	for my $login (keys %cf::PLAYER) {
2722	my $pl = $cf::PLAYER{$login} or next;	3288	my $pl = $cf::PLAYER{$login} or next;
2723	$pl->valid or next;	3289	$pl->valid or next;
		3290	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2724	$pl->save;	3291	$pl->save;
2725	}	3292	}
2726	warn "end emergency player save\n";	3293	warn "end emergency player save\n";
2727		3294
2728	warn "begin emergency map save\n";	3295	warn "begin emergency map save\n";
…		…
2790	%EXT_CORO = ();	3357	%EXT_CORO = ();
2791		3358
2792	warn "removing commands";	3359	warn "removing commands";
2793	%COMMAND = ();	3360	%COMMAND = ();
2794		3361
2795	warn "removing ext commands";	3362	warn "removing ext/exti commands";
2796	%EXTCMD = ();	3363	%EXTCMD = ();
		3364	%EXTICMD = ();
2797		3365
2798	warn "unloading/nuking all extensions";	3366	warn "unloading/nuking all extensions";
2799	for my $pkg (@EXTS) {	3367	for my $pkg (@EXTS) {
2800	warn "... unloading $pkg";	3368	warn "... unloading $pkg";
2801		3369
…		…
2844	warn "reloading cf.pm";	3412	warn "reloading cf.pm";
2845	require cf;	3413	require cf;
2846	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3414	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2847		3415
2848	warn "loading config and database again";	3416	warn "loading config and database again";
2849	cf::cfg_load;	3417	cf::reload_config;
2850		3418
2851	warn "loading extensions";	3419	warn "loading extensions";
2852	cf::load_extensions;	3420	cf::load_extensions;
2853		3421
2854	warn "reattaching attachments to objects/players";	3422	warn "reattaching attachments to objects/players";
…		…
2890	register_command "reload" => sub {	3458	register_command "reload" => sub {
2891	my ($who, $arg) = @_;	3459	my ($who, $arg) = @_;
2892		3460
2893	if ($who->flag (FLAG_WIZ)) {	3461	if ($who->flag (FLAG_WIZ)) {
2894	$who->message ("reloading server.");	3462	$who->message ("reloading server.");
		3463	async {
		3464	$Coro::current->{desc} = "perl_reload";
2895	async { reload_perl };	3465	reload_perl;
		3466	};
2896	}	3467	}
2897	};	3468	};
2898		3469
2899	unshift @INC, $LIBDIR;	3470	unshift @INC, $LIBDIR;
2900		3471
…		…
2919	my $signal = new Coro::Signal;	3490	my $signal = new Coro::Signal;
2920	push @WAIT_FOR_TICK_BEGIN, $signal;	3491	push @WAIT_FOR_TICK_BEGIN, $signal;
2921	$signal->wait;	3492	$signal->wait;
2922	}	3493	}
2923		3494
2924	my $min = 1e6;#d#
2925	my $avg = 10;
2926	$TICK_WATCHER = Event->timer (	3495	$TICK_WATCHER = Event->timer (
2927	reentrant => 0,	3496	reentrant => 0,
2928	parked => 1,	3497	parked => 1,
2929	prio => 0,	3498	prio => 0,
2930	at => $NEXT_TICK || $TICK,	3499	at => $NEXT_TICK || $TICK,
…		…
2938		3507
2939	$NOW = $tick_start = Event::time;	3508	$NOW = $tick_start = Event::time;
2940		3509
2941	cf::server_tick; # one server iteration	3510	cf::server_tick; # one server iteration
2942		3511
2943	0 && sync_job {#d#
2944	for(1..10) {
2945	my $t = Event::time;
2946	my $map = my $map = new_from_path cf::map "/tmp/x.map"
2947	or die;
2948
2949	$map->width (50);
2950	$map->height (50);
2951	$map->alloc;
2952	$map->_load_objects ("/tmp/x.map", 1);
2953	my $t = Event::time - $t;
2954
2955	#next unless $t < 0.0013;#d#
2956	if ($t < $min) {
2957	$min = $t;
2958	}
2959	$avg = $avg * 0.99 + $t * 0.01;
2960	}
2961	warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2962	exit 0;
2963	# 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2964	};
2965
2966	$RUNTIME += $TICK;	3512	$RUNTIME += $TICK;
2967	$NEXT_TICK += $TICK;	3513	$NEXT_TICK += $TICK;
2968		3514
2969	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3515	if ($NOW >= $NEXT_RUNTIME_WRITE) {
2970	$NEXT_RUNTIME_WRITE = $NOW + 10;	3516	$NEXT_RUNTIME_WRITE = $NOW + 10;
2971	Coro::async_pool {	3517	Coro::async_pool {
		3518	$Coro::current->{desc} = "runtime saver";
2972	write_runtime	3519	write_runtime
2973	or warn "ERROR: unable to write runtime file: $!";	3520	or warn "ERROR: unable to write runtime file: $!";
2974	};	3521	};
2975	}	3522	}
2976		3523
2977	# my $AFTER = Event::time;
2978	# warn $AFTER - $NOW;#d#
2979
2980	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3524	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2981	$sig->send;	3525	$sig->send;
2982	}	3526	}
2983	while (my $sig = shift @WAIT_FOR_TICK) {	3527	while (my $sig = shift @WAIT_FOR_TICK) {
2984	$sig->send;	3528	$sig->send;
…		…
2994		3538
2995	$LOAD = ($NOW - $tick_start) / $TICK;	3539	$LOAD = ($NOW - $tick_start) / $TICK;
2996	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	3540	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2997		3541
2998	_post_tick;	3542	_post_tick;
2999
3000
3001	},	3543	},
3002	);	3544	);
3003		3545
3004	{	3546	{
		3547	BDB::min_parallel 8;
3005	BDB::max_poll_time $TICK * 0.1;	3548	BDB::max_poll_time $TICK * 0.1;
3006	$BDB_POLL_WATCHER = Event->io (	3549	$BDB_POLL_WATCHER = Event->io (
3007	reentrant => 0,	3550	reentrant => 0,
3008	fd => BDB::poll_fileno,	3551	fd => BDB::poll_fileno,
3009	poll => 'r',	3552	poll => 'r',
3010	prio => 0,	3553	prio => 0,
3011	data => WF_AUTOCANCEL,	3554	data => WF_AUTOCANCEL,
3012	cb => \&BDB::poll_cb,	3555	cb => \&BDB::poll_cb,
3013	);	3556	);
3014	BDB::min_parallel 8;
3015		3557
3016	BDB::set_sync_prepare {	3558	BDB::set_sync_prepare {
3017	my $status;	3559	my $status;
3018	my $current = $Coro::current;	3560	my $current = $Coro::current;
3019	(	3561	(
…		…
3028	)	3570	)
3029	};	3571	};
3030		3572
3031	unless ($DB_ENV) {	3573	unless ($DB_ENV) {
3032	$DB_ENV = BDB::db_env_create;	3574	$DB_ENV = BDB::db_env_create;
		3575	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
		3576	| BDB::LOG_AUTOREMOVE, 1);
		3577	$DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
		3578	$DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3033		3579
3034	cf::sync_job {	3580	cf::sync_job {
3035	eval {	3581	eval {
3036	BDB::db_env_open	3582	BDB::db_env_open
3037	$DB_ENV,	3583	$DB_ENV,
…		…
3039	BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN	3585	BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3040	| BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,	3586	| BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3041	0666;	3587	0666;
3042		3588
3043	cf::cleanup "db_env_open($BDBDIR): $!" if $!;	3589	cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3044
3045	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3046	$DB_ENV->set_lk_detect;
3047	};	3590	};
3048		3591
3049	cf::cleanup "db_env_open(db): $@" if $@;	3592	cf::cleanup "db_env_open(db): $@" if $@;
3050	};	3593	};
3051	}	3594	}
		3595
		3596	$BDB_DEADLOCK_WATCHER = Event->timer (
		3597	after => 3,
		3598	interval => 1,
		3599	hard => 1,
		3600	prio => 0,
		3601	data => WF_AUTOCANCEL,
		3602	cb => sub {
		3603	BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
		3604	},
		3605	);
		3606	$BDB_CHECKPOINT_WATCHER = Event->timer (
		3607	after => 11,
		3608	interval => 60,
		3609	hard => 1,
		3610	prio => 0,
		3611	data => WF_AUTOCANCEL,
		3612	cb => sub {
		3613	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
		3614	},
		3615	);
		3616	$BDB_TRICKLE_WATCHER = Event->timer (
		3617	after => 5,
		3618	interval => 10,
		3619	hard => 1,
		3620	prio => 0,
		3621	data => WF_AUTOCANCEL,
		3622	cb => sub {
		3623	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
		3624	},
		3625	);
3052	}	3626	}
3053		3627
3054	{	3628	{
3055	IO::AIO::min_parallel 8;	3629	IO::AIO::min_parallel 8;
3056		3630
…		…
3059	$AIO_POLL_WATCHER = Event->io (	3633	$AIO_POLL_WATCHER = Event->io (
3060	reentrant => 0,	3634	reentrant => 0,
3061	data => WF_AUTOCANCEL,	3635	data => WF_AUTOCANCEL,
3062	fd => IO::AIO::poll_fileno,	3636	fd => IO::AIO::poll_fileno,
3063	poll => 'r',	3637	poll => 'r',
3064	prio => 6,	3638	prio => 0,
3065	cb => \&IO::AIO::poll_cb,	3639	cb => \&IO::AIO::poll_cb,
3066	);	3640	);
3067	}	3641	}
3068		3642
3069	my $_log_backtrace;	3643	my $_log_backtrace;
…		…
3075		3649
3076	# limit the # of concurrent backtraces	3650	# limit the # of concurrent backtraces
3077	if ($_log_backtrace < 2) {	3651	if ($_log_backtrace < 2) {
3078	++$_log_backtrace;	3652	++$_log_backtrace;
3079	async {	3653	async {
		3654	$Coro::current->{desc} = "abt $msg";
		3655
3080	my @bt = fork_call {	3656	my @bt = fork_call {
3081	@addr = map { sprintf "%x", $_ } @addr;	3657	@addr = map { sprintf "%x", $_ } @addr;
3082	my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;	3658	my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3083	open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"	3659	open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3084	or die "addr2line: $!";	3660	or die "addr2line: $!";

Diff Legend

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