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.267 by root, Sat May 19 00:08:11 2007 UTC vs.
Revision 1.371 by root, Thu Sep 13 16:16:01 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
		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.32 ();
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';
188	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';	200	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
189	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';	201	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
190	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';	202	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
191	@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';	203	@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
		204	@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
192	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';	205	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
193		206
194	# we bless all objects into (empty) derived classes to force a method lookup	207	# we bless all objects into (empty) derived classes to force a method lookup
195	# within the Safe compartment.	208	# within the Safe compartment.
196	for my $pkg (qw(	209	for my $pkg (qw(
197	cf::global cf::attachable	210	cf::global cf::attachable
…		…
205	}	218	}
206		219
207	$Event::DIED = sub {	220	$Event::DIED = sub {
208	warn "error in event callback: @_";	221	warn "error in event callback: @_";
209	};	222	};
		223
		224	#############################################################################
210		225
211	=head2 UTILITY FUNCTIONS	226	=head2 UTILITY FUNCTIONS
212		227
213	=over 4	228	=over 4
214		229
…		…
233	$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;
234	$d	249	$d
235	} || "[unable to dump $_[0]: '$@']";	250	} || "[unable to dump $_[0]: '$@']";
236	}	251	}
237		252
238	use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
239
240	=item $ref = cf::from_json $json	253	=item $ref = cf::from_json $json
241		254
242	Converts a JSON string into the corresponding perl data structure.	255	Converts a JSON string into the corresponding perl data structure.
243		256
244	=item $json = cf::to_json $ref	257	=item $json = cf::to_json $ref
245		258
246	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]) }
247		267
248	=item cf::lock_wait $string	268	=item cf::lock_wait $string
249		269
250	Wait until the given lock is available. See cf::lock_acquire.	270	Wait until the given lock is available. See cf::lock_acquire.
251		271
…		…
254	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
255	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,
256	for example when the coroutine gets canceled), the lock is automatically	276	for example when the coroutine gets canceled), the lock is automatically
257	returned.	277	returned.
258		278
		279	Locks are *not* recursive, locking from the same coro twice results in a
		280	deadlocked coro.
		281
259	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
260	uses map_find and cf::map::load uses map_load).	283	uses map_find and cf::map::load uses map_load).
261		284
262	=item $locked = cf::lock_active $string	285	=item $locked = cf::lock_active $string
263		286
264	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.
265		288
266	=cut	289	=cut
267		290
268	our %LOCK;	291	our %LOCK;
		292	our %LOCKER;#d#
269		293
270	sub lock_wait($) {	294	sub lock_wait($) {
271	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#
272		301
273	# wait for lock, if any	302	# wait for lock, if any
274	while ($LOCK{$key}) {	303	while ($LOCK{$key}) {
275	push @{ $LOCK{$key} }, $Coro::current;	304	push @{ $LOCK{$key} }, $Coro::current;
276	Coro::schedule;	305	Coro::schedule;
…		…
282		311
283	# wait, to be sure we are not locked	312	# wait, to be sure we are not locked
284	lock_wait $key;	313	lock_wait $key;
285		314
286	$LOCK{$key} = [];	315	$LOCK{$key} = [];
		316	$LOCKER{$key} = $Coro::current;#d#
287		317
288	Coro::guard {	318	Coro::guard {
		319	delete $LOCKER{$key};#d#
289	# wake up all waiters, to be on the safe side	320	# wake up all waiters, to be on the safe side
290	$_->ready for @{ delete $LOCK{$key} };	321	$_->ready for @{ delete $LOCK{$key} };
291	}	322	}
292	}	323	}
293		324
…		…
305	};	336	};
306	$TICK_WATCHER->stop;	337	$TICK_WATCHER->stop;
307	$guard	338	$guard
308	}	339	}
309		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	my $signal = new Coro::Signal;
		360
		361	while () {
		362	next_job:
		363	my $avail = cf::till_tick;
		364	if ($avail > 0.01) {
		365	for (0 .. $#SLOT_QUEUE) {
		366	if ($SLOT_QUEUE[$_][0] < $avail) {
		367	my $job = splice @SLOT_QUEUE, $_, 1, ();
		368	$job->[2]->send;
		369	Coro::cede;
		370	goto next_job;
		371	}
		372	}
		373	}
		374
		375	if (@SLOT_QUEUE) {
		376	# we do not use wait_For_tick() as it returns immediately when tick is inactive
		377	push @cf::WAIT_FOR_TICK, $signal;
		378	$signal->wait;
		379	} else {
		380	Coro::schedule;
		381	}
		382	}
		383	};
		384
		385	sub get_slot($;$$) {
		386	my ($time, $pri, $name) = @_;
		387
		388	$time = $TICK * .6 if $time > $TICK * .6;
		389	my $sig = new Coro::Signal;
		390
		391	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
		392	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
		393	$SLOT_QUEUE->ready;
		394	$sig->wait;
		395	}
		396
310	=item cf::async { BLOCK }	397	=item cf::async { BLOCK }
311		398
312	Currently the same as Coro::async_pool, meaning you cannot use	399	Currently the same as Coro::async_pool, meaning you cannot use
313	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only	400	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
314	thing you are allowed to do is call C<prio> on it.	401	thing you are allowed to do is call C<prio> on it.
…		…
317		404
318	BEGIN { *async = \&Coro::async_pool }	405	BEGIN { *async = \&Coro::async_pool }
319		406
320	=item cf::sync_job { BLOCK }	407	=item cf::sync_job { BLOCK }
321		408
322	The design of crossfire+ requires that the main coro ($Coro::main) is	409	The design of Crossfire TRT requires that the main coroutine ($Coro::main)
323	always able to handle events or runnable, as crossfire+ is only partly	410	is always able to handle events or runnable, as Crossfire TRT is only
324	reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.	411	partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
		412	acceptable.
325		413
326	If it must be done, put the blocking parts into C<sync_job>. This will run	414	If it must be done, put the blocking parts into C<sync_job>. This will run
327	the given BLOCK in another coroutine while waiting for the result. The	415	the given BLOCK in another coroutine while waiting for the result. The
328	server will be frozen during this time, so the block should either finish	416	server will be frozen during this time, so the block should either finish
329	fast or be very important.	417	fast or be very important.
…		…
389	$EXT_CORO{$coro+0} = $coro;	477	$EXT_CORO{$coro+0} = $coro;
390		478
391	$coro	479	$coro
392	}	480	}
393		481
394	sub write_runtime {	482	=item fork_call { }, $args
395	my $runtime = "$LOCALDIR/runtime";
396		483
397	# first touch the runtime file to show we are still running:	484	Executes the given code block with the given arguments in a seperate
398	# the fsync below can take a very very long time.	485	process, returning the results. Everything must be serialisable with
		486	Coro::Storable. May, of course, block. Note that the executed sub may
		487	never block itself or use any form of Event handling.
399		488
400	if (my $fh = aio_open $runtime, O_WRONLY, 0) {	489	=cut
401	utime undef, undef, $fh;	490
		491	sub fork_call(&@) {
		492	my ($cb, @args) = @_;
		493
		494	# we seemingly have to make a local copy of the whole thing,
		495	# otherwise perl prematurely frees the stuff :/
		496	# TODO: investigate and fix (likely this will be rather laborious)
		497
		498	my @res = Coro::Util::fork_eval {
		499	reset_signals;
		500	&$cb
		501	}, @args;
		502
		503	wantarray ? @res : $res[-1]
		504	}
		505
		506	=item $value = cf::db_get $family => $key
		507
		508	Returns a single value from the environment database.
		509
		510	=item cf::db_put $family => $key => $value
		511
		512	Stores the given C<$value> in the family. It can currently store binary
		513	data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
		514
		515	=item $db = cf::db_table "name"
		516
		517	Create and/or open a new database table. The string must not be "db" and must be unique
		518	within each server.
		519
		520	=cut
		521
		522	sub db_table($) {
		523	my ($name) = @_;
		524	my $db = BDB::db_create $DB_ENV;
		525
		526	eval {
		527	$db->set_flags (BDB::CHKSUM);
		528
		529	utf8::encode $name;
		530	BDB::db_open $db, undef, $name, undef, BDB::BTREE,
		531	BDB::CREATE | BDB::AUTO_COMMIT, 0666;
		532	cf::cleanup "db_open(db): $!" if $!;
402	}	533	};
		534	cf::cleanup "db_open(db): $@" if $@;
403		535
404	my $guard = cf::lock_acquire "write_runtime";	536	$db
		537	}
405		538
406	my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644	539	our $DB;
407	or return;
408		540
409	my $value = $cf::RUNTIME + 90 + 10;	541	sub db_init {
410	# 10 is the runtime save interval, for a monotonic clock	542	cf::sync_job {
411	# 60 allows for the watchdog to kill the server.	543	$DB ||= db_table "db";
		544	};
		545	}
412		546
413	(aio_write $fh, 0, (length $value), $value, 0) <= 0	547	sub db_get($$) {
414	and return;	548	my $key = "$_[0]/$_[1]";
415		549
416	# always fsync - this file is important	550	cf::sync_job {
417	aio_fsync $fh	551	BDB::db_get $DB, undef, $key, my $data;
418	and return;
419		552
420	# touch it again to show we are up-to-date	553	$! ? ()
421	utime undef, undef, $fh;	554	: $data
422
423	close $fh
424	or return;
425
426	aio_rename "$runtime~", $runtime
427	and return;
428
429	warn "runtime file written.\n";#d#
430
431	1	555	}
		556	}
		557
		558	sub db_put($$$) {
		559	BDB::dbreq_pri 4;
		560	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
		561	}
		562
		563	=item cf::cache $id => [$paths...], $processversion => $process
		564
		565	Generic caching function that returns the value of the resource $id,
		566	caching and regenerating as required.
		567
		568	This function can block.
		569
		570	=cut
		571
		572	sub cache {
		573	my ($id, $src, $processversion, $process) = @_;
		574
		575	my $meta =
		576	join "\x00",
		577	$processversion,
		578	map {
		579	aio_stat $_
		580	and Carp::croak "$_: $!";
		581
		582	($_, (stat _)[7,9])
		583	} @$src;
		584
		585	my $dbmeta = db_get cache => "$id/meta";
		586	if ($dbmeta ne $meta) {
		587	# changed, we may need to process
		588
		589	my @data;
		590	my $md5;
		591
		592	for (0 .. $#$src) {
		593	0 <= aio_load $src->[$_], $data[$_]
		594	or Carp::croak "$src->[$_]: $!";
		595	}
		596
		597	# if processing is expensive, check
		598	# checksum first
		599	if (1) {
		600	$md5 =
		601	join "\x00",
		602	$processversion,
		603	map {
		604	cf::cede_to_tick;
		605	($src->[$_], Digest::MD5::md5_hex $data[$_])
		606	} 0.. $#$src;
		607
		608
		609	my $dbmd5 = db_get cache => "$id/md5";
		610	if ($dbmd5 eq $md5) {
		611	db_put cache => "$id/meta", $meta;
		612
		613	return db_get cache => "$id/data";
		614	}
		615	}
		616
		617	my $t1 = Time::HiRes::time;
		618	my $data = $process->(\@data);
		619	my $t2 = Time::HiRes::time;
		620
		621	warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
		622
		623	db_put cache => "$id/data", $data;
		624	db_put cache => "$id/md5" , $md5;
		625	db_put cache => "$id/meta", $meta;
		626
		627	return $data;
		628	}
		629
		630	db_get cache => "$id/data"
432	}	631	}
433		632
434	=item cf::datalog type => key => value, ...	633	=item cf::datalog type => key => value, ...
435		634
436	Log a datalog packet of the given type with the given key-value pairs.	635	Log a datalog packet of the given type with the given key-value pairs.
…		…
454	attach callbacks/event handlers (a collection of which is called an "attachment")	653	attach callbacks/event handlers (a collection of which is called an "attachment")
455	to it. All such attachable objects support the following methods.	654	to it. All such attachable objects support the following methods.
456		655
457	In the following description, CLASS can be any of C<global>, C<object>	656	In the following description, CLASS can be any of C<global>, C<object>
458	C<player>, C<client> or C<map> (i.e. the attachable objects in	657	C<player>, C<client> or C<map> (i.e. the attachable objects in
459	crossfire+).	658	Crossfire TRT).
460		659
461	=over 4	660	=over 4
462		661
463	=item $attachable->attach ($attachment, key => $value...)	662	=item $attachable->attach ($attachment, key => $value...)
464		663
…		…
666	_attach $registry, $klass, @attach;	865	_attach $registry, $klass, @attach;
667	}	866	}
668		867
669	$obj->{$name} = \%arg;	868	$obj->{$name} = \%arg;
670	} else {	869	} else {
671	warn "object uses attachment '$name' that is not available, postponing.\n";	870	warn "object uses attachment '$name' which is not available, postponing.\n";
672	}	871	}
673		872
674	$obj->{_attachment}{$name} = undef;	873	$obj->{_attachment}{$name} = undef;
675	}	874	}
676		875
…		…
716	";	915	";
717	die if $@;	916	die if $@;
718	}	917	}
719		918
720	our $override;	919	our $override;
721	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	920	our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
722		921
723	sub override {	922	sub override {
724	$override = 1;	923	$override = 1;
725	@invoke_results = ();	924	@INVOKE_RESULTS = (@_);
726	}	925	}
727		926
728	sub do_invoke {	927	sub do_invoke {
729	my $event = shift;	928	my $event = shift;
730	my $callbacks = shift;	929	my $callbacks = shift;
731		930
732	@invoke_results = ();	931	@INVOKE_RESULTS = ();
733		932
734	local $override;	933	local $override;
735		934
736	for (@$callbacks) {	935	for (@$callbacks) {
737	eval { &{$_->[1]} };	936	eval { &{$_->[1]} };
…		…
754		953
755	Generate an object-specific event with the given arguments.	954	Generate an object-specific event with the given arguments.
756		955
757	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be	956	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
758	removed in future versions), and there is no public API to access override	957	removed in future versions), and there is no public API to access override
759	results (if you must, access C<@cf::invoke_results> directly).	958	results (if you must, access C<@cf::INVOKE_RESULTS> directly).
760		959
761	=back	960	=back
762		961
763	=cut	962	=cut
764		963
765	#############################################################################	964	#############################################################################
766	# object support	965	# object support
		966	#
		967
		968	sub _can_merge {
		969	my ($ob1, $ob2) = @_;
		970
		971	local $Storable::canonical = 1;
		972	my $fob1 = Storable::freeze $ob1;
		973	my $fob2 = Storable::freeze $ob2;
		974
		975	$fob1 eq $fob2
		976	}
767		977
768	sub reattach {	978	sub reattach {
769	# basically do the same as instantiate, without calling instantiate	979	# basically do the same as instantiate, without calling instantiate
770	my ($obj) = @_;	980	my ($obj) = @_;
771		981
…		…
816	);	1026	);
817		1027
818	sub object_freezer_save {	1028	sub object_freezer_save {
819	my ($filename, $rdata, $objs) = @_;	1029	my ($filename, $rdata, $objs) = @_;
820		1030
		1031	my $guard = cf::lock_acquire "io";
		1032
821	sync_job {	1033	sync_job {
822	if (length $$rdata) {	1034	if (length $$rdata) {
		1035	utf8::decode (my $decname = $filename);
823	warn sprintf "saving %s (%d,%d)\n",	1036	warn sprintf "saving %s (%d,%d)\n",
824	$filename, length $$rdata, scalar @$objs;	1037	$decname, length $$rdata, scalar @$objs;
825		1038
826	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {	1039	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
827	chmod SAVE_MODE, $fh;	1040	chmod SAVE_MODE, $fh;
828	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1041	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
829	aio_fsync $fh if $cf::USE_FSYNC;	1042	aio_fsync $fh if $cf::USE_FSYNC;
…		…
848	}	1061	}
849	} else {	1062	} else {
850	aio_unlink $filename;	1063	aio_unlink $filename;
851	aio_unlink "$filename.pst";	1064	aio_unlink "$filename.pst";
852	}	1065	}
853	}	1066	};
		1067
		1068	undef $guard;
854	}	1069	}
855		1070
856	sub object_freezer_as_string {	1071	sub object_freezer_as_string {
857	my ($rdata, $objs) = @_;	1072	my ($rdata, $objs) = @_;
858		1073
…		…
863		1078
864	sub object_thawer_load {	1079	sub object_thawer_load {
865	my ($filename) = @_;	1080	my ($filename) = @_;
866		1081
867	my ($data, $av);	1082	my ($data, $av);
		1083
		1084	my $guard = cf::lock_acquire "io";
868		1085
869	(aio_load $filename, $data) >= 0	1086	(aio_load $filename, $data) >= 0
870	or return;	1087	or return;
871		1088
872	unless (aio_stat "$filename.pst") {	1089	unless (aio_stat "$filename.pst") {
873	(aio_load "$filename.pst", $av) >= 0	1090	(aio_load "$filename.pst", $av) >= 0
874	or return;	1091	or return;
		1092
		1093	undef $guard;
875	$av = eval { (Storable::thaw $av)->{objs} };	1094	$av = eval { (Storable::thaw $av)->{objs} };
876	}	1095	}
877		1096
		1097	utf8::decode (my $decname = $filename);
878	warn sprintf "loading %s (%d)\n",	1098	warn sprintf "loading %s (%d,%d)\n",
879	$filename, length $data, scalar @{$av || []};#d#	1099	$decname, length $data, scalar @{$av || []};
		1100
880	return ($data, $av);	1101	($data, $av)
881	}	1102	}
		1103
		1104	=head2 COMMAND CALLBACKS
		1105
		1106	=over 4
		1107
		1108	=cut
882		1109
883	#############################################################################	1110	#############################################################################
884	# command handling &c	1111	# command handling &c
885		1112
886	=item cf::register_command $name => \&callback($ob,$args);	1113	=item cf::register_command $name => \&callback($ob,$args);
…		…
899	push @{ $COMMAND{$name} }, [$caller, $cb];	1126	push @{ $COMMAND{$name} }, [$caller, $cb];
900	}	1127	}
901		1128
902	=item cf::register_extcmd $name => \&callback($pl,$packet);	1129	=item cf::register_extcmd $name => \&callback($pl,$packet);
903		1130
904	Register a callbackf ro execution when the client sends an extcmd packet.	1131	Register a callback for execution when the client sends an (synchronous)
		1132	extcmd packet. Ext commands will be processed in the order they are
		1133	received by the server, like other user commands. The first argument is
		1134	the logged-in player. Ext commands can only be processed after a player
		1135	has logged in successfully.
905		1136
906	If the callback returns something, it is sent back as if reply was being	1137	If the callback returns something, it is sent back as if reply was being
907	called.	1138	called.
908		1139
		1140	=item cf::register_exticmd $name => \&callback($ns,$packet);
		1141
		1142	Register a callback for execution when the client sends an (asynchronous)
		1143	exticmd packet. Exti commands are processed by the server as soon as they
		1144	are received, i.e. out of order w.r.t. other commands. The first argument
		1145	is a client socket. Exti commands can be received anytime, even before
		1146	log-in.
		1147
		1148	If the callback returns something, it is sent back as if reply was being
		1149	called.
		1150
909	=cut	1151	=cut
910		1152
911	sub register_extcmd {	1153	sub register_extcmd {
912	my ($name, $cb) = @_;	1154	my ($name, $cb) = @_;
913		1155
914	$EXTCMD{$name} = $cb;	1156	$EXTCMD{$name} = $cb;
		1157	}
		1158
		1159	sub register_exticmd {
		1160	my ($name, $cb) = @_;
		1161
		1162	$EXTICMD{$name} = $cb;
915	}	1163	}
916		1164
917	cf::player->attach (	1165	cf::player->attach (
918	on_command => sub {	1166	on_command => sub {
919	my ($pl, $name, $params) = @_;	1167	my ($pl, $name, $params) = @_;
…		…
928	cf::override;	1176	cf::override;
929	},	1177	},
930	on_extcmd => sub {	1178	on_extcmd => sub {
931	my ($pl, $buf) = @_;	1179	my ($pl, $buf) = @_;
932		1180
933	my $msg = eval { from_json $buf };	1181	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
934		1182
935	if (ref $msg) {	1183	if (ref $msg) {
		1184	my ($type, $reply, @payload) =
		1185	"ARRAY" eq ref $msg
		1186	? @$msg
		1187	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		1188
		1189	my @reply;
		1190
936	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1191	if (my $cb = $EXTCMD{$type}) {
937	if (my %reply = $cb->($pl, $msg)) {	1192	@reply = $cb->($pl, @payload);
938	$pl->ext_reply ($msg->{msgid}, %reply);
939	}
940	}	1193	}
		1194
		1195	$pl->ext_reply ($reply, @reply)
		1196	if $reply;
		1197
941	} else {	1198	} else {
942	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1199	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
943	}	1200	}
944		1201
945	cf::override;	1202	cf::override;
946	},	1203	},
947	);	1204	);
948		1205
949	sub load_extension {
950	my ($path) = @_;
951
952	$path =~ /([^\/\\]+)\.ext$/ or die "$path";
953	my $base = $1;
954	my $pkg = $1;
955	$pkg =~ s/[^[:word:]]/_/g;
956	$pkg = "ext::$pkg";
957
958	warn "... loading '$path' into '$pkg'\n";
959
960	open my $fh, "<:utf8", $path
961	or die "$path: $!";
962
963	my $source =
964	"package $pkg; use strict; use utf8;\n"
965	. "#line 1 \"$path\"\n{\n"
966	. (do { local $/; <$fh> })
967	. "\n};\n1";
968
969	unless (eval $source) {
970	my $msg = $@ ? "$path: $@\n"
971	: "extension disabled.\n";
972	if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
973	warn $@;
974	warn "mandatory extension failed to load, exiting.\n";
975	exit 1;
976	}
977	die $@;
978	}
979
980	push @EXTS, $pkg;
981	}
982
983	sub load_extensions {	1206	sub load_extensions {
		1207	cf::sync_job {
		1208	my %todo;
		1209
984	for my $ext (<$LIBDIR/*.ext>) {	1210	for my $path (<$LIBDIR/*.ext>) {
985	next unless -r $ext;	1211	next unless -r $path;
986	eval {	1212
987	load_extension $ext;	1213	$path =~ /([^\/\\]+)\.ext$/ or die "$path";
		1214	my $base = $1;
		1215	my $pkg = $1;
		1216	$pkg =~ s/[^[:word:]]/_/g;
		1217	$pkg = "ext::$pkg";
		1218
		1219	open my $fh, "<:utf8", $path
		1220	or die "$path: $!";
		1221
		1222	my $source = do { local $/; <$fh> };
		1223
		1224	my %ext = (
		1225	path => $path,
		1226	base => $base,
		1227	pkg => $pkg,
		1228	);
		1229
		1230	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
		1231	if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
		1232
		1233	$ext{source} =
		1234	"package $pkg; use strict; use utf8;\n"
		1235	. "#line 1 \"$path\"\n{\n"
		1236	. $source
		1237	. "\n};\n1";
		1238
		1239	$todo{$base} = \%ext;
		1240	}
		1241
		1242	my %done;
		1243	while (%todo) {
		1244	my $progress;
		1245
		1246	while (my ($k, $v) = each %todo) {
		1247	for (split /,\s*/, $v->{meta}{depends}) {
		1248	goto skip
		1249	unless exists $done{$_};
		1250	}
		1251
		1252	warn "... loading '$k' into '$v->{pkg}'\n";
		1253
		1254	unless (eval $v->{source}) {
		1255	my $msg = $@ ? "$v->{path}: $@\n"
		1256	: "$v->{base}: extension inactive.\n";
		1257
		1258	if (exists $v->{meta}{mandatory}) {
		1259	warn $msg;
		1260	warn "mandatory extension failed to load, exiting.\n";
		1261	exit 1;
		1262	}
		1263
		1264	warn $msg;
		1265	}
		1266
		1267	$done{$k} = delete $todo{$k};
		1268	push @EXTS, $v->{pkg};
		1269	$progress = 1;
988	1	1270	}
989	} or warn "$ext not loaded: $@";	1271
		1272	skip:
		1273	die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
		1274	unless $progress;
		1275	}
990	}	1276	};
991	}	1277	}
992		1278
993	#############################################################################	1279	#############################################################################
994		1280
		1281	=back
		1282
995	=head2 CORE EXTENSIONS	1283	=head2 CORE EXTENSIONS
996		1284
997	Functions and methods that extend core crossfire objects.	1285	Functions and methods that extend core crossfire objects.
998		1286
999	=cut	1287	=cut
…		…
1003	use Coro::AIO;	1291	use Coro::AIO;
1004		1292
1005	=head3 cf::player	1293	=head3 cf::player
1006		1294
1007	=over 4	1295	=over 4
		1296
		1297	=item cf::player::num_playing
		1298
		1299	Returns the official number of playing players, as per the Crossfire metaserver rules.
		1300
		1301	=cut
		1302
		1303	sub num_playing {
		1304	scalar grep
		1305	$_->ob->map
		1306	&& !$_->hidden
		1307	&& !$_->ob->flag (cf::FLAG_WIZ),
		1308	cf::player::list
		1309	}
1008		1310
1009	=item cf::player::find $login	1311	=item cf::player::find $login
1010		1312
1011	Returns the given player object, loading it if necessary (might block).	1313	Returns the given player object, loading it if necessary (might block).
1012		1314
…		…
1048	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";	1350	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1049	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";	1351	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1050	aio_unlink +(playerdir $login) . "/$login.pl.pst";	1352	aio_unlink +(playerdir $login) . "/$login.pl.pst";
1051	aio_unlink +(playerdir $login) . "/$login.pl";	1353	aio_unlink +(playerdir $login) . "/$login.pl";
1052		1354
1053	my $pl = load_pl path $login	1355	my $f = new_from_file cf::object::thawer path $login
1054	or return;	1356	or return;
		1357
		1358	$f->next;
		1359	my $pl = cf::player::load_pl $f
		1360	or return;
		1361	local $cf::PLAYER_LOADING{$login} = $pl;
		1362	$f->resolve_delayed_derefs;
1055	$cf::PLAYER{$login} = $pl	1363	$cf::PLAYER{$login} = $pl
1056	}	1364	}
1057	}	1365	}
1058	}	1366	}
1059		1367
…		…
1069		1377
1070	aio_mkdir playerdir $pl, 0770;	1378	aio_mkdir playerdir $pl, 0770;
1071	$pl->{last_save} = $cf::RUNTIME;	1379	$pl->{last_save} = $cf::RUNTIME;
1072		1380
1073	$pl->save_pl ($path);	1381	$pl->save_pl ($path);
1074	Coro::cede;	1382	cf::cede_to_tick;
1075	}	1383	}
1076		1384
1077	sub new($) {	1385	sub new($) {
1078	my ($login) = @_;	1386	my ($login) = @_;
1079		1387
…		…
1083	$self->{deny_save} = 1;	1391	$self->{deny_save} = 1;
1084		1392
1085	$cf::PLAYER{$login} = $self;	1393	$cf::PLAYER{$login} = $self;
1086		1394
1087	$self	1395	$self
		1396	}
		1397
		1398	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1399
		1400	=cut
		1401
		1402	sub send_msg {
		1403	my $ns = shift->ns
		1404	or return;
		1405	$ns->send_msg (@_);
1088	}	1406	}
1089		1407
1090	=item $pl->quit_character	1408	=item $pl->quit_character
1091		1409
1092	Nukes the player without looking back. If logged in, the connection will	1410	Nukes the player without looking back. If logged in, the connection will
…		…
1147	or return [];	1465	or return [];
1148		1466
1149	my @logins;	1467	my @logins;
1150		1468
1151	for my $login (@$dirs) {	1469	for my $login (@$dirs) {
		1470	my $path = path $login;
		1471
		1472	# a .pst is a dead give-away for a valid player
		1473	unless (-e "$path.pst") {
1152	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;	1474	my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1153	aio_read $fh, 0, 512, my $buf, 0 or next;	1475	aio_read $fh, 0, 512, my $buf, 0 or next;
1154	$buf !~ /^password -------------$/m or next; # official not-valid tag	1476	$buf !~ /^password -------------$/m or next; # official not-valid tag
		1477	}
1155		1478
1156	utf8::decode $login;	1479	utf8::decode $login;
1157	push @logins, $login;	1480	push @logins, $login;
1158	}	1481	}
1159		1482
…		…
1186	}	1509	}
1187		1510
1188	\@paths	1511	\@paths
1189	}	1512	}
1190		1513
		1514	=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
		1515
		1516	Expand crossfire pod fragments into protocol xml.
		1517
		1518	=cut
		1519
		1520	sub expand_cfpod {
		1521	((my $self), (local $_)) = @_;
		1522
		1523	# escape & and <
		1524	s/&/&amp;/g;
		1525	s/(?<![BIUGHT])</&lt;/g;
		1526
		1527	# this is buggy, it needs to properly take care of nested <'s
		1528
		1529	1 while
		1530	# replace B<>, I<>, U<> etc.
		1531	s/B<([^\>]*)>/<b>$1<\/b>/
		1532	|| s/I<([^\>]*)>/<i>$1<\/i>/
		1533	|| s/U<([^\>]*)>/<u>$1<\/u>/
		1534	|| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
		1535	# replace G<male|female> tags
		1536	|| s{G<([^>|]*)\|([^>]*)>}{
		1537	$self->gender ? $2 : $1
		1538	}ge
		1539	# replace H<hint text>
		1540	|| s{H<([^\>]*)>}
		1541	{
		1542	("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
		1543	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
		1544	"")
		1545	[$self->{hintmode}]
		1546	}ge;
		1547
		1548	# create single paragraphs (very hackish)
		1549	s/(?<=\S)\n(?=\w)/ /g;
		1550
		1551	# compress some whitespace
		1552	s/\s+\n/\n/g; # ws line-ends
		1553	s/\n\n+/\n/g; # double lines
		1554	s/^\n+//; # beginning lines
		1555	s/\n+$//; # ending lines
		1556
		1557	$_
		1558	}
		1559
		1560	sub hintmode {
		1561	$_[0]{hintmode} = $_[1] if @_ > 1;
		1562	$_[0]{hintmode}
		1563	}
		1564
1191	=item $player->ext_reply ($msgid, %msg)	1565	=item $player->ext_reply ($msgid, @msg)
1192		1566
1193	Sends an ext reply to the player.	1567	Sends an ext reply to the player.
1194		1568
1195	=cut	1569	=cut
1196		1570
1197	sub ext_reply($$%) {	1571	sub ext_reply($$@) {
1198	my ($self, $id, %msg) = @_;	1572	my ($self, $id, @msg) = @_;
1199		1573
1200	$msg{msgid} = $id;	1574	$self->ns->ext_reply ($id, @msg)
1201
1202	$self->send ("ext " . cf::to_json \%msg);
1203	}	1575	}
1204		1576
1205	=item $player->ext_event ($type, %msg)	1577	=item $player->ext_msg ($type, @msg)
1206		1578
1207	Sends an ext event to the client.	1579	Sends an ext event to the client.
1208		1580
1209	=cut	1581	=cut
1210		1582
1211	sub ext_event($$%) {	1583	sub ext_msg($$@) {
1212	my ($self, $type, %msg) = @_;	1584	my ($self, $type, @msg) = @_;
1213		1585
1214	$self->ns->ext_event ($type, %msg);	1586	$self->ns->ext_msg ($type, @msg);
1215	}	1587	}
1216		1588
1217	=head3 cf::region	1589	=head3 cf::region
1218		1590
1219	=over 4	1591	=over 4
…		…
1222		1594
1223	package cf::region;	1595	package cf::region;
1224		1596
1225	=item cf::region::find_by_path $path	1597	=item cf::region::find_by_path $path
1226		1598
1227	Tries to decuce the probable region for a map knowing only its path.	1599	Tries to decuce the likely region for a map knowing only its path.
1228		1600
1229	=cut	1601	=cut
1230		1602
1231	sub find_by_path($) {	1603	sub find_by_path($) {
1232	my ($path) = @_;	1604	my ($path) = @_;
1233		1605
1234	my ($match, $specificity);	1606	my ($match, $specificity);
1235		1607
1236	for my $region (list) {	1608	for my $region (list) {
1237	if ($region->match && $path =~ $region->match) {	1609	if ($region->{match} && $path =~ $region->{match}) {
1238	($match, $specificity) = ($region, $region->specificity)	1610	($match, $specificity) = ($region, $region->specificity)
1239	if $region->specificity > $specificity;	1611	if $region->specificity > $specificity;
1240	}	1612	}
1241	}	1613	}
1242		1614
…		…
1306	my ($self, $merge) = @_;	1678	my ($self, $merge) = @_;
1307		1679
1308	# we have to keep some variables in memory intact	1680	# we have to keep some variables in memory intact
1309	local $self->{path};	1681	local $self->{path};
1310	local $self->{load_path};	1682	local $self->{load_path};
1311	local $self->{deny_save};
1312	local $self->{deny_reset};
1313		1683
1314	$self->SUPER::thawer_merge ($merge);	1684	$self->SUPER::thawer_merge ($merge);
1315	}	1685	}
1316		1686
1317	sub normalise {	1687	sub normalise {
…		…
1364	$self->init; # pass $1 etc.	1734	$self->init; # pass $1 etc.
1365	return $self;	1735	return $self;
1366	}	1736	}
1367	}	1737	}
1368		1738
1369	Carp::carp "unable to resolve path '$path' (base '$base').";	1739	Carp::cluck "unable to resolve path '$path' (base '$base').";
1370	()	1740	()
1371	}	1741	}
1372		1742
1373	sub init {	1743	sub init {
1374	my ($self) = @_;	1744	my ($self) = @_;
…		…
1417		1787
1418	$_->change_map_light ($change)	1788	$_->change_map_light ($change)
1419	for grep $_->outdoor, values %cf::MAP;	1789	for grep $_->outdoor, values %cf::MAP;
1420	}	1790	}
1421		1791
		1792	sub decay_objects {
		1793	my ($self) = @_;
		1794
		1795	return if $self->{deny_reset};
		1796
		1797	$self->do_decay_objects;
		1798	}
		1799
1422	sub unlink_save {	1800	sub unlink_save {
1423	my ($self) = @_;	1801	my ($self) = @_;
1424		1802
1425	utf8::encode (my $save = $self->save_path);	1803	utf8::encode (my $save = $self->save_path);
1426	IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;	1804	IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
…		…
1429		1807
1430	sub load_header_from($) {	1808	sub load_header_from($) {
1431	my ($self, $path) = @_;	1809	my ($self, $path) = @_;
1432		1810
1433	utf8::encode $path;	1811	utf8::encode $path;
1434	#aio_open $path, O_RDONLY, 0	1812	my $f = new_from_file cf::object::thawer $path
1435	# or return;
1436
1437	$self->_load_header ($path)
1438	or return;	1813	or return;
		1814
		1815	$self->_load_header ($f)
		1816	or return;
		1817
		1818	local $MAP_LOADING{$self->{path}} = $self;
		1819	$f->resolve_delayed_derefs;
1439		1820
1440	$self->{load_path} = $path;	1821	$self->{load_path} = $path;
1441		1822
1442	1	1823	1
1443	}	1824	}
…		…
1482	$self->load_header_orig	1863	$self->load_header_orig
1483	or return;	1864	or return;
1484	$self->prepare_orig;	1865	$self->prepare_orig;
1485	}	1866	}
1486		1867
		1868	$self->{deny_reset} = 1
		1869	if $self->no_reset;
		1870
1487	$self->default_region (cf::region::find_by_path $self->{path})	1871	$self->default_region (cf::region::find_by_path $self->{path})
1488	unless $self->default_region;	1872	unless $self->default_region;
1489		1873
1490	1	1874	1
1491	}	1875	}
…		…
1494	sub find {	1878	sub find {
1495	my ($path, $origin) = @_;	1879	my ($path, $origin) = @_;
1496		1880
1497	$path = normalise $path, $origin && $origin->path;	1881	$path = normalise $path, $origin && $origin->path;
1498		1882
		1883	cf::lock_wait "map_data:$path";#d#remove
1499	cf::lock_wait "map_find:$path";	1884	cf::lock_wait "map_find:$path";
1500		1885
1501	$cf::MAP{$path} || do {	1886	$cf::MAP{$path} || do {
1502	my $guard = cf::lock_acquire "map_find:$path";	1887	my $guard1 = cf::lock_acquire "map_find:$path";
		1888	my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
		1889
1503	my $map = new_from_path cf::map $path	1890	my $map = new_from_path cf::map $path
1504	or return;	1891	or return;
1505		1892
1506	$map->{last_save} = $cf::RUNTIME;	1893	$map->{last_save} = $cf::RUNTIME;
1507		1894
1508	$map->load_header	1895	$map->load_header
1509	or return;	1896	or return;
1510		1897
1511	if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?)	1898	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1512	# doing this can freeze the server in a sync job, obviously	1899	# doing this can freeze the server in a sync job, obviously
1513	#$cf::WAIT_FOR_TICK->wait;	1900	#$cf::WAIT_FOR_TICK->wait;
		1901	undef $guard1;
		1902	undef $guard2;
1514	$map->reset;	1903	$map->reset;
1515	undef $guard;
1516	return find $path;	1904	return find $path;
1517	}	1905	}
1518		1906
1519	$cf::MAP{$path} = $map	1907	$cf::MAP{$path} = $map
1520	}	1908	}
…		…
1529	local $self->{deny_reset} = 1; # loading can take a long time	1917	local $self->{deny_reset} = 1; # loading can take a long time
1530		1918
1531	my $path = $self->{path};	1919	my $path = $self->{path};
1532		1920
1533	{	1921	{
1534	my $guard = cf::lock_acquire "map_load:$path";	1922	my $guard = cf::lock_acquire "map_data:$path";
1535		1923
		1924	return unless $self->valid;
1536	return if $self->in_memory != cf::MAP_SWAPPED;	1925	return unless $self->in_memory == cf::MAP_SWAPPED;
1537		1926
1538	$self->in_memory (cf::MAP_LOADING);	1927	$self->in_memory (cf::MAP_LOADING);
1539		1928
1540	$self->alloc;	1929	$self->alloc;
1541		1930
1542	$self->pre_load;	1931	$self->pre_load;
1543	Coro::cede;	1932	cf::cede_to_tick;
1544		1933
		1934	my $f = new_from_file cf::object::thawer $self->{load_path};
		1935	$f->skip_block;
1545	$self->_load_objects ($self->{load_path}, 1)	1936	$self->_load_objects ($f)
1546	or return;	1937	or return;
1547		1938
1548	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	1939	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1549	if delete $self->{load_original};	1940	if delete $self->{load_original};
1550		1941
1551	if (my $uniq = $self->uniq_path) {	1942	if (my $uniq = $self->uniq_path) {
1552	utf8::encode $uniq;	1943	utf8::encode $uniq;
1553	if (aio_open $uniq, O_RDONLY, 0) {	1944	unless (aio_stat $uniq) {
		1945	if (my $f = new_from_file cf::object::thawer $uniq) {
1554	$self->clear_unique_items;	1946	$self->clear_unique_items;
1555	$self->_load_objects ($uniq, 0);	1947	$self->_load_objects ($f);
		1948	$f->resolve_delayed_derefs;
		1949	}
1556	}	1950	}
1557	}	1951	}
1558		1952
1559	Coro::cede;	1953	$f->resolve_delayed_derefs;
		1954
		1955	cf::cede_to_tick;
1560	# now do the right thing for maps	1956	# now do the right thing for maps
1561	$self->link_multipart_objects;	1957	$self->link_multipart_objects;
1562	$self->difficulty ($self->estimate_difficulty)	1958	$self->difficulty ($self->estimate_difficulty)
1563	unless $self->difficulty;	1959	unless $self->difficulty;
1564	Coro::cede;	1960	cf::cede_to_tick;
1565		1961
1566	unless ($self->{deny_activate}) {	1962	unless ($self->{deny_activate}) {
1567	$self->decay_objects;	1963	$self->decay_objects;
1568	$self->fix_auto_apply;	1964	$self->fix_auto_apply;
1569	$self->update_buttons;	1965	$self->update_buttons;
1570	Coro::cede;	1966	cf::cede_to_tick;
1571	$self->set_darkness_map;	1967	$self->set_darkness_map;
1572	Coro::cede;	1968	cf::cede_to_tick;
1573	$self->activate;	1969	$self->activate;
1574	}	1970	}
		1971
		1972	$self->{last_save} = $cf::RUNTIME;
		1973	$self->last_access ($cf::RUNTIME);
1575		1974
1576	$self->in_memory (cf::MAP_IN_MEMORY);	1975	$self->in_memory (cf::MAP_IN_MEMORY);
1577	}	1976	}
1578		1977
1579	$self->post_load;	1978	$self->post_load;
…		…
1583	my ($self, $ob) = @_;	1982	my ($self, $ob) = @_;
1584		1983
1585	return find "~" . $ob->name . "/" . $self->{path}	1984	return find "~" . $ob->name . "/" . $self->{path}
1586	if $self->per_player;	1985	if $self->per_player;
1587		1986
		1987	# return find "?party/" . $ob->name . "/" . $self->{path}
		1988	# if $self->per_party;
		1989
1588	$self	1990	$self
1589	}	1991	}
1590		1992
1591	# find and load all maps in the 3x3 area around a map	1993	# find and load all maps in the 3x3 area around a map
1592	sub load_diag {	1994	sub load_neighbours {
1593	my ($map) = @_;	1995	my ($map) = @_;
1594		1996
1595	my @diag; # diagonal neighbours	1997	my @neigh; # diagonal neighbours
1596		1998
1597	for (0 .. 3) {	1999	for (0 .. 3) {
1598	my $neigh = $map->tile_path ($_)	2000	my $neigh = $map->tile_path ($_)
1599	or next;	2001	or next;
1600	$neigh = find $neigh, $map	2002	$neigh = find $neigh, $map
1601	or next;	2003	or next;
1602	$neigh->load;	2004	$neigh->load;
1603		2005
		2006	push @neigh,
1604	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],	2007	[$neigh->tile_path (($_ + 3) % 4), $neigh],
1605	[$neigh->tile_path (($_ + 1) % 4), $neigh];	2008	[$neigh->tile_path (($_ + 1) % 4), $neigh];
1606	}	2009	}
1607		2010
1608	for (@diag) {	2011	for (grep defined $_->[0], @neigh) {
		2012	my ($path, $origin) = @$_;
1609	my $neigh = find @$_	2013	my $neigh = find $path, $origin
1610	or next;	2014	or next;
1611	$neigh->load;	2015	$neigh->load;
1612	}	2016	}
1613	}	2017	}
1614		2018
…		…
1619	}	2023	}
1620		2024
1621	sub do_load_sync {	2025	sub do_load_sync {
1622	my ($map) = @_;	2026	my ($map) = @_;
1623		2027
		2028	cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
		2029	if $Coro::current == $Coro::main;
		2030
1624	cf::sync_job { $map->load };	2031	cf::sync_job { $map->load };
1625	}	2032	}
1626		2033
1627	our %MAP_PREFETCH;	2034	our %MAP_PREFETCH;
1628	our $MAP_PREFETCHER = undef;	2035	our $MAP_PREFETCHER = undef;
1629		2036
1630	sub find_async {	2037	sub find_async {
1631	my ($path, $origin) = @_;	2038	my ($path, $origin, $load) = @_;
1632		2039
1633	$path = normalise $path, $origin && $origin->{path};	2040	$path = normalise $path, $origin && $origin->{path};
1634		2041
1635	if (my $map = $cf::MAP{$path}) {	2042	if (my $map = $cf::MAP{$path}) {
1636	return $map if $map->in_memory == cf::MAP_IN_MEMORY;	2043	return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1637	}	2044	}
1638		2045
1639	undef $MAP_PREFETCH{$path};	2046	$MAP_PREFETCH{$path} |= $load;
		2047
1640	$MAP_PREFETCHER ||= cf::async {	2048	$MAP_PREFETCHER ||= cf::async {
1641	while (%MAP_PREFETCH) {	2049	while (%MAP_PREFETCH) {
1642	for my $path (keys %MAP_PREFETCH) {	2050	while (my ($k, $v) = each %MAP_PREFETCH) {
1643	my $map = find $path	2051	if (my $map = find $k) {
1644	or next;
1645	$map->load;	2052	$map->load if $v;
		2053	}
1646		2054
1647	delete $MAP_PREFETCH{$path};	2055	delete $MAP_PREFETCH{$k};
1648	}	2056	}
1649	}	2057	}
1650	undef $MAP_PREFETCHER;	2058	undef $MAP_PREFETCHER;
1651	};	2059	};
1652	$MAP_PREFETCHER->prio (6);	2060	$MAP_PREFETCHER->prio (6);
…		…
1655	}	2063	}
1656		2064
1657	sub save {	2065	sub save {
1658	my ($self) = @_;	2066	my ($self) = @_;
1659		2067
1660	my $lock = cf::lock_acquire "map_data:" . $self->path;	2068	my $lock = cf::lock_acquire "map_data:$self->{path}";
1661		2069
1662	$self->{last_save} = $cf::RUNTIME;	2070	$self->{last_save} = $cf::RUNTIME;
1663		2071
1664	return unless $self->dirty;	2072	return unless $self->dirty;
1665		2073
…		…
1688	my ($self) = @_;	2096	my ($self) = @_;
1689		2097
1690	# save first because save cedes	2098	# save first because save cedes
1691	$self->save;	2099	$self->save;
1692		2100
1693	my $lock = cf::lock_acquire "map_data:" . $self->path;	2101	my $lock = cf::lock_acquire "map_data:$self->{path}";
1694		2102
1695	return if $self->players;	2103	return if $self->players;
1696	return if $self->in_memory != cf::MAP_IN_MEMORY;	2104	return if $self->in_memory != cf::MAP_IN_MEMORY;
1697	return if $self->{deny_save};	2105	return if $self->{deny_save};
1698		2106
		2107	$self->in_memory (cf::MAP_SWAPPED);
		2108
		2109	$self->deactivate;
		2110	$_->clear_links_to ($self) for values %cf::MAP;
1699	$self->clear;	2111	$self->clear;
1700	$self->in_memory (cf::MAP_SWAPPED);
1701	}	2112	}
1702		2113
1703	sub reset_at {	2114	sub reset_at {
1704	my ($self) = @_;	2115	my ($self) = @_;
1705		2116
1706	# TODO: safety, remove and allow resettable per-player maps	2117	# TODO: safety, remove and allow resettable per-player maps
1707	return 1e99 if $self->isa ("ext::map_per_player");#d#
1708	return 1e99 if $self->{deny_reset};	2118	return 1e99 if $self->{deny_reset};
1709		2119
1710	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;	2120	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1711	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;	2121	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1712		2122
…		…
1723	my ($self) = @_;	2133	my ($self) = @_;
1724		2134
1725	my $lock = cf::lock_acquire "map_data:$self->{path}";	2135	my $lock = cf::lock_acquire "map_data:$self->{path}";
1726		2136
1727	return if $self->players;	2137	return if $self->players;
1728	return if $self->isa ("ext::map_per_player");#d#
1729		2138
1730	warn "resetting map ", $self->path;#d#	2139	warn "resetting map ", $self->path;
1731		2140
1732	$self->in_memory (cf::MAP_SWAPPED);	2141	$self->in_memory (cf::MAP_SWAPPED);
1733		2142
1734	# need to save uniques path	2143	# need to save uniques path
1735	unless ($self->{deny_save}) {	2144	unless ($self->{deny_save}) {
…		…
1739	if $uniq;	2148	if $uniq;
1740	}	2149	}
1741		2150
1742	delete $cf::MAP{$self->path};	2151	delete $cf::MAP{$self->path};
1743		2152
		2153	$self->deactivate;
		2154	$_->clear_links_to ($self) for values %cf::MAP;
1744	$self->clear;	2155	$self->clear;
1745
1746	$_->clear_links_to ($self) for values %cf::MAP;
1747		2156
1748	$self->unlink_save;	2157	$self->unlink_save;
1749	$self->destroy;	2158	$self->destroy;
1750	}	2159	}
1751		2160
1752	my $nuke_counter = "aaaa";	2161	my $nuke_counter = "aaaa";
1753		2162
1754	sub nuke {	2163	sub nuke {
1755	my ($self) = @_;	2164	my ($self) = @_;
1756		2165
		2166	{
		2167	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2168
1757	delete $cf::MAP{$self->path};	2169	delete $cf::MAP{$self->path};
1758		2170
1759	$self->unlink_save;	2171	$self->unlink_save;
1760		2172
1761	bless $self, "cf::map";	2173	bless $self, "cf::map";
1762	delete $self->{deny_reset};	2174	delete $self->{deny_reset};
1763	$self->{deny_save} = 1;	2175	$self->{deny_save} = 1;
1764	$self->reset_timeout (1);	2176	$self->reset_timeout (1);
1765	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2177	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1766		2178
1767	$cf::MAP{$self->path} = $self;	2179	$cf::MAP{$self->path} = $self;
		2180	}
1768		2181
1769	$self->reset; # polite request, might not happen	2182	$self->reset; # polite request, might not happen
		2183	}
		2184
		2185	=item $maps = cf::map::tmp_maps
		2186
		2187	Returns an arrayref with all map paths of currently instantiated and saved
		2188	maps. May block.
		2189
		2190	=cut
		2191
		2192	sub tmp_maps() {
		2193	[
		2194	map {
		2195	utf8::decode $_;
		2196	/\.map$/
		2197	? normalise $_
		2198	: ()
		2199	} @{ aio_readdir $TMPDIR or [] }
		2200	]
		2201	}
		2202
		2203	=item $maps = cf::map::random_maps
		2204
		2205	Returns an arrayref with all map paths of currently instantiated and saved
		2206	random maps. May block.
		2207
		2208	=cut
		2209
		2210	sub random_maps() {
		2211	[
		2212	map {
		2213	utf8::decode $_;
		2214	/\.map$/
		2215	? normalise "?random/$_"
		2216	: ()
		2217	} @{ aio_readdir $RANDOMDIR or [] }
		2218	]
1770	}	2219	}
1771		2220
1772	=item cf::map::unique_maps	2221	=item cf::map::unique_maps
1773		2222
1774	Returns an arrayref of paths of all shared maps that have	2223	Returns an arrayref of paths of all shared maps that have
1775	instantiated unique items. May block.	2224	instantiated unique items. May block.
1776		2225
1777	=cut	2226	=cut
1778		2227
1779	sub unique_maps() {	2228	sub unique_maps() {
1780	my $files = aio_readdir $UNIQUEDIR	2229	[
1781	or return;	2230	map {
1782
1783	my @paths;
1784
1785	for (@$files) {
1786	utf8::decode $_;	2231	utf8::decode $_;
1787	next if /\.pst$/;	2232	/\.map$/
1788	next unless /^$PATH_SEP/o;	2233	? normalise $_
1789		2234	: ()
1790	push @paths, cf::map::normalise $_;	2235	} @{ aio_readdir $UNIQUEDIR or [] }
1791	}	2236	]
1792
1793	\@paths
1794	}	2237	}
1795		2238
1796	package cf;	2239	package cf;
1797		2240
1798	=back	2241	=back
…		…
1816	map { $_, inv_recursive_ $_->inv } @_	2259	map { $_, inv_recursive_ $_->inv } @_
1817	}	2260	}
1818		2261
1819	sub inv_recursive {	2262	sub inv_recursive {
1820	inv_recursive_ inv $_[0]	2263	inv_recursive_ inv $_[0]
		2264	}
		2265
		2266	=item $ref = $ob->ref
		2267
		2268	creates and returns a persistent reference to an objetc that can be stored as a string.
		2269
		2270	=item $ob = cf::object::deref ($refstring)
		2271
		2272	returns the objetc referenced by refstring. may return undef when it cnanot find the object,
		2273	even if the object actually exists. May block.
		2274
		2275	=cut
		2276
		2277	sub deref {
		2278	my ($ref) = @_;
		2279
		2280	# temporary compatibility#TODO#remove
		2281	$ref =~ s{^<}{player/<};
		2282
		2283	if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
		2284	my ($uuid, $name) = ($1, $2);
		2285	my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
		2286	or return;
		2287	$pl->ob->uuid eq $uuid
		2288	or return;
		2289
		2290	$pl->ob
		2291	} else {
		2292	warn "$ref: cannot resolve object reference\n";
		2293	undef
		2294	}
1821	}	2295	}
1822		2296
1823	package cf;	2297	package cf;
1824		2298
1825	=back	2299	=back
…		…
1844		2318
1845	$flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;	2319	$flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1846		2320
1847	if ($self->{record_replies}) {	2321	if ($self->{record_replies}) {
1848	push @{ $self->{record_replies} }, [$npc, $msg, $flags];	2322	push @{ $self->{record_replies} }, [$npc, $msg, $flags];
		2323
1849	} else {	2324	} else {
		2325	my $pl = $self->contr;
		2326
		2327	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
		2328	my $dialog = $pl->{npc_dialog};
		2329	$dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
		2330
		2331	} else {
1850	$msg = $npc->name . " says: $msg" if $npc;	2332	$msg = $npc->name . " says: $msg" if $npc;
1851	$self->message ($msg, $flags);	2333	$self->message ($msg, $flags);
		2334	}
1852	}	2335	}
		2336	}
		2337
		2338	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2339
		2340	=cut
		2341
		2342	sub cf::object::send_msg {
		2343	my $pl = shift->contr
		2344	or return;
		2345	$pl->send_msg (@_);
1853	}	2346	}
1854		2347
1855	=item $player_object->may ("access")	2348	=item $player_object->may ("access")
1856		2349
1857	Returns wether the given player is authorized to access resource "access"	2350	Returns wether the given player is authorized to access resource "access"
…		…
1904	$self->deactivate_recursive;	2397	$self->deactivate_recursive;
1905		2398
1906	return if UNIVERSAL::isa $self->map, "ext::map_link";	2399	return if UNIVERSAL::isa $self->map, "ext::map_link";
1907		2400
1908	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]	2401	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1909	if $self->map;	2402	if $self->map && $self->map->{path} ne "{link}";
1910		2403
1911	$self->enter_map ($LINK_MAP || link_map, 10, 10);	2404	$self->enter_map ($LINK_MAP || link_map, 10, 10);
1912	}	2405	}
1913		2406
1914	sub cf::object::player::leave_link {	2407	sub cf::object::player::leave_link {
1915	my ($self, $map, $x, $y) = @_;	2408	my ($self, $map, $x, $y) = @_;
		2409
		2410	return unless $self->contr->active;
1916		2411
1917	my $link_pos = delete $self->{_link_pos};	2412	my $link_pos = delete $self->{_link_pos};
1918		2413
1919	unless ($map) {	2414	unless ($map) {
1920	# restore original map position	2415	# restore original map position
…		…
1934	# use -1 or undef as default coordinates, not 0, 0	2429	# use -1 or undef as default coordinates, not 0, 0
1935	($x, $y) = ($map->enter_x, $map->enter_y)	2430	($x, $y) = ($map->enter_x, $map->enter_y)
1936	if $x <=0 && $y <= 0;	2431	if $x <=0 && $y <= 0;
1937		2432
1938	$map->load;	2433	$map->load;
1939	$map->load_diag;	2434	$map->load_neighbours;
1940		2435
1941	return unless $self->contr->active;	2436	return unless $self->contr->active;
1942	$self->activate_recursive;	2437	$self->activate_recursive;
1943		2438
1944	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2439	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1945	$self->enter_map ($map, $x, $y);	2440	$self->enter_map ($map, $x, $y);
1946	}	2441	}
1947		2442
1948	cf::player->attach (	2443	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1949	on_logout => sub {
1950	my ($pl) = @_;
1951		2444
1952	# abort map switching before logout	2445	Moves the player to the given map-path and coordinates by first freezing
1953	if ($pl->ob->{_link_pos}) {	2446	her, loading and preparing them map, calling the provided $check callback
1954	cf::sync_job {	2447	that has to return the map if sucecssful, and then unfreezes the player on
1955	$pl->ob->leave_link	2448	the new (success) or old (failed) map position. In either case, $done will
1956	};	2449	be called at the end of this process.
1957	}
1958	},
1959	on_login => sub {
1960	my ($pl) = @_;
1961		2450
1962	# try to abort aborted map switching on player login :)
1963	# should happen only on crashes
1964	if ($pl->ob->{_link_pos}) {
1965	$pl->ob->enter_link;
1966	(async {
1967	$pl->ob->reply (undef,
1968	"There was an internal problem at your last logout, "
1969	. "the server will try to bring you to your intended destination in a second.",
1970	cf::NDI_RED);
1971	# we need this sleep as the login has a concurrent enter_exit running
1972	# and this sleep increases chances of the player not ending up in scorn
1973	Coro::Timer::sleep 1;
1974	$pl->ob->leave_link;
1975	})->prio (2);
1976	}
1977	},
1978	);
1979
1980	=item $player_object->goto ($path, $x, $y)
1981
1982	=cut	2451	=cut
		2452
		2453	our $GOTOGEN;
1983		2454
1984	sub cf::object::player::goto {	2455	sub cf::object::player::goto {
1985	my ($self, $path, $x, $y) = @_;	2456	my ($self, $path, $x, $y, $check, $done) = @_;
		2457
		2458	# do generation counting so two concurrent goto's will be executed in-order
		2459	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1986		2460
1987	$self->enter_link;	2461	$self->enter_link;
1988		2462
1989	(async {	2463	(async {
		2464	# *tag paths override both path and x|y
		2465	if ($path =~ /^\*(.*)$/) {
		2466	if (my @obs = grep $_->map, ext::map_tags::find $1) {
		2467	my $ob = $obs[rand @obs];
		2468
		2469	# see if we actually can go there
		2470	if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
		2471	$ob = $obs[rand @obs];
		2472	} else {
		2473	$self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
		2474	}
		2475	# else put us there anyways for now #d#
		2476
		2477	($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
		2478	} else {
		2479	($path, $x, $y) = (undef, undef, undef);
		2480	}
		2481	}
		2482
1990	my $map = eval {	2483	my $map = eval {
1991	my $map = cf::map::find $path;	2484	my $map = defined $path ? cf::map::find $path : undef;
		2485
		2486	if ($map) {
1992	$map = $map->customise_for ($self) if $map;	2487	$map = $map->customise_for ($self);
		2488	$map = $check->($map) if $check && $map;
		2489	} else {
		2490	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
		2491	}
		2492
1993	$map	2493	$map
		2494	};
		2495
		2496	if ($@) {
		2497	$self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
		2498	LOG llevError | logBacktrace, Carp::longmess $@;
1994	} or	2499	}
1995	$self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1996		2500
		2501	if ($gen == $self->{_goto_generation}) {
		2502	delete $self->{_goto_generation};
1997	$self->leave_link ($map, $x, $y);	2503	$self->leave_link ($map, $x, $y);
		2504	}
		2505
		2506	$done->() if $done;
1998	})->prio (1);	2507	})->prio (1);
1999	}	2508	}
2000		2509
2001	=item $player_object->enter_exit ($exit_object)	2510	=item $player_object->enter_exit ($exit_object)
2002		2511
…		…
2071	my $hp = $exit->stats->hp;	2580	my $hp = $exit->stats->hp;
2072	my $sp = $exit->stats->sp;	2581	my $sp = $exit->stats->sp;
2073		2582
2074	$self->enter_link;	2583	$self->enter_link;
2075		2584
		2585	# if exit is damned, update players death & WoR home-position
		2586	$self->contr->savebed ($slaying, $hp, $sp)
		2587	if $exit->flag (FLAG_DAMNED);
		2588
2076	(async {	2589	(async {
2077	$self->deactivate_recursive; # just to be sure	2590	$self->deactivate_recursive; # just to be sure
2078	unless (eval {	2591	unless (eval {
2079	$self->goto ($slaying, $hp, $sp);	2592	$self->goto ($slaying, $hp, $sp);
2080		2593
…		…
2107		2620
2108	utf8::encode $text;	2621	utf8::encode $text;
2109	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);	2622	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2110	}	2623	}
2111		2624
		2625	=item $client->send_msg ($channel, $msg, $color, [extra...])
		2626
		2627	Send a drawinfo or msg packet to the client, formatting the msg for the
		2628	client if neccessary. C<$type> should be a string identifying the type of
		2629	the message, with C<log> being the default. If C<$color> is negative, suppress
		2630	the message unless the client supports the msg packet.
		2631
		2632	=cut
		2633
		2634	our %CHANNEL = (
		2635	"c/identify" => {
		2636	id => "identify",
		2637	title => "Identify",
		2638	reply => undef,
		2639	tooltip => "Items recently identified",
		2640	},
		2641	"c/examine" => {
		2642	id => "examine",
		2643	title => "Examine",
		2644	reply => undef,
		2645	tooltip => "Signs and other items you examined",
		2646	},
		2647	);
		2648
		2649	sub cf::client::send_msg {
		2650	my ($self, $channel, $msg, $color, @extra) = @_;
		2651
		2652	$msg = $self->pl->expand_cfpod ($msg);
		2653
		2654	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2655
		2656	# check predefined channels, for the benefit of C
		2657	$channel = $CHANNEL{$channel} if $CHANNEL{$channel};
		2658
		2659	if (ref $channel) {
		2660	# send meta info to client, if not yet sent
		2661	unless (exists $self->{channel}{$channel->{id}}) {
		2662	$self->{channel}{$channel->{id}} = $channel;
		2663	$self->ext_msg (channel_info => $channel)
		2664	if $self->can_msg;
		2665	}
		2666
		2667	$channel = $channel->{id};
		2668	}
		2669
		2670	return unless @extra || length $msg;
		2671
		2672	if ($self->can_msg) {
		2673	# default colour, mask it out
		2674	$color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
		2675	if $color & cf::NDI_DEF;
		2676
		2677	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2678	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
		2679	} else {
		2680	if ($color >= 0) {
		2681	# replace some tags by gcfclient-compatible ones
		2682	for ($msg) {
		2683	1 while
		2684	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2685	|| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2686	|| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2687	|| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2688	|| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2689	}
		2690
		2691	$color &= cf::NDI_COLOR_MASK;
		2692
		2693	utf8::encode $msg;
		2694
		2695	if (0 && $msg =~ /\[/) {
		2696	# COMMAND/INFO
		2697	$self->send_packet ("drawextinfo $color 10 8 $msg")
		2698	} else {
		2699	$msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
		2700	$self->send_packet ("drawinfo $color $msg")
		2701	}
		2702	}
		2703	}
		2704	}
		2705
2112	=item $client->ext_event ($type, %msg)	2706	=item $client->ext_msg ($type, @msg)
2113		2707
2114	Sends an exti event to the client.	2708	Sends an ext event to the client.
2115		2709
2116	=cut	2710	=cut
2117		2711
2118	sub cf::client::ext_event($$%) {	2712	sub cf::client::ext_msg($$@) {
2119	my ($self, $type, %msg) = @_;	2713	my ($self, $type, @msg) = @_;
2120		2714
		2715	if ($self->extcmd == 2) {
		2716	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2717	} elsif ($self->extcmd == 1) { # TODO: remove
2121	$msg{msgtype} = "event_$type";	2718	push @msg, msgtype => "event_$type";
2122	$self->send_packet ("ext " . cf::to_json \%msg);	2719	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2720	}
		2721	}
		2722
		2723	=item $client->ext_reply ($msgid, @msg)
		2724
		2725	Sends an ext reply to the client.
		2726
		2727	=cut
		2728
		2729	sub cf::client::ext_reply($$@) {
		2730	my ($self, $id, @msg) = @_;
		2731
		2732	if ($self->extcmd == 2) {
		2733	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
		2734	} elsif ($self->extcmd == 1) {
		2735	#TODO: version 1, remove
		2736	unshift @msg, msgtype => "reply", msgid => $id;
		2737	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2738	}
2123	}	2739	}
2124		2740
2125	=item $success = $client->query ($flags, "text", \&cb)	2741	=item $success = $client->query ($flags, "text", \&cb)
2126		2742
2127	Queues a query to the client, calling the given callback with	2743	Queues a query to the client, calling the given callback with
2128	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,	2744	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2129	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.	2745	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2130		2746
2131	Queries can fail, so check the return code. Or don't, as queries will become	2747	Queries can fail, so check the return code. Or don't, as queries will
2132	reliable at some point in the future.	2748	become reliable at some point in the future.
2133		2749
2134	=cut	2750	=cut
2135		2751
2136	sub cf::client::query {	2752	sub cf::client::query {
2137	my ($self, $flags, $text, $cb) = @_;	2753	my ($self, $flags, $text, $cb) = @_;
…		…
2145	utf8::encode $text;	2761	utf8::encode $text;
2146	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];	2762	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2147		2763
2148	$self->send_packet ($self->{query_queue}[0][0])	2764	$self->send_packet ($self->{query_queue}[0][0])
2149	if @{ $self->{query_queue} } == 1;	2765	if @{ $self->{query_queue} } == 1;
		2766
		2767	1
2150	}	2768	}
2151		2769
2152	cf::client->attach (	2770	cf::client->attach (
		2771	on_connect => sub {
		2772	my ($ns) = @_;
		2773
		2774	$ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
		2775	},
2153	on_reply => sub {	2776	on_reply => sub {
2154	my ($ns, $msg) = @_;	2777	my ($ns, $msg) = @_;
2155		2778
2156	# this weird shuffling is so that direct followup queries	2779	# this weird shuffling is so that direct followup queries
2157	# get handled first	2780	# get handled first
…		…
2169	} else {	2792	} else {
2170	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;	2793	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2171	}	2794	}
2172	}	2795	}
2173	},	2796	},
		2797	on_exticmd => sub {
		2798	my ($ns, $buf) = @_;
		2799
		2800	my $msg = eval { $ns->{json_coder}->decode ($buf) };
		2801
		2802	if (ref $msg) {
		2803	my ($type, $reply, @payload) =
		2804	"ARRAY" eq ref $msg
		2805	? @$msg
		2806	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2807
		2808	my @reply;
		2809
		2810	if (my $cb = $EXTICMD{$type}) {
		2811	@reply = $cb->($ns, @payload);
		2812	}
		2813
		2814	$ns->ext_reply ($reply, @reply)
		2815	if $reply;
		2816
		2817	} else {
		2818	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
		2819	}
		2820
		2821	cf::override;
		2822	},
2174	);	2823	);
2175		2824
2176	=item $client->async (\&cb)	2825	=item $client->async (\&cb)
2177		2826
2178	Create a new coroutine, running the specified callback. The coroutine will	2827	Create a new coroutine, running the specified callback. The coroutine will
…		…
2219	our $safe = new Safe "safe";	2868	our $safe = new Safe "safe";
2220	our $safe_hole = new Safe::Hole;	2869	our $safe_hole = new Safe::Hole;
2221		2870
2222	$SIG{FPE} = 'IGNORE';	2871	$SIG{FPE} = 'IGNORE';
2223		2872
2224	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2873	$safe->permit_only (Opcode::opset qw(
		2874	:base_core :base_mem :base_orig :base_math
		2875	grepstart grepwhile mapstart mapwhile
		2876	sort time
		2877	));
2225		2878
2226	# here we export the classes and methods available to script code	2879	# here we export the classes and methods available to script code
2227		2880
2228	=pod	2881	=pod
2229		2882
2230	The following functions and methods are available within a safe environment:	2883	The following functions and methods are available within a safe environment:
2231		2884
2232	cf::object contr pay_amount pay_player map	2885	cf::object
		2886	contr pay_amount pay_player map x y force_find force_add
		2887	insert remove name archname title slaying race decrease_ob_nr
		2888
2233	cf::object::player player	2889	cf::object::player
2234	cf::player peaceful	2890	player
2235	cf::map trigger	2891
		2892	cf::player
		2893	peaceful
		2894
		2895	cf::map
		2896	trigger
2236		2897
2237	=cut	2898	=cut
2238		2899
2239	for (	2900	for (
2240	["cf::object" => qw(contr pay_amount pay_player map)],	2901	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2902	insert remove inv name archname title slaying race
		2903	decrease_ob_nr)],
2241	["cf::object::player" => qw(player)],	2904	["cf::object::player" => qw(player)],
2242	["cf::player" => qw(peaceful)],	2905	["cf::player" => qw(peaceful)],
2243	["cf::map" => qw(trigger)],	2906	["cf::map" => qw(trigger)],
2244	) {	2907	) {
2245	no strict 'refs';	2908	no strict 'refs';
…		…
2316	=back	2979	=back
2317		2980
2318	=cut	2981	=cut
2319		2982
2320	#############################################################################	2983	#############################################################################
2321
2322	=head2 EXTENSION DATABASE SUPPORT
2323
2324	Crossfire maintains a very simple database for extension use. It can
2325	currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2326	convert to/from binary).
2327
2328	The parameter C<$family> should best start with the name of the extension
2329	using it, it should be unique.
2330
2331	=over 4
2332
2333	=item $value = cf::db_get $family => $key
2334
2335	Returns a single value from the database.
2336
2337	=item cf::db_put $family => $key => $value
2338
2339	Stores the given C<$value> in the family.
2340
2341	=cut
2342
2343	our $DB;
2344
2345	sub db_init {
2346	unless ($DB) {
2347	$DB = BDB::db_create $DB_ENV;
2348
2349	cf::sync_job {
2350	eval {
2351	$DB->set_flags (BDB::CHKSUM);
2352
2353	BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2354	BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2355	cf::cleanup "db_open(db): $!" if $!;
2356	};
2357	cf::cleanup "db_open(db): $@" if $@;
2358	};
2359	}
2360	}
2361
2362	sub db_get($$) {
2363	my $key = "$_[0]/$_[1]";
2364
2365	cf::sync_job {
2366	BDB::db_get $DB, undef, $key, my $data;
2367
2368	$! ? ()
2369	: $data
2370	}
2371	}
2372
2373	sub db_put($$$) {
2374	BDB::dbreq_pri 4;
2375	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2376	}
2377
2378	=item cf::cache $id => [$paths...], $processversion => $process
2379
2380	Generic caching function that returns the value of the resource $id,
2381	caching and regenerating as required.
2382
2383	This function can block.
2384
2385	=cut
2386
2387	sub cache {
2388	my ($id, $src, $processversion, $process) = @_;
2389
2390	my $meta =
2391	join "\x00",
2392	$processversion,
2393	map {
2394	aio_stat $_
2395	and Carp::croak "$_: $!";
2396
2397	($_, (stat _)[7,9])
2398	} @$src;
2399
2400	my $dbmeta = db_get cache => "$id/meta";
2401	if ($dbmeta ne $meta) {
2402	# changed, we may need to process
2403
2404	my @data;
2405	my $md5;
2406
2407	for (0 .. $#$src) {
2408	0 <= aio_load $src->[$_], $data[$_]
2409	or Carp::croak "$src->[$_]: $!";
2410	}
2411
2412	# if processing is expensive, check
2413	# checksum first
2414	if (1) {
2415	$md5 =
2416	join "\x00",
2417	$processversion,
2418	map {
2419	Coro::cede;
2420	($src->[$_], Digest::MD5::md5_hex $data[$_])
2421	} 0.. $#$src;
2422
2423
2424	my $dbmd5 = db_get cache => "$id/md5";
2425	if ($dbmd5 eq $md5) {
2426	db_put cache => "$id/meta", $meta;
2427
2428	return db_get cache => "$id/data";
2429	}
2430	}
2431
2432	my $t1 = Time::HiRes::time;
2433	my $data = $process->(\@data);
2434	my $t2 = Time::HiRes::time;
2435
2436	warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2437
2438	db_put cache => "$id/data", $data;
2439	db_put cache => "$id/md5" , $md5;
2440	db_put cache => "$id/meta", $meta;
2441
2442	return $data;
2443	}
2444
2445	db_get cache => "$id/data"
2446	}
2447
2448	=item fork_call { }, $args
2449
2450	Executes the given code block with the given arguments in a seperate
2451	process, returning the results. Everything must be serialisable with
2452	Coro::Storable. May, of course, block. Note that the executed sub may
2453	never block itself or use any form of Event handling.
2454
2455	=cut
2456
2457	sub fork_call(&@) {
2458	my ($cb, @args) = @_;
2459
2460	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2461	# or die "socketpair: $!";
2462	pipe my $fh1, my $fh2
2463	or die "pipe: $!";
2464
2465	if (my $pid = fork) {
2466	close $fh2;
2467
2468	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2469	$res = Coro::Storable::thaw $res;
2470
2471	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2472
2473	die $$res unless "ARRAY" eq ref $res;
2474
2475	return wantarray ? @$res : $res->[-1];
2476	} else {
2477	reset_signals;
2478	local $SIG{__WARN__};
2479	local $SIG{__DIE__};
2480	eval {
2481	close $fh1;
2482
2483	my @res = eval { $cb->(@args) };
2484	syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2485	};
2486
2487	warn $@ if $@;
2488	_exit 0;
2489	}
2490	}
2491
2492
2493
2494	#############################################################################
2495	# the server's init and main functions	2984	# the server's init and main functions
2496		2985
2497	sub load_facedata($) {	2986	sub load_facedata($) {
2498	my ($path) = @_;	2987	my ($path) = @_;
		2988
		2989	# HACK to clear player env face cache, we need some signal framework
		2990	# for this (global event?)
		2991	%ext::player_env::MUSIC_FACE_CACHE = ();
		2992
		2993	my $enc = JSON::XS->new->utf8->canonical->relaxed;
2499		2994
2500	warn "loading facedata from $path\n";	2995	warn "loading facedata from $path\n";
2501		2996
2502	my $facedata;	2997	my $facedata;
2503	0 < aio_load $path, $facedata	2998	0 < aio_load $path, $facedata
…		…
2506	$facedata = Coro::Storable::thaw $facedata;	3001	$facedata = Coro::Storable::thaw $facedata;
2507		3002
2508	$facedata->{version} == 2	3003	$facedata->{version} == 2
2509	or cf::cleanup "$path: version mismatch, cannot proceed.";	3004	or cf::cleanup "$path: version mismatch, cannot proceed.";
2510		3005
		3006	# patch in the exptable
		3007	$facedata->{resource}{"res/exp_table"} = {
		3008	type => FT_RSRC,
		3009	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
		3010	};
		3011	cf::cede_to_tick;
		3012
2511	{	3013	{
2512	my $faces = $facedata->{faceinfo};	3014	my $faces = $facedata->{faceinfo};
2513		3015
2514	while (my ($face, $info) = each %$faces) {	3016	while (my ($face, $info) = each %$faces) {
2515	my $idx = (cf::face::find $face) || cf::face::alloc $face;	3017	my $idx = (cf::face::find $face) || cf::face::alloc $face;
2516	cf::face::set $idx, $info->{visibility}, $info->{magicmap};	3018	cf::face::set_visibility $idx, $info->{visibility};
		3019	cf::face::set_magicmap $idx, $info->{magicmap};
2517	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	3020	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2518	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	3021	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2519	Coro::cede;	3022
		3023	cf::cede_to_tick;
2520	}	3024	}
2521		3025
2522	while (my ($face, $info) = each %$faces) {	3026	while (my ($face, $info) = each %$faces) {
2523	next unless $info->{smooth};	3027	next unless $info->{smooth};
2524	my $idx = cf::face::find $face	3028	my $idx = cf::face::find $face
2525	or next;	3029	or next;
2526	if (my $smooth = cf::face::find $info->{smooth}) {	3030	if (my $smooth = cf::face::find $info->{smooth}) {
		3031	cf::face::set_smooth $idx, $smooth;
2527	cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};	3032	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2528	} else {	3033	} else {
2529	warn "smooth face '$info->{smooth}' not found for face '$face'";	3034	warn "smooth face '$info->{smooth}' not found for face '$face'";
2530	}	3035	}
2531	Coro::cede;	3036
		3037	cf::cede_to_tick;
2532	}	3038	}
2533	}	3039	}
2534		3040
2535	{	3041	{
2536	my $anims = $facedata->{animinfo};	3042	my $anims = $facedata->{animinfo};
2537		3043
2538	while (my ($anim, $info) = each %$anims) {	3044	while (my ($anim, $info) = each %$anims) {
2539	cf::anim::set $anim, $info->{frames}, $info->{facings};	3045	cf::anim::set $anim, $info->{frames}, $info->{facings};
2540	Coro::cede;	3046	cf::cede_to_tick;
2541	}	3047	}
2542		3048
2543	cf::anim::invalidate_all; # d'oh	3049	cf::anim::invalidate_all; # d'oh
2544	}	3050	}
2545		3051
		3052	{
		3053	# TODO: for gcfclient pleasure, we should give resources
		3054	# that gcfclient doesn't grok a >10000 face index.
		3055	my $res = $facedata->{resource};
		3056
		3057	my $soundconf = delete $res->{"res/sound.conf"};
		3058
		3059	while (my ($name, $info) = each %$res) {
		3060	my $idx = (cf::face::find $name) || cf::face::alloc $name;
		3061	my $data;
		3062
		3063	if ($info->{type} & 1) {
		3064	# prepend meta info
		3065
		3066	my $meta = $enc->encode ({
		3067	name => $name,
		3068	%{ $info->{meta} || {} },
		3069	});
		3070
		3071	$data = pack "(w/a*)*", $meta, $info->{data};
		3072	} else {
		3073	$data = $info->{data};
		3074	}
		3075
		3076	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
		3077	cf::face::set_type $idx, $info->{type};
		3078
		3079	cf::cede_to_tick;
		3080	}
		3081
		3082	if ($soundconf) {
		3083	$soundconf = $enc->decode (delete $soundconf->{data});
		3084
		3085	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3086	my $sound = $soundconf->{compat}[$_]
		3087	or next;
		3088
		3089	my $face = cf::face::find "sound/$sound->[1]";
		3090	cf::sound::set $sound->[0] => $face;
		3091	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3092	}
		3093
		3094	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3095	my $face = cf::face::find "sound/$v";
		3096	cf::sound::set $k => $face;
		3097	}
		3098	}
		3099	}
		3100
2546	1	3101	1
2547	}	3102	}
2548		3103
		3104	register_exticmd fx_want => sub {
		3105	my ($ns, $want) = @_;
		3106
		3107	while (my ($k, $v) = each %$want) {
		3108	$ns->fx_want ($k, $v);
		3109	}
		3110	};
		3111
2549	sub reload_regions {	3112	sub reload_regions {
		3113	# HACK to clear player env face cache, we need some signal framework
		3114	# for this (global event?)
		3115	%ext::player_env::MUSIC_FACE_CACHE = ();
		3116
2550	load_resource_file "$MAPDIR/regions"	3117	load_resource_file "$MAPDIR/regions"
2551	or die "unable to load regions file\n";	3118	or die "unable to load regions file\n";
		3119
		3120	for (cf::region::list) {
		3121	$_->{match} = qr/$_->{match}/
		3122	if exists $_->{match};
		3123	}
2552	}	3124	}
2553		3125
2554	sub reload_facedata {	3126	sub reload_facedata {
2555	load_facedata "$DATADIR/facedata"	3127	load_facedata "$DATADIR/facedata"
2556	or die "unable to load facedata\n";	3128	or die "unable to load facedata\n";
2557	}	3129	}
2558		3130
2559	sub reload_archetypes {	3131	sub reload_archetypes {
2560	load_resource_file "$DATADIR/archetypes"	3132	load_resource_file "$DATADIR/archetypes"
2561	or die "unable to load archetypes\n";	3133	or die "unable to load archetypes\n";
		3134	#d# NEED to laod twice to resolve forward references
		3135	# this really needs to be done in an extra post-pass
		3136	# (which needs to be synchronous, so solve it differently)
		3137	load_resource_file "$DATADIR/archetypes"
		3138	or die "unable to load archetypes\n";
2562	}	3139	}
2563		3140
2564	sub reload_treasures {	3141	sub reload_treasures {
2565	load_resource_file "$DATADIR/treasures"	3142	load_resource_file "$DATADIR/treasures"
2566	or die "unable to load treasurelists\n";	3143	or die "unable to load treasurelists\n";
…		…
2569	sub reload_resources {	3146	sub reload_resources {
2570	warn "reloading resource files...\n";	3147	warn "reloading resource files...\n";
2571		3148
2572	reload_regions;	3149	reload_regions;
2573	reload_facedata;	3150	reload_facedata;
		3151	#reload_archetypes;#d#
2574	reload_archetypes;	3152	reload_archetypes;
2575	reload_treasures;	3153	reload_treasures;
2576		3154
2577	warn "finished reloading resource files\n";	3155	warn "finished reloading resource files\n";
2578	}	3156	}
2579		3157
2580	sub init {	3158	sub init {
2581	reload_resources;	3159	reload_resources;
2582	}	3160	}
2583		3161
2584	sub cfg_load {	3162	sub reload_config {
2585	open my $fh, "<:utf8", "$CONFDIR/config"	3163	open my $fh, "<:utf8", "$CONFDIR/config"
2586	or return;	3164	or return;
2587		3165
2588	local $/;	3166	local $/;
2589	*CFG = YAML::Syck::Load <$fh>;	3167	*CFG = YAML::Syck::Load <$fh>;
…		…
2609	(async {	3187	(async {
2610	Event::one_event;	3188	Event::one_event;
2611	})->prio (Coro::PRIO_MAX);	3189	})->prio (Coro::PRIO_MAX);
2612	};	3190	};
2613		3191
2614	cfg_load;	3192	reload_config;
2615	db_init;	3193	db_init;
2616	load_extensions;	3194	load_extensions;
2617		3195
2618	$TICK_WATCHER->start;	3196	$TICK_WATCHER->start;
2619	Event::loop;	3197	Event::loop;
…		…
2635	},	3213	},
2636	);	3214	);
2637	}	3215	}
2638	}	3216	}
2639		3217
		3218	sub write_runtime {
		3219	my $runtime = "$LOCALDIR/runtime";
		3220
		3221	# first touch the runtime file to show we are still running:
		3222	# the fsync below can take a very very long time.
		3223
		3224	IO::AIO::aio_utime $runtime, undef, undef;
		3225
		3226	my $guard = cf::lock_acquire "write_runtime";
		3227
		3228	my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
		3229	or return;
		3230
		3231	my $value = $cf::RUNTIME + 90 + 10;
		3232	# 10 is the runtime save interval, for a monotonic clock
		3233	# 60 allows for the watchdog to kill the server.
		3234
		3235	(aio_write $fh, 0, (length $value), $value, 0) <= 0
		3236	and return;
		3237
		3238	# always fsync - this file is important
		3239	aio_fsync $fh
		3240	and return;
		3241
		3242	# touch it again to show we are up-to-date
		3243	aio_utime $fh, undef, undef;
		3244
		3245	close $fh
		3246	or return;
		3247
		3248	aio_rename "$runtime~", $runtime
		3249	and return;
		3250
		3251	warn "runtime file written.\n";
		3252
		3253	1
		3254	}
		3255
2640	sub emergency_save() {	3256	sub emergency_save() {
2641	my $freeze_guard = cf::freeze_mainloop;	3257	my $freeze_guard = cf::freeze_mainloop;
2642		3258
2643	warn "enter emergency perl save\n";	3259	warn "enter emergency perl save\n";
2644		3260
…		…
2719	%EXT_CORO = ();	3335	%EXT_CORO = ();
2720		3336
2721	warn "removing commands";	3337	warn "removing commands";
2722	%COMMAND = ();	3338	%COMMAND = ();
2723		3339
2724	warn "removing ext commands";	3340	warn "removing ext/exti commands";
2725	%EXTCMD = ();	3341	%EXTCMD = ();
		3342	%EXTICMD = ();
2726		3343
2727	warn "unloading/nuking all extensions";	3344	warn "unloading/nuking all extensions";
2728	for my $pkg (@EXTS) {	3345	for my $pkg (@EXTS) {
2729	warn "... unloading $pkg";	3346	warn "... unloading $pkg";
2730		3347
…		…
2773	warn "reloading cf.pm";	3390	warn "reloading cf.pm";
2774	require cf;	3391	require cf;
2775	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3392	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2776		3393
2777	warn "loading config and database again";	3394	warn "loading config and database again";
2778	cf::cfg_load;	3395	cf::reload_config;
2779		3396
2780	warn "loading extensions";	3397	warn "loading extensions";
2781	cf::load_extensions;	3398	cf::load_extensions;
2782		3399
2783	warn "reattaching attachments to objects/players";	3400	warn "reattaching attachments to objects/players";
…		…
2876	write_runtime	3493	write_runtime
2877	or warn "ERROR: unable to write runtime file: $!";	3494	or warn "ERROR: unable to write runtime file: $!";
2878	};	3495	};
2879	}	3496	}
2880		3497
2881	# my $AFTER = Event::time;
2882	# warn $AFTER - $NOW;#d#
2883
2884	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3498	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2885	$sig->send;	3499	$sig->send;
2886	}	3500	}
2887	while (my $sig = shift @WAIT_FOR_TICK) {	3501	while (my $sig = shift @WAIT_FOR_TICK) {
2888	$sig->send;	3502	$sig->send;
…		…
2898		3512
2899	$LOAD = ($NOW - $tick_start) / $TICK;	3513	$LOAD = ($NOW - $tick_start) / $TICK;
2900	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	3514	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2901		3515
2902	_post_tick;	3516	_post_tick;
2903
2904
2905	},	3517	},
2906	);	3518	);
2907		3519
2908	{	3520	{
		3521	BDB::min_parallel 8;
2909	BDB::max_poll_time $TICK * 0.1;	3522	BDB::max_poll_time $TICK * 0.1;
2910	$BDB_POLL_WATCHER = Event->io (	3523	$BDB_POLL_WATCHER = Event->io (
2911	reentrant => 0,	3524	reentrant => 0,
2912	fd => BDB::poll_fileno,	3525	fd => BDB::poll_fileno,
2913	poll => 'r',	3526	poll => 'r',
2914	prio => 0,	3527	prio => 0,
2915	data => WF_AUTOCANCEL,	3528	data => WF_AUTOCANCEL,
2916	cb => \&BDB::poll_cb,	3529	cb => \&BDB::poll_cb,
2917	);	3530	);
2918	BDB::min_parallel 8;
2919		3531
2920	BDB::set_sync_prepare {	3532	BDB::set_sync_prepare {
2921	my $status;	3533	my $status;
2922	my $current = $Coro::current;	3534	my $current = $Coro::current;
2923	(	3535	(
…		…
2932	)	3544	)
2933	};	3545	};
2934		3546
2935	unless ($DB_ENV) {	3547	unless ($DB_ENV) {
2936	$DB_ENV = BDB::db_env_create;	3548	$DB_ENV = BDB::db_env_create;
		3549	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
		3550	| BDB::LOG_AUTOREMOVE, 1);
		3551	$DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
		3552	$DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2937		3553
2938	cf::sync_job {	3554	cf::sync_job {
2939	eval {	3555	eval {
2940	BDB::db_env_open	3556	BDB::db_env_open
2941	$DB_ENV,	3557	$DB_ENV,
…		…
2943	BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN	3559	BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2944	| BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,	3560	| BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2945	0666;	3561	0666;
2946		3562
2947	cf::cleanup "db_env_open($BDBDIR): $!" if $!;	3563	cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2948
2949	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2950	$DB_ENV->set_lk_detect;
2951	};	3564	};
2952		3565
2953	cf::cleanup "db_env_open(db): $@" if $@;	3566	cf::cleanup "db_env_open(db): $@" if $@;
2954	};	3567	};
2955	}	3568	}
		3569
		3570	$BDB_DEADLOCK_WATCHER = Event->timer (
		3571	after => 3,
		3572	interval => 1,
		3573	hard => 1,
		3574	prio => 0,
		3575	data => WF_AUTOCANCEL,
		3576	cb => sub {
		3577	BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
		3578	},
		3579	);
		3580	$BDB_CHECKPOINT_WATCHER = Event->timer (
		3581	after => 11,
		3582	interval => 60,
		3583	hard => 1,
		3584	prio => 0,
		3585	data => WF_AUTOCANCEL,
		3586	cb => sub {
		3587	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
		3588	},
		3589	);
		3590	$BDB_TRICKLE_WATCHER = Event->timer (
		3591	after => 5,
		3592	interval => 10,
		3593	hard => 1,
		3594	prio => 0,
		3595	data => WF_AUTOCANCEL,
		3596	cb => sub {
		3597	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
		3598	},
		3599	);
2956	}	3600	}
2957		3601
2958	{	3602	{
2959	IO::AIO::min_parallel 8;	3603	IO::AIO::min_parallel 8;
2960		3604

Diff Legend

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