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.494 by root, Mon Oct 26 05:18:00 2009 UTC vs.
Revision 1.624 by root, Sat Nov 17 23:40:02 2018 UTC

1	#	1	#
2	# This file is part of Deliantra, the Roguelike Realtime MMORPG.	2	# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3	#	3	#
		4	# Copyright (©) 2018 Marc Alexander Lehmann / the Deliantra team
4	# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team	5	# Copyright (©) 2006,2007,2008,2009,2010,2011,2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5	#	6	#
6	# Deliantra is free software: you can redistribute it and/or modify it under	7	# Deliantra is free software: you can redistribute it and/or modify it under
7	# the terms of the Affero GNU General Public License as published by the	8	# the terms of the Affero GNU General Public License as published by the
8	# Free Software Foundation, either version 3 of the License, or (at your	9	# Free Software Foundation, either version 3 of the License, or (at your
9	# option) any later version.	10	# option) any later version.
10	#	11	#
11	# This program is distributed in the hope that it will be useful,	12	# This program is distributed in the hope that it will be useful,
12	# but WITHOUT ANY WARRANTY; without even the implied warranty of	13	# but WITHOUT ANY WARRANTY; without even the implied warranty of
13	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the	14	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14	# GNU General Public License for more details.	15	# GNU General Public License for more details.
15	#	16	#
16	# You should have received a copy of the Affero GNU General Public License	17	# You should have received a copy of the Affero GNU General Public License
17	# and the GNU General Public License along with this program. If not, see	18	# and the GNU General Public License along with this program. If not, see
18	# <http://www.gnu.org/licenses/>.	19	# <http://www.gnu.org/licenses/>.
19	#	20	#
20	# The authors can be reached via e-mail to <support@deliantra.net>	21	# The authors can be reached via e-mail to <support@deliantra.net>
21	#	22	#
22		23
23	package cf;	24	package cf;
24		25
25	use 5.10.0;	26	use common::sense;
26	use utf8;
27	use strict qw(vars subs);
28		27
29	use Symbol;	28	use Symbol;
30	use List::Util;	29	use List::Util;
31	use Socket;	30	use Socket;
32	use EV;	31	use EV;
…		…
34	use Safe;	33	use Safe;
35	use Safe::Hole;	34	use Safe::Hole;
36	use Storable ();	35	use Storable ();
37	use Carp ();	36	use Carp ();
38		37
39	use Guard ();	38	use AnyEvent ();
		39	use AnyEvent::IO ();
		40	use AnyEvent::DNS ();
		41
40	use Coro ();	42	use Coro ();
41	use Coro::State;	43	use Coro::State;
42	use Coro::Handle;	44	use Coro::Handle;
43	use Coro::EV;	45	use Coro::EV;
44	use Coro::AnyEvent;	46	use Coro::AnyEvent;
…		…
50	use Coro::AIO;	52	use Coro::AIO;
51	use Coro::BDB 1.6;	53	use Coro::BDB 1.6;
52	use Coro::Storable;	54	use Coro::Storable;
53	use Coro::Util ();	55	use Coro::Util ();
54		56
		57	use Guard ();
55	use JSON::XS 2.01 ();	58	use JSON::XS 2.01 ();
56	use BDB ();	59	use BDB ();
57	use Data::Dumper;	60	use Data::Dumper;
58	use Digest::MD5;
59	use Fcntl;	61	use Fcntl;
60	use YAML::XS ();	62	use YAML::XS ();
		63	use CBOR::XS ();
61	use IO::AIO ();	64	use IO::AIO ();
62	use Time::HiRes;
63	use Compress::LZF;	65	use Compress::LZF;
64	use Digest::MD5 ();	66	use Digest::MD5 ();
65		67
66	AnyEvent::detect;	68	AnyEvent::detect;
67		69
…		…
79	# strictly for debugging	81	# strictly for debugging
80	$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };	82	$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
81		83
82	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	84	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
83		85
		86	our @ORIG_INC;
		87
84	our %COMMAND = ();	88	our %COMMAND = ();
85	our %COMMAND_TIME = ();	89	our %COMMAND_TIME = ();
86		90
87	our @EXTS = (); # list of extension package names	91	our @EXTS = (); # list of extension package names
88	our %EXTCMD = ();	92	our %EXTCMD = ();
		93	our %EXTACMD = ();
89	our %EXTICMD = ();	94	our %EXTICMD = ();
		95	our %EXTIACMD = ();
90	our %EXT_CORO = (); # coroutines bound to extensions	96	our %EXT_CORO = (); # coroutines bound to extensions
91	our %EXT_MAP = (); # pluggable maps	97	our %EXT_MAP = (); # pluggable maps
92		98
93	our $RELOAD; # number of reloads so far, non-zero while in reload	99	our $RELOAD; # number of reloads so far, non-zero while in reload
94	our @EVENT;	100	our @EVENT;
95	our @REFLECT; # set by XS	101	our @REFLECT; # set by XS
96	our %REFLECT; # set by us	102	our %REFLECT; # set by us
97		103
98	our $CONFDIR = confdir;	104	our $CONFDIR = confdir;
		105
99	our $DATADIR = datadir;	106	our $DATADIR = datadir;
100	our $LIBDIR = "$DATADIR/ext";	107	our $LIBDIR = "$DATADIR/ext";
101	our $PODDIR = "$DATADIR/pod";	108	our $PODDIR = "$DATADIR/pod";
102	our $MAPDIR = "$DATADIR/" . mapdir;	109	our $MAPDIR = "$DATADIR/" . mapdir;
		110
103	our $LOCALDIR = localdir;	111	our $LOCALDIR = localdir;
104	our $TMPDIR = "$LOCALDIR/" . tmpdir;	112	our $TMPDIR = "$LOCALDIR/" . tmpdir;
105	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;	113	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
106	our $PLAYERDIR = "$LOCALDIR/" . playerdir;	114	our $PLAYERDIR = "$LOCALDIR/" . playerdir;
107	our $RANDOMDIR = "$LOCALDIR/random";	115	our $RANDOMDIR = "$LOCALDIR/random";
108	our $BDBDIR = "$LOCALDIR/db";	116	our $BDBDIR = "$LOCALDIR/db";
109	our $PIDFILE = "$LOCALDIR/pid";	117	our $PIDFILE = "$LOCALDIR/pid";
110	our $RUNTIMEFILE = "$LOCALDIR/runtime";	118	our $RUNTIMEFILE = "$LOCALDIR/runtime";
111		119
112	our %RESOURCE;	120	#our %RESOURCE; # unused
		121
		122	our $OUTPUT_RATE_MIN = 3000;
		123	our $OUTPUT_RATE_MAX = 1000000;
		124
		125	our $MAX_LINKS = 32; # how many chained exits to follow
		126	our $VERBOSE_IO = 1;
113		127
114	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	128	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
115	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	129	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
116	our $NEXT_TICK;	130	our $NEXT_TICK;
117	our $USE_FSYNC = 1; # use fsync to write maps - default on	131	our $USE_FSYNC = 1; # use fsync to write maps - default on
…		…
119	our $BDB_DEADLOCK_WATCHER;	133	our $BDB_DEADLOCK_WATCHER;
120	our $BDB_CHECKPOINT_WATCHER;	134	our $BDB_CHECKPOINT_WATCHER;
121	our $BDB_TRICKLE_WATCHER;	135	our $BDB_TRICKLE_WATCHER;
122	our $DB_ENV;	136	our $DB_ENV;
123		137
124	our @EXTRA_MODULES = qw(pod match mapscript);	138	our @EXTRA_MODULES = qw(pod match mapscript incloader);
125		139
126	our %CFG;	140	our %CFG;
		141	our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
127		142
128	our $UPTIME; $UPTIME ||= time;	143	our $UPTIME; $UPTIME ||= time;
129	our $RUNTIME;	144	our $RUNTIME = 0;
		145	our $SERVER_TICK = 0;
130	our $NOW;	146	our $NOW;
131		147
132	our (%PLAYER, %PLAYER_LOADING); # all users	148	our (%PLAYER, %PLAYER_LOADING); # all users
133	our (%MAP, %MAP_LOADING ); # all maps	149	our (%MAP, %MAP_LOADING ); # all maps
134	our $LINK_MAP; # the special {link} map, which is always available	150	our $LINK_MAP; # the special {link} map, which is always available
…		…
143		159
144	our @POST_INIT;	160	our @POST_INIT;
145		161
146	our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)	162	our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
147	our $REALLY_UNLOOP; # never set to true, please :)	163	our $REALLY_UNLOOP; # never set to true, please :)
		164
		165	our $WAIT_FOR_TICK = new Coro::Signal;
		166	our @WAIT_FOR_TICK_BEGIN;
148		167
149	binmode STDOUT;	168	binmode STDOUT;
150	binmode STDERR;	169	binmode STDERR;
151		170
152	# read virtual server time, if available	171	# read virtual server time, if available
…		…
163		182
164	our $EMERGENCY_POSITION;	183	our $EMERGENCY_POSITION;
165		184
166	sub cf::map::normalise;	185	sub cf::map::normalise;
167		186
		187	sub in_main() {
		188	$Coro::current == $Coro::main
		189	}
		190
168	#############################################################################	191	#############################################################################
169		192
170	%REFLECT = ();	193	%REFLECT = ();
171	for (@REFLECT) {	194	for (@REFLECT) {
172	my $reflect = JSON::XS::decode_json $_;	195	my $reflect = JSON::XS::decode_json $_;
…		…
182		205
183	=over 4	206	=over 4
184		207
185	=item $cf::UPTIME	208	=item $cf::UPTIME
186		209
187	The timestamp of the server start (so not actually an uptime).	210	The timestamp of the server start (so not actually an "uptime").
		211
		212	=item $cf::SERVER_TICK
		213
		214	An unsigned integer that starts at zero when the server is started and is
		215	incremented on every tick.
		216
		217	=item $cf::NOW
		218
		219	The (real) time of the last (current) server tick - updated before and
		220	after tick processing, so this is useful only as a rough "what time is it
		221	now" estimate.
		222
		223	=item $cf::TICK
		224
		225	The interval between each server tick, in seconds.
188		226
189	=item $cf::RUNTIME	227	=item $cf::RUNTIME
190		228
191	The time this server has run, starts at 0 and is increased by $cf::TICK on	229	The time this server has run, starts at 0 and is increased by $cf::TICK on
192	every server tick.	230	every server tick.
193		231
194	=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR	232	=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
195	$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR	233	$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
196	$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR	234	$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
197		235
198	Various directories - "/etc", read-only install directory, perl-library	236	Various directories - "/etc", read-only install directory, perl-library
199	directory, pod-directory, read-only maps directory, "/var", "/var/tmp",	237	directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
200	unique-items directory, player file directory, random maps directory and	238	unique-items directory, player file directory, random maps directory and
201	database environment.	239	database environment.
202		240
203	=item $cf::NOW
204
205	The time of the last (current) server tick.
206
207	=item $cf::TICK
208
209	The interval between server ticks, in seconds.
210
211	=item $cf::LOADAVG	241	=item $cf::LOADAVG
212		242
213	The current CPU load on the server (alpha-smoothed), as a value between 0	243	The current CPU load on the server (alpha-smoothed), as a value between 0
214	(none) and 1 (overloaded), indicating how much time is spent on processing	244	(none) and 1 (overloaded), indicating how much time is spent on processing
215	objects per tick. Healthy values are < 0.5.	245	objects per tick. Healthy values are < 0.5.
…		…
223	Configuration for the server, loaded from C</etc/deliantra-server/config>, or	253	Configuration for the server, loaded from C</etc/deliantra-server/config>, or
224	from wherever your confdir points to.	254	from wherever your confdir points to.
225		255
226	=item cf::wait_for_tick, cf::wait_for_tick_begin	256	=item cf::wait_for_tick, cf::wait_for_tick_begin
227		257
228	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	258	These are functions that inhibit the current coroutine one tick.
229	returns directly I<after> the tick processing (and consequently, can only wake one process	259	cf::wait_for_tick_begin only returns directly I<after> the tick
		260	processing (and consequently, can only wake one thread per tick), while
230	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	261	cf::wait_for_tick wakes up all waiters after tick processing.
		262
		263	Note that cf::wait_for_tick will immediately return when the server is not
		264	ticking, making it suitable for small pauses in threads that need to run
		265	when the server is paused. If that is not applicable (i.e. you I<really>
		266	want to wait, use C<$cf::WAIT_FOR_TICK>).
		267
		268	=item $cf::WAIT_FOR_TICK
		269
		270	Note that C<cf::wait_for_tick> is probably the correct thing to use. This
		271	variable contains a L<Coro::Signal> that is broadcats after every server
		272	tick. Calling C<< ->wait >> on it will suspend the caller until after the
		273	next server tick.
		274
		275	=cut
		276
		277	sub wait_for_tick();
		278	sub wait_for_tick_begin();
231		279
232	=item @cf::INVOKE_RESULTS	280	=item @cf::INVOKE_RESULTS
233		281
234	This array contains the results of the last C<invoke ()> call. When	282	This array contains the results of the last C<invoke ()> call. When
235	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of	283	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
…		…
243		291
244	=back	292	=back
245		293
246	=cut	294	=cut
247		295
		296	sub error(@) { LOG llevError, join "", @_ }
		297	sub warn (@) { LOG llevWarn , join "", @_ }
		298	sub info (@) { LOG llevInfo , join "", @_ }
		299	sub debug(@) { LOG llevDebug, join "", @_ }
		300	sub trace(@) { LOG llevTrace, join "", @_ }
		301
248	$Coro::State::WARNHOOK = sub {	302	$Coro::State::WARNHOOK = sub {
249	my $msg = join "", @_;	303	my $msg = join "", @_;
250		304
251	$msg .= "\n"	305	$msg .= "\n"
252	unless $msg =~ /\n$/;	306	unless $msg =~ /\n$/;
253		307
254	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;	308	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
255		309
256	LOG llevError, $msg;	310	LOG llevWarn, $msg;
257	};	311	};
258		312
259	$Coro::State::DIEHOOK = sub {	313	$Coro::State::DIEHOOK = sub {
260	return unless $^S eq 0; # "eq", not "=="	314	return unless $^S eq 0; # "eq", not "=="
261		315
262	warn Carp::longmess $_[0];	316	error Carp::longmess $_[0];
263		317
264	if ($Coro::current == $Coro::main) {#d#	318	if (in_main) {#d#
265	warn "DIEHOOK called in main context, Coro bug?\n";#d#	319	error "DIEHOOK called in main context, Coro bug?\n";#d#
266	return;#d#	320	return;#d#
267	}#d#	321	}#d#
268		322
269	# kill coroutine otherwise	323	# kill coroutine otherwise
270	Coro::terminate	324	Coro::terminate
…		…
290	)) {	344	)) {
291	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	345	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
292	}	346	}
293		347
294	$EV::DIED = sub {	348	$EV::DIED = sub {
295	Carp::cluck "error in event callback: @_";	349	warn "error in event callback: $@";
296	};	350	};
		351
		352	#############################################################################
		353
		354	sub fork_call(&@);
		355	sub get_slot($;$$);
297		356
298	#############################################################################	357	#############################################################################
299		358
300	=head2 UTILITY FUNCTIONS	359	=head2 UTILITY FUNCTIONS
301		360
…		…
322	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;	381	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
323	$d	382	$d
324	} || "[unable to dump $_[0]: '$@']";	383	} || "[unable to dump $_[0]: '$@']";
325	}	384	}
326		385
		386	=item $scalar = cf::load_file $path
		387
		388	Loads the given file from path and returns its contents. Croaks on error
		389	and can block.
		390
		391	=cut
		392
		393	sub load_file($) {
		394	0 <= aio_load $_[0], my $data
		395	or Carp::croak "$_[0]: $!";
		396
		397	$data
		398	}
		399
		400	=item $success = cf::replace_file $path, $data, $sync
		401
		402	Atomically replaces the file at the given $path with new $data, and
		403	optionally $sync the data to disk before replacing the file.
		404
		405	=cut
		406
		407	sub replace_file($$;$) {
		408	my ($path, $data, $sync) = @_;
		409
		410	my $lock = cf::lock_acquire ("replace_file:$path");
		411
		412	my $fh = aio_open "$path~", Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_TRUNC, 0644
		413	or return;
		414
		415	$data = $data->() if ref $data;
		416
		417	length $data == aio_write $fh, 0, (length $data), $data, 0
		418	or return;
		419
		420	!$sync
		421	or !aio_fsync $fh
		422	or return;
		423
		424	aio_close $fh
		425	and return;
		426
		427	aio_rename "$path~", $path
		428	and return;
		429
		430	if ($sync) {
		431	$path =~ s%/[^/]*$%%;
		432	aio_pathsync $path;
		433	}
		434
		435	1
		436	}
		437
327	=item $ref = cf::decode_json $json	438	=item $ref = cf::decode_json $json
328		439
329	Converts a JSON string into the corresponding perl data structure.	440	Converts a JSON string into the corresponding perl data structure.
330		441
331	=item $json = cf::encode_json $ref	442	=item $json = cf::encode_json $ref
…		…
337	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max	448	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
338		449
339	sub encode_json($) { $json_coder->encode ($_[0]) }	450	sub encode_json($) { $json_coder->encode ($_[0]) }
340	sub decode_json($) { $json_coder->decode ($_[0]) }	451	sub decode_json($) { $json_coder->decode ($_[0]) }
341		452
		453	=item $ref = cf::decode_storable $scalar
		454
		455	Same as Coro::Storable::thaw, so blocks.
		456
		457	=cut
		458
		459	BEGIN { *decode_storable = \&Coro::Storable::thaw }
		460
		461	=item $ref = cf::decode_yaml $scalar
		462
		463	Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
		464
		465	=cut
		466
		467	sub decode_yaml($) {
		468	fork_call { YAML::XS::Load $_[0] } @_
		469	}
		470
		471	=item $scalar = cf::decode_cbor $scalar
		472
		473	Same as CBOR::XS::decode_cbor, but takes server ticks into account, so
		474	blocks. For small amounts of data, C<CBOR::XS::decode_cbor> is the better
		475	alternative.
		476
		477	=cut
		478
		479	sub decode_cbor($) {
		480	# we assume 10mb/s minimum decoding speed (on a ~2ghz machine)
		481	cf::get_slot +(length $_[0]) / 10_000_000, 0, "decode_cbor";
		482	CBOR::XS::decode_cbor $_[0]
		483	}
		484
		485	=item $scalar = cf::unlzf $scalar
		486
		487	Same as Compress::LZF::compress, but takes server ticks into account, so
		488	blocks.
		489
		490	=cut
		491
		492	sub unlzf($) {
		493	# we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
		494	cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
		495	Compress::LZF::decompress $_[0]
		496	}
		497
342	=item cf::post_init { BLOCK }	498	=item cf::post_init { BLOCK }
343		499
344	Execute the given codeblock, I<after> all extensions have been (re-)loaded,	500	Execute the given codeblock, I<after> all extensions have been (re-)loaded,
345	but I<before> the server starts ticking again.	501	but I<before> the server starts ticking again.
346		502
347	The cdoeblock will have a single boolean argument to indicate whether this	503	The codeblock will have a single boolean argument to indicate whether this
348	is a reload or not.	504	is a reload or not.
349		505
350	=cut	506	=cut
351		507
352	sub post_init(&) {	508	sub post_init(&) {
353	push @POST_INIT, shift;	509	push @POST_INIT, shift;
354	}	510	}
355		511
		512	sub _post_init {
		513	trace "running post_init jobs";
		514
		515	# run them in parallel...
		516
		517	my @join;
		518
		519	while () {
		520	push @join, map &Coro::async ($_, 0), @POST_INIT;
		521	@POST_INIT = ();
		522
		523	@join or last;
		524
		525	(pop @join)->join;
		526	}
		527	}
		528
356	=item cf::lock_wait $string	529	=item cf::lock_wait $string
357		530
358	Wait until the given lock is available. See cf::lock_acquire.	531	Wait until the given lock is available. See cf::lock_acquire.
359		532
360	=item my $lock = cf::lock_acquire $string	533	=item my $lock = cf::lock_acquire $string
361		534
362	Wait until the given lock is available and then acquires it and returns	535	Wait until the given lock is available and then acquires it and returns
363	a L<Guard> object. If the guard object gets destroyed (goes out of scope,	536	a L<Guard> object. If the guard object gets destroyed (goes out of scope,
…		…
397	}	570	}
398		571
399	=item cf::periodic $interval, $cb	572	=item cf::periodic $interval, $cb
400		573
401	Like EV::periodic, but randomly selects a starting point so that the actions	574	Like EV::periodic, but randomly selects a starting point so that the actions
402	get spread over timer.	575	get spread over time.
403		576
404	=cut	577	=cut
405		578
406	sub periodic($$) {	579	sub periodic($$) {
407	my ($interval, $cb) = @_;	580	my ($interval, $cb) = @_;
…		…
411	EV::periodic $start, $interval, 0, $cb	584	EV::periodic $start, $interval, 0, $cb
412	}	585	}
413		586
414	=item cf::get_slot $time[, $priority[, $name]]	587	=item cf::get_slot $time[, $priority[, $name]]
415		588
416	Allocate $time seconds of blocking CPU time at priority C<$priority>:	589	Allocate $time seconds of blocking CPU time at priority C<$priority>
417	This call blocks and returns only when you have at least C<$time> seconds	590	(default: 0): This call blocks and returns only when you have at least
418	of cpu time till the next tick. The slot is only valid till the next cede.	591	C<$time> seconds of cpu time till the next tick. The slot is only valid
		592	till the next cede.
		593
		594	Background jobs should use a priority less than zero, interactive jobs
		595	should use 100 or more.
419		596
420	The optional C<$name> can be used to identify the job to run. It might be	597	The optional C<$name> can be used to identify the job to run. It might be
421	used for statistical purposes and should identify the same time-class.	598	used for statistical purposes and should identify the same time-class.
422		599
423	Useful for short background jobs.	600	Useful for short background jobs.
424		601
425	=cut	602	=cut
426		603
427	our @SLOT_QUEUE;	604	our @SLOT_QUEUE;
428	our $SLOT_QUEUE;	605	our $SLOT_QUEUE;
		606	our $SLOT_DECAY = 0.9;
429		607
430	$SLOT_QUEUE->cancel if $SLOT_QUEUE;	608	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
431	$SLOT_QUEUE = Coro::async {	609	$SLOT_QUEUE = Coro::async {
432	$Coro::current->desc ("timeslot manager");	610	$Coro::current->desc ("timeslot manager");
433		611
434	my $signal = new Coro::Signal;	612	my $signal = new Coro::Signal;
		613	my $busy;
435		614
436	while () {	615	while () {
437	next_job:	616	next_job:
		617
		618	Coro::cede;
		619
438	my $avail = cf::till_tick;	620	my $avail = cf::till_tick;
439	if ($avail > 0.01) {	621
440	for (0 .. $#SLOT_QUEUE) {	622	for (0 .. $#SLOT_QUEUE) {
441	if ($SLOT_QUEUE[$_][0] < $avail) {	623	if ($SLOT_QUEUE[$_][0] <= $avail) {
		624	$busy = 0;
442	my $job = splice @SLOT_QUEUE, $_, 1, ();	625	my $job = splice @SLOT_QUEUE, $_, 1, ();
443	$job->[2]->send;	626	$job->[2]->send;
444	Coro::cede;
445	goto next_job;	627	goto next_job;
446	}	628	} else {
		629	$SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
447	}	630	}
448	}	631	}
449		632
450	if (@SLOT_QUEUE) {	633	if (@SLOT_QUEUE) {
451	# we do not use wait_for_tick() as it returns immediately when tick is inactive	634	wait_for_tick;
452	push @cf::WAIT_FOR_TICK, $signal;
453	$signal->wait;
454	} else {	635	} else {
		636	$busy = 0;
455	Coro::schedule;	637	Coro::schedule;
456	}	638	}
457	}	639	}
458	};	640	};
459		641
460	sub get_slot($;$$) {	642	sub get_slot($;$$) {
461	return if tick_inhibit || $Coro::current == $Coro::main;	643	return if tick_inhibit || $Coro::current == $Coro::main;
462		644
463	my ($time, $pri, $name) = @_;	645	my ($time, $pri, $name) = @_;
464		646
465	$time = $TICK * .6 if $time > $TICK * .6;	647	$time = clamp $time, 0.01, $TICK * .6;
		648
466	my $sig = new Coro::Signal;	649	my $sig = new Coro::Signal;
467		650
468	push @SLOT_QUEUE, [$time, $pri, $sig, $name];	651	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
469	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;	652	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
470	$SLOT_QUEUE->ready;	653	$SLOT_QUEUE->ready;
…		…
482	BEGIN { *async = \&Coro::async_pool }	665	BEGIN { *async = \&Coro::async_pool }
483		666
484	=item cf::sync_job { BLOCK }	667	=item cf::sync_job { BLOCK }
485		668
486	The design of Deliantra requires that the main coroutine ($Coro::main)	669	The design of Deliantra requires that the main coroutine ($Coro::main)
487	is always able to handle events or runnable, as Deliantra is only	670	is always able to handle events or is runnable, as Deliantra is only
488	partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not	671	partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
489	acceptable.	672	acceptable.
490		673
491	If it must be done, put the blocking parts into C<sync_job>. This will run	674	If it must be done, put the blocking parts into C<sync_job>. This will run
492	the given BLOCK in another coroutine while waiting for the result. The	675	the given BLOCK in another coroutine while waiting for the result. The
…		…
496	=cut	679	=cut
497		680
498	sub sync_job(&) {	681	sub sync_job(&) {
499	my ($job) = @_;	682	my ($job) = @_;
500		683
501	if ($Coro::current == $Coro::main) {	684	if (in_main) {
502	my $time = EV::time;	685	my $time = AE::time;
503		686
504	# this is the main coro, too bad, we have to block	687	# this is the main coro, too bad, we have to block
505	# till the operation succeeds, freezing the server :/	688	# till the operation succeeds, freezing the server :/
506		689
507	LOG llevError, Carp::longmess "sync job";#d#	690	#LOG llevError, Carp::longmess "sync job";#d#
508		691
509	my $freeze_guard = freeze_mainloop;	692	my $freeze_guard = freeze_mainloop;
510		693
511	my $busy = 1;	694	my $busy = 1;
512	my @res;	695	my @res;
513		696
514	(async {	697	(async {
515	$Coro::current->desc ("sync job coro");	698	$Coro::current->desc ("sync job coro");
516	@res = eval { $job->() };	699	@res = eval { $job->() };
517	warn $@ if $@;	700	error $@ if $@;
518	undef $busy;	701	undef $busy;
519	})->prio (Coro::PRIO_MAX);	702	})->prio (Coro::PRIO_MAX);
520		703
521	while ($busy) {	704	while ($busy) {
522	if (Coro::nready) {	705	if (Coro::nready) {
523	Coro::cede_notself;	706	Coro::cede_notself;
524	} else {	707	} else {
525	EV::loop EV::LOOP_ONESHOT;	708	EV::run EV::RUN_ONCE;
526	}	709	}
527	}	710	}
528		711
529	my $time = EV::time - $time;	712	my $time = AE::time - $time;
530		713
531	$TICK_START += $time; # do not account sync jobs to server load	714	$TICK_START += $time; # do not account sync jobs to server load
532		715
533	wantarray ? @res : $res[0]	716	wantarray ? @res : $res[0]
534	} else {	717	} else {
…		…
556	$EXT_CORO{$coro+0} = $coro;	739	$EXT_CORO{$coro+0} = $coro;
557		740
558	$coro	741	$coro
559	}	742	}
560		743
561	=item fork_call { }, $args	744	=item fork_call { }, @args
562		745
563	Executes the given code block with the given arguments in a seperate	746	Executes the given code block with the given arguments in a seperate
564	process, returning the results. Everything must be serialisable with	747	process, returning the results. Everything must be serialisable with
565	Coro::Storable. May, of course, block. Note that the executed sub may	748	Coro::Storable. May, of course, block. Note that the executed sub may
566	never block itself or use any form of event handling.	749	never block itself or use any form of event handling.
567		750
568	=cut	751	=cut
569		752
		753	sub post_fork {
		754	reset_signals;
		755	}
		756
570	sub fork_call(&@) {	757	sub fork_call(&@) {
571	my ($cb, @args) = @_;	758	my ($cb, @args) = @_;
572		759
573	# we seemingly have to make a local copy of the whole thing,
574	# otherwise perl prematurely frees the stuff :/
575	# TODO: investigate and fix (likely this will be rather laborious)
576
577	my @res = Coro::Util::fork_eval {	760	my @res = Coro::Util::fork_eval {
578	reset_signals;	761	cf::post_fork;
579	&$cb	762	&$cb
580	}, @args;	763	} @args;
581		764
582	wantarray ? @res : $res[-1]	765	wantarray ? @res : $res[-1]
		766	}
		767
		768	sub objinfo {
		769	(
		770	"counter value" => cf::object::object_count,
		771	"objects created" => cf::object::create_count,
		772	"objects destroyed" => cf::object::destroy_count,
		773	"freelist size" => cf::object::free_count,
		774	"allocated objects" => cf::object::objects_size,
		775	"active objects" => cf::object::actives_size,
		776	)
583	}	777	}
584		778
585	=item $coin = coin_from_name $name	779	=item $coin = coin_from_name $name
586		780
587	=cut	781	=cut
…		…
624	within each server.	818	within each server.
625		819
626	=cut	820	=cut
627		821
628	sub db_table($) {	822	sub db_table($) {
		823	cf::error "db_get called from main context"
		824	if $Coro::current == $Coro::main;
		825
629	my ($name) = @_;	826	my ($name) = @_;
630	my $db = BDB::db_create $DB_ENV;	827	my $db = BDB::db_create $DB_ENV;
631		828
632	eval {	829	eval {
633	$db->set_flags (BDB::CHKSUM);	830	$db->set_flags (BDB::CHKSUM);
…		…
643	}	840	}
644		841
645	our $DB;	842	our $DB;
646		843
647	sub db_init {	844	sub db_init {
648	cf::sync_job {
649	$DB ||= db_table "db";	845	$DB ||= db_table "db";
650	};
651	}	846	}
652		847
653	sub db_get($$) {	848	sub db_get($$) {
654	my $key = "$_[0]/$_[1]";	849	my $key = "$_[0]/$_[1]";
655		850
656	cf::sync_job {	851	cf::error "db_get called from main context"
		852	if $Coro::current == $Coro::main;
		853
657	BDB::db_get $DB, undef, $key, my $data;	854	BDB::db_get $DB, undef, $key, my $data;
658		855
659	$! ? ()	856	$! ? ()
660	: $data	857	: $data
661	}
662	}	858	}
663		859
664	sub db_put($$$) {	860	sub db_put($$$) {
665	BDB::dbreq_pri 4;	861	BDB::dbreq_pri 4;
666	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };	862	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
…		…
694		890
695	my @data;	891	my @data;
696	my $md5;	892	my $md5;
697		893
698	for (0 .. $#$src) {	894	for (0 .. $#$src) {
699	0 <= aio_load $src->[$_], $data[$_]	895	$data[$_] = load_file $src->[$_];
700	or Carp::croak "$src->[$_]: $!";
701	}	896	}
702		897
703	# if processing is expensive, check	898	# if processing is expensive, check
704	# checksum first	899	# checksum first
705	if (1) {	900	if (1) {
…		…
718		913
719	return db_get cache => "$id/data";	914	return db_get cache => "$id/data";
720	}	915	}
721	}	916	}
722		917
723	my $t1 = Time::HiRes::time;	918	my $t1 = EV::time;
724	my $data = $process->(\@data);	919	my $data = $process->(\@data);
725	my $t2 = Time::HiRes::time;	920	my $t2 = EV::time;
726		921
727	warn "cache: '$id' processed in ", $t2 - $t1, "s\n";	922	info "cache: '$id' processed in ", $t2 - $t1, "s\n";
728		923
729	db_put cache => "$id/data", $data;	924	db_put cache => "$id/data", $data;
730	db_put cache => "$id/md5" , $md5;	925	db_put cache => "$id/md5" , $md5;
731	db_put cache => "$id/meta", $meta;	926	db_put cache => "$id/meta", $meta;
732		927
…		…
742		937
743	=cut	938	=cut
744		939
745	sub datalog($@) {	940	sub datalog($@) {
746	my ($type, %kv) = @_;	941	my ($type, %kv) = @_;
747	warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });	942	info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
748	}	943	}
749		944
750	=back	945	=back
751		946
752	=cut	947	=cut
…		…
947		1142
948	} elsif (exists $cb_id{$type}) {	1143	} elsif (exists $cb_id{$type}) {
949	_attach_cb $registry, $cb_id{$type}, $prio, shift @arg;	1144	_attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
950		1145
951	} elsif (ref $type) {	1146	} elsif (ref $type) {
952	warn "attaching objects not supported, ignoring.\n";	1147	error "attaching objects not supported, ignoring.\n";
953		1148
954	} else {	1149	} else {
955	shift @arg;	1150	shift @arg;
956	warn "attach argument '$type' not supported, ignoring.\n";	1151	error "attach argument '$type' not supported, ignoring.\n";
957	}	1152	}
958	}	1153	}
959	}	1154	}
960		1155
961	sub _object_attach {	1156	sub _object_attach {
…		…
971	_attach $registry, $klass, @attach;	1166	_attach $registry, $klass, @attach;
972	}	1167	}
973		1168
974	$obj->{$name} = \%arg;	1169	$obj->{$name} = \%arg;
975	} else {	1170	} else {
976	warn "object uses attachment '$name' which is not available, postponing.\n";	1171	info "object uses attachment '$name' which is not available, postponing.\n";
977	}	1172	}
978		1173
979	$obj->{_attachment}{$name} = undef;	1174	$obj->{_attachment}{$name} = undef;
980	}	1175	}
981		1176
…		…
1040		1235
1041	for (@$callbacks) {	1236	for (@$callbacks) {
1042	eval { &{$_->[1]} };	1237	eval { &{$_->[1]} };
1043		1238
1044	if ($@) {	1239	if ($@) {
1045	warn "$@";
1046	warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";	1240	error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1047	override;	1241	override;
1048	}	1242	}
1049		1243
1050	return 1 if $override;	1244	return 1 if $override;
1051	}	1245	}
…		…
1130	for (@$attach) {	1324	for (@$attach) {
1131	my ($klass, @attach) = @$_;	1325	my ($klass, @attach) = @$_;
1132	_attach $registry, $klass, @attach;	1326	_attach $registry, $klass, @attach;
1133	}	1327	}
1134	} else {	1328	} else {
1135	warn "object uses attachment '$name' that is not available, postponing.\n";	1329	info "object uses attachment '$name' that is not available, postponing.\n";
1136	}	1330	}
1137	}	1331	}
1138	}	1332	}
1139		1333
1140	cf::attachable->attach (	1334	cf::attachable->attach (
…		…
1167	my ($filename, $rdata, $objs) = @_;	1361	my ($filename, $rdata, $objs) = @_;
1168		1362
1169	sync_job {	1363	sync_job {
1170	if (length $$rdata) {	1364	if (length $$rdata) {
1171	utf8::decode (my $decname = $filename);	1365	utf8::decode (my $decname = $filename);
1172	warn sprintf "saving %s (%d,%d)\n",	1366	trace sprintf "saving %s (%d,%d)\n",
1173	$decname, length $$rdata, scalar @$objs;	1367	$decname, length $$rdata, scalar @$objs
		1368	if $VERBOSE_IO;
1174		1369
1175	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {	1370	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1176	aio_chmod $fh, SAVE_MODE;	1371	aio_chmod $fh, SAVE_MODE;
1177	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1372	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1178	if ($cf::USE_FSYNC) {	1373	if ($cf::USE_FSYNC) {
…		…
1200	aio_rename "$filename~", $filename;	1395	aio_rename "$filename~", $filename;
1201		1396
1202	$filename =~ s%/[^/]+$%%;	1397	$filename =~ s%/[^/]+$%%;
1203	aio_pathsync $filename if $cf::USE_FSYNC;	1398	aio_pathsync $filename if $cf::USE_FSYNC;
1204	} else {	1399	} else {
1205	warn "unable to save objects: $filename~: $!\n";	1400	error "unable to save objects: $filename~: $!\n";
1206	}	1401	}
1207	} else {	1402	} else {
1208	aio_unlink $filename;	1403	aio_unlink $filename;
1209	aio_unlink "$filename.pst";	1404	aio_unlink "$filename.pst";
1210	}	1405	}
…		…
1234	my $st = eval { Coro::Storable::thaw $av };	1429	my $st = eval { Coro::Storable::thaw $av };
1235	$av = $st->{objs};	1430	$av = $st->{objs};
1236	}	1431	}
1237		1432
1238	utf8::decode (my $decname = $filename);	1433	utf8::decode (my $decname = $filename);
1239	warn sprintf "loading %s (%d,%d)\n",	1434	trace sprintf "loading %s (%d,%d)\n",
1240	$decname, length $data, scalar @{$av || []};	1435	$decname, length $data, scalar @{$av || []}
		1436	if $VERBOSE_IO;
1241		1437
1242	($data, $av)	1438	($data, $av)
1243	}	1439	}
1244		1440
1245	=head2 COMMAND CALLBACKS	1441	=head2 COMMAND CALLBACKS
…		…
1249	=cut	1445	=cut
1250		1446
1251	#############################################################################	1447	#############################################################################
1252	# command handling &c	1448	# command handling &c
1253		1449
1254	=item cf::register_command $name => \&callback($ob,$args);	1450	=item cf::register_command $name => \&callback($ob,$args)
1255		1451
1256	Register a callback for execution when the client sends the user command	1452	Register a callback for execution when the client sends the user command
1257	$name.	1453	$name.
1258		1454
1259	=cut	1455	=cut
…		…
1265	#warn "registering command '$name/$time' to '$caller'";	1461	#warn "registering command '$name/$time' to '$caller'";
1266		1462
1267	push @{ $COMMAND{$name} }, [$caller, $cb];	1463	push @{ $COMMAND{$name} }, [$caller, $cb];
1268	}	1464	}
1269		1465
1270	=item cf::register_extcmd $name => \&callback($pl,$packet);	1466	=item cf::register_extcmd $name => \&callback($pl,@args)
1271		1467
1272	Register a callback for execution when the client sends an (synchronous)	1468	Register a callback for execution when the client sends an (synchronous)
1273	extcmd packet. Ext commands will be processed in the order they are	1469	extcmd packet. Ext commands will be processed in the order they are
1274	received by the server, like other user commands. The first argument is	1470	received by the server, like other user commands. The first argument is
1275	the logged-in player. Ext commands can only be processed after a player	1471	the logged-in player. Ext commands can only be processed after a player
1276	has logged in successfully.	1472	has logged in successfully.
1277		1473
1278	If the callback returns something, it is sent back as if reply was being	1474	The values will be sent back to the client.
1279	called.
1280		1475
		1476	=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
		1477
		1478	Same as C<cf::register_extcmd>, but instead of returning values, the
		1479	callback needs to clal the C<$reply> function.
		1480
1281	=item cf::register_exticmd $name => \&callback($ns,$packet);	1481	=item cf::register_exticmd $name => \&callback($ns,@args)
1282		1482
1283	Register a callback for execution when the client sends an (asynchronous)	1483	Register a callback for execution when the client sends an (asynchronous)
1284	exticmd packet. Exti commands are processed by the server as soon as they	1484	exticmd packet. Exti commands are processed by the server as soon as they
1285	are received, i.e. out of order w.r.t. other commands. The first argument	1485	are received, i.e. out of order w.r.t. other commands. The first argument
1286	is a client socket. Exti commands can be received anytime, even before	1486	is a client socket. Exti commands can be received anytime, even before
1287	log-in.	1487	log-in.
1288		1488
1289	If the callback returns something, it is sent back as if reply was being	1489	The values will be sent back to the client.
1290	called.
1291		1490
1292	=cut	1491	=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
1293		1492
		1493	Same as C<cf::register_extcmd>, but instead of returning values, the
		1494	callback needs to clal the C<$reply> function.
		1495
		1496	=cut
		1497
1294	sub register_extcmd {	1498	sub register_extcmd($$) {
1295	my ($name, $cb) = @_;	1499	my ($name, $cb) = @_;
1296		1500
1297	$EXTCMD{$name} = $cb;	1501	$EXTCMD{$name} = $cb;
1298	}	1502	}
1299		1503
1300	sub register_exticmd {	1504	sub register_async_extcmd($$) {
1301	my ($name, $cb) = @_;	1505	my ($name, $cb) = @_;
1302		1506
		1507	$EXTACMD{$name} = $cb;
		1508	}
		1509
		1510	sub register_exticmd($$) {
		1511	my ($name, $cb) = @_;
		1512
1303	$EXTICMD{$name} = $cb;	1513	$EXTICMD{$name} = $cb;
1304	}	1514	}
1305		1515
		1516	sub register_async_exticmd($$) {
		1517	my ($name, $cb) = @_;
		1518
		1519	$EXTIACMD{$name} = $cb;
		1520	}
		1521
1306	use File::Glob ();	1522	use File::Glob ();
1307		1523
1308	cf::player->attach (	1524	cf::player->attach (
1309	on_command => sub {	1525	on_unknown_command => sub {
1310	my ($pl, $name, $params) = @_;	1526	my ($pl, $name, $params) = @_;
1311		1527
1312	my $cb = $COMMAND{$name}	1528	my $cb = $COMMAND{$name}
1313	or return;	1529	or return;
1314		1530
…		…
1322	my ($pl, $buf) = @_;	1538	my ($pl, $buf) = @_;
1323		1539
1324	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1540	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1325		1541
1326	if (ref $msg) {	1542	if (ref $msg) {
1327	my ($type, $reply, @payload) =	1543	my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1328	"ARRAY" eq ref $msg
1329	? @$msg
1330	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1331		1544
1332	my @reply;
1333
1334	if (my $cb = $EXTCMD{$type}) {	1545	if (my $cb = $EXTACMD{$type}) {
		1546	$cb->(
		1547	$pl,
		1548	sub {
		1549	$pl->ext_msg ("reply-$reply", @_)
		1550	if $reply;
		1551	},
		1552	@payload
		1553	);
		1554	} else {
		1555	my @reply;
		1556
		1557	if (my $cb = $EXTCMD{$type}) {
1335	@reply = $cb->($pl, @payload);	1558	@reply = $cb->($pl, @payload);
		1559	}
		1560
		1561	$pl->ext_msg ("reply-$reply", @reply)
		1562	if $reply;
1336	}	1563	}
1337		1564
1338	$pl->ext_reply ($reply, @reply)
1339	if $reply;
1340
1341	} else {	1565	} else {
1342	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1566	error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1343	}	1567	}
1344		1568
1345	cf::override;	1569	cf::override;
1346	},	1570	},
1347	);	1571	);
…		…
1357	};	1581	};
1358		1582
1359	$grp	1583	$grp
1360	}	1584	}
1361		1585
		1586	sub _ext_cfg_reg($$$$) {
		1587	my ($rvar, $varname, $cfgname, $default) = @_;
		1588
		1589	$cfgname = lc $varname
		1590	unless length $cfgname;
		1591
		1592	$EXT_CFG{$cfgname} = [$rvar, $default];
		1593
		1594	$$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
		1595	}
		1596
1362	sub load_extensions {	1597	sub load_extensions {
		1598	info "loading extensions...";
		1599
		1600	%EXT_CFG = ();
		1601
1363	cf::sync_job {	1602	cf::sync_job {
1364	my %todo;	1603	my %todo;
1365		1604
1366	for my $path (<$LIBDIR/*.ext>) {	1605	for my $path (<$LIBDIR/*.ext>) {
1367	next unless -r $path;	1606	next unless -r $path;
…		…
1385		1624
1386	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }	1625	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1387	if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;	1626	if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1388		1627
1389	$ext{source} =	1628	$ext{source} =
1390	"package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"	1629	"package $pkg; use common::sense;\n"
1391	. "#line 1 \"$path\"\n{\n"	1630	. "#line 1 \"$path\"\n{\n"
1392	. $source	1631	. $source
1393	. "\n};\n1";	1632	. "\n};\n1";
1394		1633
1395	$todo{$base} = \%ext;	1634	$todo{$base} = \%ext;
1396	}	1635	}
1397		1636
		1637	my $pass = 0;
1398	my %done;	1638	my %done;
1399	while (%todo) {	1639	while (%todo) {
1400	my $progress;	1640	my $progress;
1401		1641
		1642	++$pass;
		1643
		1644	ext:
1402	while (my ($k, $v) = each %todo) {	1645	while (my ($k, $v) = each %todo) {
1403	for (split /,\s*/, $v->{meta}{depends}) {	1646	for (split /,\s*/, $v->{meta}{depends}) {
1404	goto skip	1647	next ext
1405	unless exists $done{$_};	1648	unless exists $done{$_};
1406	}	1649	}
1407		1650
1408	warn "... loading '$k' into '$v->{pkg}'\n";	1651	trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1409		1652
1410	unless (eval $v->{source}) {	1653	my $source = $v->{source};
		1654
		1655	# support "CONF varname :confname = default" pseudo-statements
		1656	$source =~ s{
		1657	^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
		1658	}{
		1659	"our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
		1660	}gmxe;
		1661
		1662	my $active = eval $source;
		1663
		1664	if (length $@) {
1411	my $msg = $@ ? "$v->{path}: $@\n"	1665	error "$v->{path}: $@\n";
1412	: "$v->{base}: extension inactive.\n";
1413		1666
1414	if (exists $v->{meta}{mandatory}) {
1415	warn $msg;
1416	cf::cleanup "mandatory extension failed to load, exiting.";	1667	cf::cleanup "mandatory extension '$k' failed to load, exiting."
1417	}	1668	if exists $v->{meta}{mandatory};
1418		1669
1419	warn $msg;	1670	warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
		1671	delete $todo{$k};
		1672	} else {
		1673	$done{$k} = delete $todo{$k};
		1674	push @EXTS, $v->{pkg};
		1675	$progress = 1;
		1676
		1677	info "$v->{base}: extension inactive.\n"
		1678	unless $active;
1420	}	1679	}
1421
1422	$done{$k} = delete $todo{$k};
1423	push @EXTS, $v->{pkg};
1424	$progress = 1;
1425	}	1680	}
1426		1681
1427	skip:	1682	unless ($progress) {
1428	die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"	1683	warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1429	unless $progress;	1684
		1685	while (my ($k, $v) = each %todo) {
		1686	cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
		1687	if exists $v->{meta}{mandatory};
		1688	}
		1689
		1690	last;
		1691	}
1430	}	1692	}
1431	};	1693	};
1432	}	1694	}
1433		1695
1434	#############################################################################	1696	#############################################################################
…		…
1518	$cf::PLAYER{$login} = $pl	1780	$cf::PLAYER{$login} = $pl
1519	}	1781	}
1520	}	1782	}
1521	}	1783	}
1522		1784
		1785	cf::player->attach (
		1786	on_load => sub {
		1787	my ($pl, $path) = @_;
		1788
		1789	# restore slots saved in save, below
		1790	my $slots = delete $pl->{_slots};
		1791
		1792	$pl->ob->current_weapon ($slots->[0]);
		1793	$pl->combat_ob ($slots->[1]);
		1794	$pl->ranged_ob ($slots->[2]);
		1795	},
		1796	);
		1797
1523	sub save($) {	1798	sub save($) {
1524	my ($pl) = @_;	1799	my ($pl) = @_;
1525		1800
1526	return if $pl->{deny_save};	1801	return if $pl->{deny_save};
1527		1802
…		…
1532		1807
1533	aio_mkdir playerdir $pl, 0770;	1808	aio_mkdir playerdir $pl, 0770;
1534	$pl->{last_save} = $cf::RUNTIME;	1809	$pl->{last_save} = $cf::RUNTIME;
1535		1810
1536	cf::get_slot 0.01;	1811	cf::get_slot 0.01;
		1812
		1813	# save slots, to be restored later
		1814	local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1537		1815
1538	$pl->save_pl ($path);	1816	$pl->save_pl ($path);
1539	cf::cede_to_tick;	1817	cf::cede_to_tick;
1540	}	1818	}
1541		1819
…		…
1575	my $name = $pl->ob->name;	1853	my $name = $pl->ob->name;
1576		1854
1577	$pl->{deny_save} = 1;	1855	$pl->{deny_save} = 1;
1578	$pl->password ("*"); # this should lock out the player until we have nuked the dir	1856	$pl->password ("*"); # this should lock out the player until we have nuked the dir
1579		1857
1580	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;	1858	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1581	$pl->deactivate;	1859	$pl->deactivate;
		1860
1582	my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;	1861	my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1583	$pl->ob->check_score;
1584	$pl->invoke (cf::EVENT_PLAYER_QUIT);	1862	$pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
		1863	ext::highscore::check ($pl->ob);
		1864
1585	$pl->ns->destroy if $pl->ns;	1865	$pl->ns->destroy if $pl->ns;
1586		1866
1587	my $path = playerdir $pl;	1867	my $path = playerdir $pl;
1588	my $temp = "$path~$cf::RUNTIME~deleting~";	1868	my $temp = "$path~$cf::RUNTIME~deleting~";
1589	aio_rename $path, $temp;	1869	aio_rename $path, $temp;
…		…
1643	\@logins	1923	\@logins
1644	}	1924	}
1645		1925
1646	=item $player->maps	1926	=item $player->maps
1647		1927
		1928	=item cf::player::maps $login
		1929
1648	Returns an arrayref of map paths that are private for this	1930	Returns an arrayref of map paths that are private for this
1649	player. May block.	1931	player. May block.
1650		1932
1651	=cut	1933	=cut
1652		1934
…		…
1673		1955
1674	=item $protocol_xml = $player->expand_cfpod ($cfpod)	1956	=item $protocol_xml = $player->expand_cfpod ($cfpod)
1675		1957
1676	Expand deliantra pod fragments into protocol xml.	1958	Expand deliantra pod fragments into protocol xml.
1677		1959
1678	=item $player->ext_reply ($msgid, @msg)
1679
1680	Sends an ext reply to the player.
1681
1682	=cut
1683
1684	sub ext_reply($$@) {
1685	my ($self, $id, @msg) = @_;
1686
1687	$self->ns->ext_reply ($id, @msg)
1688	}
1689
1690	=item $player->ext_msg ($type, @msg)	1960	=item $player->ext_msg ($type, @msg)
1691		1961
1692	Sends an ext event to the client.	1962	Sends an ext event to the client.
1693		1963
1694	=cut	1964	=cut
…		…
1713		1983
1714	=cut	1984	=cut
1715		1985
1716	sub find_by_path($) {	1986	sub find_by_path($) {
1717	my ($path) = @_;	1987	my ($path) = @_;
		1988
		1989	$path =~ s/^~[^\/]*//; # skip ~login
1718		1990
1719	my ($match, $specificity);	1991	my ($match, $specificity);
1720		1992
1721	for my $region (list) {	1993	for my $region (list) {
1722	if ($region->{match} && $path =~ $region->{match}) {	1994	if ($region->{match} && $path =~ $region->{match}) {
…		…
1751	sub generate_random_map {	2023	sub generate_random_map {
1752	my ($self, $rmp) = @_;	2024	my ($self, $rmp) = @_;
1753		2025
1754	my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM	2026	my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1755		2027
1756	# mit "rum" bekleckern, nicht
1757	$self->_create_random_map (	2028	$self->_create_random_map ($rmp);
1758	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1759	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1760	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1761	$rmp->{exit_on_final_map},
1762	$rmp->{xsize}, $rmp->{ysize},
1763	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1764	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1765	$rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1766	$rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1767	$rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1768	(cf::region::find $rmp->{region}), $rmp->{custom}
1769	)
1770	}	2029	}
1771		2030
1772	=item cf::map->register ($regex, $prio)	2031	=item cf::map->register ($regex, $prio)
1773		2032
1774	Register a handler for the map path matching the given regex at the	2033	Register a handler for the map path matching the given regex at the
…		…
1779		2038
1780	sub register {	2039	sub register {
1781	my (undef, $regex, $prio) = @_;	2040	my (undef, $regex, $prio) = @_;
1782	my $pkg = caller;	2041	my $pkg = caller;
1783		2042
1784	no strict;
1785	push @{"$pkg\::ISA"}, __PACKAGE__;	2043	push @{"$pkg\::ISA"}, __PACKAGE__;
1786		2044
1787	$EXT_MAP{$pkg} = [$prio, qr<$regex>];	2045	$EXT_MAP{$pkg} = [$prio, qr<$regex>];
1788	}	2046	}
1789		2047
1790	# also paths starting with '/'	2048	# also paths starting with '/'
1791	$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];	2049	$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1792		2050
1793	sub thawer_merge {	2051	sub thawer_merge {
1794	my ($self, $merge) = @_;	2052	my ($self, $merge) = @_;
1795		2053
1796	# we have to keep some variables in memory intact	2054	# we have to keep some variables in memory intact
…		…
1801	}	2059	}
1802		2060
1803	sub normalise {	2061	sub normalise {
1804	my ($path, $base) = @_;	2062	my ($path, $base) = @_;
1805		2063
1806	$path = "$path"; # make sure its a string	2064	$path = "$path"; # make sure it's a string
1807		2065
1808	$path =~ s/\.map$//;	2066	$path =~ s/\.map$//;
1809		2067
1810	# map plan:	2068	# map plan:
1811	#	2069	#
…		…
1826	$base =~ s{[^/]+/?$}{};	2084	$base =~ s{[^/]+/?$}{};
1827	$path = "$base/$path";	2085	$path = "$base/$path";
1828	}	2086	}
1829		2087
1830	for ($path) {	2088	for ($path) {
1831	redo if s{//}{/};
1832	redo if s{/\.?/}{/};	2089	redo if s{/\.?/}{/};
1833	redo if s{/[^/]+/\.\./}{/};	2090	redo if s{/[^/]+/\.\./}{/};
1834	}	2091	}
1835		2092
1836	$path	2093	$path
…		…
1850	$self->init; # pass $1 etc.	2107	$self->init; # pass $1 etc.
1851	return $self;	2108	return $self;
1852	}	2109	}
1853	}	2110	}
1854		2111
1855	Carp::cluck "unable to resolve path '$path' (base '$base').";	2112	Carp::cluck "unable to resolve path '$path' (base '$base')";
1856	()	2113	()
1857	}	2114	}
1858		2115
		2116	# may re-bless or do other evil things
1859	sub init {	2117	sub init {
1860	my ($self) = @_;	2118	my ($self) = @_;
1861		2119
1862	$self	2120	$self
1863	}	2121	}
…		…
1928	$self->{load_path} = $path;	2186	$self->{load_path} = $path;
1929		2187
1930	1	2188	1
1931	}	2189	}
1932		2190
		2191	# used to laod the header of an original map
1933	sub load_header_orig {	2192	sub load_header_orig {
1934	my ($self) = @_;	2193	my ($self) = @_;
1935		2194
1936	$self->load_header_from ($self->load_path)	2195	$self->load_header_from ($self->load_path)
1937	}	2196	}
1938		2197
		2198	# used to laod the header of an instantiated map
1939	sub load_header_temp {	2199	sub load_header_temp {
1940	my ($self) = @_;	2200	my ($self) = @_;
1941		2201
1942	$self->load_header_from ($self->save_path)	2202	$self->load_header_from ($self->save_path)
1943	}	2203	}
1944		2204
		2205	# called after loading the header from an instantiated map
1945	sub prepare_temp {	2206	sub prepare_temp {
1946	my ($self) = @_;	2207	my ($self) = @_;
1947		2208
1948	$self->last_access ((delete $self->{last_access})	2209	$self->last_access ((delete $self->{last_access})
1949	|| $cf::RUNTIME); #d#	2210	|| $cf::RUNTIME); #d#
1950	# safety	2211	# safety
1951	$self->{instantiate_time} = $cf::RUNTIME	2212	$self->{instantiate_time} = $cf::RUNTIME
1952	if $self->{instantiate_time} > $cf::RUNTIME;	2213	if $self->{instantiate_time} > $cf::RUNTIME;
1953	}	2214	}
1954		2215
		2216	# called after loading the header from an original map
1955	sub prepare_orig {	2217	sub prepare_orig {
1956	my ($self) = @_;	2218	my ($self) = @_;
1957		2219
1958	$self->{load_original} = 1;	2220	$self->{load_original} = 1;
1959	$self->{instantiate_time} = $cf::RUNTIME;	2221	$self->{instantiate_time} = $cf::RUNTIME;
…		…
1983		2245
1984	sub find;	2246	sub find;
1985	sub find {	2247	sub find {
1986	my ($path, $origin) = @_;	2248	my ($path, $origin) = @_;
1987		2249
		2250	cf::cede_to_tick;
		2251
1988	$path = normalise $path, $origin && $origin->path;	2252	$path = normalise $path, $origin;
1989		2253
1990	my $guard1 = cf::lock_acquire "map_data:$path";#d#remove	2254	my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1991	my $guard2 = cf::lock_acquire "map_find:$path";	2255	my $guard2 = cf::lock_acquire "map_find:$path";
1992		2256
1993	$cf::MAP{$path} || do {	2257	$cf::MAP{$path} || do {
…		…
2010		2274
2011	$cf::MAP{$path} = $map	2275	$cf::MAP{$path} = $map
2012	}	2276	}
2013	}	2277	}
2014		2278
2015	sub pre_load { }	2279	sub pre_load { }
2016	sub post_load { }	2280	#sub post_load { } # XS
2017		2281
2018	sub load {	2282	sub load {
2019	my ($self) = @_;	2283	my ($self) = @_;
2020		2284
2021	local $self->{deny_reset} = 1; # loading can take a long time	2285	local $self->{deny_reset} = 1; # loading can take a long time
…		…
2024		2288
2025	{	2289	{
2026	my $guard = cf::lock_acquire "map_data:$path";	2290	my $guard = cf::lock_acquire "map_data:$path";
2027		2291
2028	return unless $self->valid;	2292	return unless $self->valid;
2029	return unless $self->in_memory == cf::MAP_SWAPPED;	2293	return unless $self->state == cf::MAP_SWAPPED;
2030
2031	$self->in_memory (cf::MAP_LOADING);
2032		2294
2033	$self->alloc;	2295	$self->alloc;
2034		2296
2035	$self->pre_load;	2297	$self->pre_load;
2036	cf::cede_to_tick;	2298	cf::cede_to_tick;
2037		2299
		2300	if (exists $self->{load_path}) {
2038	my $f = new_from_file cf::object::thawer $self->{load_path};	2301	my $f = new_from_file cf::object::thawer $self->{load_path};
2039	$f->skip_block;	2302	$f->skip_block;
2040	$self->_load_objects ($f)	2303	$self->_load_objects ($f)
2041	or return;	2304	or return;
2042		2305
2043	$self->post_load_original	2306	$self->post_load_original
2044	if delete $self->{load_original};	2307	if delete $self->{load_original};
2045		2308
2046	if (my $uniq = $self->uniq_path) {	2309	if (my $uniq = $self->uniq_path) {
2047	utf8::encode $uniq;	2310	utf8::encode $uniq;
2048	unless (aio_stat $uniq) {	2311	unless (aio_stat $uniq) {
2049	if (my $f = new_from_file cf::object::thawer $uniq) {	2312	if (my $f = new_from_file cf::object::thawer $uniq) {
2050	$self->clear_unique_items;	2313	$self->clear_unique_items;
2051	$self->_load_objects ($f);	2314	$self->_load_objects ($f);
2052	$f->resolve_delayed_derefs;	2315	$f->resolve_delayed_derefs;
		2316	}
2053	}	2317	}
2054	}	2318	}
2055	}
2056		2319
2057	$f->resolve_delayed_derefs;	2320	$f->resolve_delayed_derefs;
		2321	} else {
		2322	$self->post_load_original
		2323	if delete $self->{load_original};
		2324	}
		2325
		2326	$self->state (cf::MAP_INACTIVE);
2058		2327
2059	cf::cede_to_tick;	2328	cf::cede_to_tick;
2060	# now do the right thing for maps	2329	# now do the right thing for maps
2061	$self->link_multipart_objects;	2330	$self->link_multipart_objects;
2062	$self->difficulty ($self->estimate_difficulty)	2331	$self->difficulty ($self->estimate_difficulty)
…		…
2066	unless ($self->{deny_activate}) {	2335	unless ($self->{deny_activate}) {
2067	$self->decay_objects;	2336	$self->decay_objects;
2068	$self->fix_auto_apply;	2337	$self->fix_auto_apply;
2069	$self->update_buttons;	2338	$self->update_buttons;
2070	cf::cede_to_tick;	2339	cf::cede_to_tick;
2071	$self->activate;	2340	#$self->activate; # no longer activate maps automatically
2072	}	2341	}
2073		2342
2074	$self->{last_save} = $cf::RUNTIME;	2343	$self->{last_save} = $cf::RUNTIME;
2075	$self->last_access ($cf::RUNTIME);	2344	$self->last_access ($cf::RUNTIME);
2076
2077	$self->in_memory (cf::MAP_ACTIVE);
2078	}	2345	}
2079		2346
2080	$self->post_load;	2347	$self->post_load;
2081	}
2082		2348
		2349	1
		2350	}
		2351
		2352	# customize the map for a given player, i.e.
		2353	# return the _real_ map. used by e.g. per-player
		2354	# maps to change the path to ~playername/mappath
2083	sub customise_for {	2355	sub customise_for {
2084	my ($self, $ob) = @_;	2356	my ($self, $ob) = @_;
2085		2357
2086	return find "~" . $ob->name . "/" . $self->{path}	2358	return find "~" . $ob->name . "/" . $self->{path}
2087	if $self->per_player;	2359	if $self->per_player;
…		…
2090	# if $self->per_party;	2362	# if $self->per_party;
2091		2363
2092	$self	2364	$self
2093	}	2365	}
2094		2366
2095	# find and load all maps in the 3x3 area around a map
2096	sub load_neighbours {
2097	my ($map) = @_;
2098
2099	my @neigh; # diagonal neighbours
2100
2101	for (0 .. 3) {
2102	my $neigh = $map->tile_path ($_)
2103	or next;
2104	$neigh = find $neigh, $map
2105	or next;
2106	$neigh->load;
2107
2108	push @neigh,
2109	[$neigh->tile_path (($_ + 3) % 4), $neigh],
2110	[$neigh->tile_path (($_ + 1) % 4), $neigh];
2111	}
2112
2113	for (grep defined $_->[0], @neigh) {
2114	my ($path, $origin) = @$_;
2115	my $neigh = find $path, $origin
2116	or next;
2117	$neigh->load;
2118	}
2119	}
2120
2121	sub find_sync {	2367	sub find_sync {
2122	my ($path, $origin) = @_;	2368	my ($path, $origin) = @_;
2123		2369
2124	cf::sync_job { find $path, $origin }	2370	# it's a bug to call this from the main context
		2371	return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
		2372	if $Coro::current == $Coro::main;
		2373
		2374	find $path, $origin
2125	}	2375	}
2126		2376
2127	sub do_load_sync {	2377	sub do_load_sync {
2128	my ($map) = @_;	2378	my ($map) = @_;
2129		2379
		2380	# it's a bug to call this from the main context
2130	cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"	2381	return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2131	if $Coro::current == $Coro::main;	2382	if $Coro::current == $Coro::main;
2132		2383
2133	cf::sync_job { $map->load };	2384	$map->load;
2134	}	2385	}
2135		2386
2136	our %MAP_PREFETCH;	2387	our %MAP_PREFETCH;
2137	our $MAP_PREFETCHER = undef;	2388	our $MAP_PREFETCHER = undef;
2138		2389
2139	sub find_async {	2390	sub find_async {
2140	my ($path, $origin, $load) = @_;	2391	my ($path, $origin, $load) = @_;
2141		2392
2142	$path = normalise $path, $origin && $origin->{path};	2393	$path = normalise $path, $origin;
2143		2394
2144	if (my $map = $cf::MAP{$path}) {	2395	if (my $map = $cf::MAP{$path}) {
2145	return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;	2396	return $map if !$load || $map->linkable;
2146	}	2397	}
2147		2398
2148	$MAP_PREFETCH{$path} |= $load;	2399	$MAP_PREFETCH{$path} |= $load;
2149		2400
2150	$MAP_PREFETCHER ||= cf::async {	2401	$MAP_PREFETCHER ||= cf::async {
2151	$Coro::current->{desc} = "map prefetcher";	2402	$Coro::current->{desc} = "map prefetcher";
2152		2403
2153	while (%MAP_PREFETCH) {	2404	while (%MAP_PREFETCH) {
2154	while (my ($k, $v) = each %MAP_PREFETCH) {	2405	for my $k (keys %MAP_PREFETCH) {
2155	if (my $map = find $k) {	2406	if (my $map = find $k) {
2156	$map->load if $v;	2407	$map->load if $MAP_PREFETCH{$k};
2157	}	2408	}
2158		2409
2159	delete $MAP_PREFETCH{$k};	2410	delete $MAP_PREFETCH{$k};
2160	}	2411	}
2161	}	2412	}
…		…
2164	$MAP_PREFETCHER->prio (6);	2415	$MAP_PREFETCHER->prio (6);
2165		2416
2166	()	2417	()
2167	}	2418	}
2168		2419
		2420	# common code, used by both ->save and ->swapout
2169	sub save {	2421	sub _save {
2170	my ($self) = @_;	2422	my ($self) = @_;
2171
2172	my $lock = cf::lock_acquire "map_data:$self->{path}";
2173		2423
2174	$self->{last_save} = $cf::RUNTIME;	2424	$self->{last_save} = $cf::RUNTIME;
2175		2425
2176	return unless $self->dirty;	2426	return unless $self->dirty;
2177		2427
…		…
2197	} else {	2447	} else {
2198	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);	2448	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2199	}	2449	}
2200	}	2450	}
2201		2451
		2452	sub save {
		2453	my ($self) = @_;
		2454
		2455	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2456
		2457	$self->_save;
		2458	}
		2459
2202	sub swap_out {	2460	sub swap_out {
2203	my ($self) = @_;	2461	my ($self) = @_;
2204		2462
2205	# save first because save cedes
2206	$self->save;
2207
2208	my $lock = cf::lock_acquire "map_data:$self->{path}";	2463	my $lock = cf::lock_acquire "map_data:$self->{path}";
2209		2464
		2465	return if !$self->linkable;
		2466	return if $self->{deny_save};
2210	return if $self->players;	2467	return if $self->players;
2211	return if $self->in_memory != cf::MAP_ACTIVE;	2468
		2469	# first deactivate the map and "unlink" it from the core
		2470	$self->deactivate;
		2471	$_->clear_links_to ($self) for values %cf::MAP;
		2472	$self->state (cf::MAP_SWAPPED);
		2473
		2474	# then atomically save
		2475	$self->_save;
		2476
		2477	# then free the map
		2478	$self->clear;
		2479	}
		2480
		2481	sub reset_at {
		2482	my ($self) = @_;
		2483
		2484	# TODO: safety, remove and allow resettable per-player maps
2212	return if $self->{deny_save};	2485	return 1e99 if $self->{deny_reset};
2213		2486
		2487	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
		2488	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
		2489
		2490	$time + $to
		2491	}
		2492
		2493	sub should_reset {
		2494	my ($self) = @_;
		2495
		2496	$self->reset_at <= $cf::RUNTIME
		2497	}
		2498
		2499	sub reset {
		2500	my ($self) = @_;
		2501
		2502	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2503
		2504	return if $self->players;
		2505
		2506	cf::trace "resetting map ", $self->path, "\n";
		2507
2214	$self->in_memory (cf::MAP_SWAPPED);	2508	$self->state (cf::MAP_SWAPPED);
		2509
		2510	# need to save uniques path
		2511	unless ($self->{deny_save}) {
		2512	my $uniq = $self->uniq_path; utf8::encode $uniq;
		2513
		2514	$self->_save_objects ($uniq, cf::IO_UNIQUES)
		2515	if $uniq;
		2516	}
		2517
		2518	delete $cf::MAP{$self->path};
2215		2519
2216	$self->deactivate;	2520	$self->deactivate;
2217	$_->clear_links_to ($self) for values %cf::MAP;	2521	$_->clear_links_to ($self) for values %cf::MAP;
2218	$self->clear;	2522	$self->clear;
2219	}
2220
2221	sub reset_at {
2222	my ($self) = @_;
2223
2224	# TODO: safety, remove and allow resettable per-player maps
2225	return 1e99 if $self->{deny_reset};
2226
2227	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2228	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2229
2230	$time + $to
2231	}
2232
2233	sub should_reset {
2234	my ($self) = @_;
2235
2236	$self->reset_at <= $cf::RUNTIME
2237	}
2238
2239	sub reset {
2240	my ($self) = @_;
2241
2242	my $lock = cf::lock_acquire "map_data:$self->{path}";
2243
2244	return if $self->players;
2245
2246	warn "resetting map ", $self->path, "\n";
2247
2248	$self->in_memory (cf::MAP_SWAPPED);
2249
2250	# need to save uniques path
2251	unless ($self->{deny_save}) {
2252	my $uniq = $self->uniq_path; utf8::encode $uniq;
2253
2254	$self->_save_objects ($uniq, cf::IO_UNIQUES)
2255	if $uniq;
2256	}
2257
2258	delete $cf::MAP{$self->path};
2259
2260	$self->deactivate;
2261	$_->clear_links_to ($self) for values %cf::MAP;
2262	$self->clear;
2263		2523
2264	$self->unlink_save;	2524	$self->unlink_save;
2265	$self->destroy;	2525	$self->destroy;
2266	}	2526	}
2267		2527
…		…
2275		2535
2276	delete $cf::MAP{$self->path};	2536	delete $cf::MAP{$self->path};
2277		2537
2278	$self->unlink_save;	2538	$self->unlink_save;
2279		2539
2280	bless $self, "cf::map";	2540	bless $self, "cf::map::wrap";
2281	delete $self->{deny_reset};	2541	delete $self->{deny_reset};
2282	$self->{deny_save} = 1;	2542	$self->{deny_save} = 1;
2283	$self->reset_timeout (1);	2543	$self->reset_timeout (1);
2284	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2544	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2285		2545
…		…
2406		2666
2407	Creates and returns a persistent reference to an object that can be stored as a string.	2667	Creates and returns a persistent reference to an object that can be stored as a string.
2408		2668
2409	=item $ob = cf::object::deref ($refstring)	2669	=item $ob = cf::object::deref ($refstring)
2410		2670
2411	returns the objetc referenced by refstring. may return undef when it cnanot find the object,	2671	returns the objetc referenced by refstring. may return undef when it cannot find the object,
2412	even if the object actually exists. May block.	2672	even if the object actually exists. May block.
2413		2673
2414	=cut	2674	=cut
2415		2675
2416	sub deref {	2676	sub deref {
…		…
2498	=item $player_object->may ("access")	2758	=item $player_object->may ("access")
2499		2759
2500	Returns wether the given player is authorized to access resource "access"	2760	Returns wether the given player is authorized to access resource "access"
2501	(e.g. "command_wizcast").	2761	(e.g. "command_wizcast").
2502		2762
		2763	This is implemented by checking a config setting of C<may_access> where
		2764	C<access> is replaced by the access string. The following alternatives are
		2765	possible (and are tested in order):
		2766
		2767	=over 4
		2768
		2769	=item * Player is DM
		2770
		2771	The request will succeed.
		2772
		2773	=item * may_access is an array reference
		2774
		2775	If either the player nickname or UUID is in the array, the request will
		2776	succeed, otherwise it will fail.
		2777
		2778	=item * may_access is a true value
		2779
		2780	The request will succeed.
		2781
		2782	=item * may_access is missing or false
		2783
		2784	The request will fail.
		2785
		2786	=back
		2787
2503	=cut	2788	=cut
2504		2789
2505	sub cf::object::player::may {	2790	sub cf::object::player::may {
2506	my ($self, $access) = @_;	2791	my ($self, $access) = @_;
2507		2792
2508	$self->flag (cf::FLAG_WIZ) ||	2793	$self->flag (cf::FLAG_WIZ) ||
2509	(ref $cf::CFG{"may_$access"}	2794	(ref $cf::CFG{"may_$access"}
2510	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}	2795	? scalar grep $self->name eq $_ || $self->uuid eq $_, @{$cf::CFG{"may_$access"}}
2511	: $cf::CFG{"may_$access"})	2796	: $cf::CFG{"may_$access"})
2512	}	2797	}
2513		2798
2514	=item $player_object->enter_link	2799	=item $player_object->enter_link
2515		2800
2516	Freezes the player and moves him/her to a special map (C<{link}>).	2801	Freezes the player and moves him/her to a special map (C<{link}>).
2517		2802
2518	The player should be reasonably safe there for short amounts of time (e.g.	2803	The player should be reasonably safe there for short amounts of time (e.g.
2519	for loading a map). You I<MUST> call C<leave_link> as soon as possible,	2804	for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2520	though, as the palyer cannot control the character while it is on the link	2805	though, as the player cannot control the character while it is on the link
2521	map.	2806	map.
2522		2807
2523	Will never block.	2808	This method will never block, which is the whole reaosn for it's
		2809	existance: you can I<always> put a player onto the link map, which is the
		2810	only place to put objects that is guaranteed to exist.
		2811
		2812	A typical usage pattern is to call C<enter_link> synchronously from the
		2813	server, then start a new thread, do your blocking stuff there and then
		2814	call C<leave_link> from that thread.
2524		2815
2525	=item $player_object->leave_link ($map, $x, $y)	2816	=item $player_object->leave_link ($map, $x, $y)
2526		2817
2527	Moves the player out of the special C<{link}> map onto the specified	2818	Moves the player out of the special C<{link}> map onto the specified
2528	map. If the map is not valid (or omitted), the player will be moved back	2819	map. If the map is not valid (or omitted), the player will be moved back
…		…
2546	sub cf::object::player::enter_link {	2837	sub cf::object::player::enter_link {
2547	my ($self) = @_;	2838	my ($self) = @_;
2548		2839
2549	$self->deactivate_recursive;	2840	$self->deactivate_recursive;
2550		2841
		2842	++$self->{_link_recursion};
		2843
2551	return if UNIVERSAL::isa $self->map, "ext::map_link";	2844	return if UNIVERSAL::isa $self->map, "ext::map_link";
2552		2845
2553	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]	2846	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2554	if $self->map && $self->map->{path} ne "{link}";	2847	if $self->map && $self->map->{path} ne "{link}";
2555		2848
2556	$self->enter_map ($LINK_MAP || link_map, 10, 10);	2849	$self->enter_map ($LINK_MAP || link_map, 3, 3);
2557	}	2850	}
2558		2851
2559	sub cf::object::player::leave_link {	2852	sub cf::object::player::leave_link {
2560	my ($self, $map, $x, $y) = @_;	2853	my ($self, $map, $x, $y) = @_;
2561		2854
…		…
2581	# use -1 or undef as default coordinates, not 0, 0	2874	# use -1 or undef as default coordinates, not 0, 0
2582	($x, $y) = ($map->enter_x, $map->enter_y)	2875	($x, $y) = ($map->enter_x, $map->enter_y)
2583	if $x <= 0 && $y <= 0;	2876	if $x <= 0 && $y <= 0;
2584		2877
2585	$map->load;	2878	$map->load;
2586	$map->load_neighbours;
2587		2879
2588	return unless $self->contr->active;	2880	return unless $self->contr->active;
2589		2881
2590	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2882	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2591	$self->enter_map ($map, $x, $y);	2883	if ($self->enter_map ($map, $x, $y)) {
2592		2884	# entering was successful
		2885	delete $self->{_link_recursion};
2593	# only activate afterwards, to support waiting in hooks	2886	# only activate afterwards, to support waiting in hooks
2594	$self->activate_recursive;	2887	$self->activate_recursive;
2595	}	2888	}
2596		2889
		2890	}
		2891
2597	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])	2892	=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2598		2893
2599	Moves the player to the given map-path and coordinates by first freezing	2894	Moves the player to the given map-path and coordinates by first freezing
2600	her, loading and preparing them map, calling the provided $check callback	2895	her, loading and preparing them map, calling the provided $check callback
2601	that has to return the map if sucecssful, and then unfreezes the player on	2896	that has to return the map if sucecssful, and then unfreezes the player on
2602	the new (success) or old (failed) map position. In either case, $done will	2897	the new (success) or old (failed) map position. In either case, $done will
…		…
2609		2904
2610	our $GOTOGEN;	2905	our $GOTOGEN;
2611		2906
2612	sub cf::object::player::goto {	2907	sub cf::object::player::goto {
2613	my ($self, $path, $x, $y, $check, $done) = @_;	2908	my ($self, $path, $x, $y, $check, $done) = @_;
		2909
		2910	if ($self->{_link_recursion} >= $MAX_LINKS) {
		2911	error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
		2912	$self->failmsg ("Something went wrong inside the server - please contact an administrator!");
		2913	($path, $x, $y) = @$EMERGENCY_POSITION;
		2914	}
2614		2915
2615	# do generation counting so two concurrent goto's will be executed in-order	2916	# do generation counting so two concurrent goto's will be executed in-order
2616	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2917	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2617		2918
2618	$self->enter_link;	2919	$self->enter_link;
…		…
2638	($path, $x, $y) = (undef, undef, undef);	2939	($path, $x, $y) = (undef, undef, undef);
2639	}	2940	}
2640	}	2941	}
2641		2942
2642	my $map = eval {	2943	my $map = eval {
2643	my $map = defined $path ? cf::map::find $path : undef;	2944	my $map = defined $path ? cf::map::find $path, $self->map : undef;
2644		2945
2645	if ($map) {	2946	if ($map) {
2646	$map = $map->customise_for ($self);	2947	$map = $map->customise_for ($self);
2647	$map = $check->($map) if $check && $map;	2948	$map = $check->($map, $x, $y, $self) if $check && $map;
2648	} else {	2949	} else {
2649	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);	2950	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2650	}	2951	}
2651		2952
2652	$map	2953	$map
…		…
2660	if ($gen == $self->{_goto_generation}) {	2961	if ($gen == $self->{_goto_generation}) {
2661	delete $self->{_goto_generation};	2962	delete $self->{_goto_generation};
2662	$self->leave_link ($map, $x, $y);	2963	$self->leave_link ($map, $x, $y);
2663	}	2964	}
2664		2965
2665	$done->() if $done;	2966	$done->($self) if $done;
2666	})->prio (1);	2967	})->prio (1);
2667	}	2968	}
2668		2969
2669	=item $player_object->enter_exit ($exit_object)	2970	=item $player_object->enter_exit ($exit_object)
2670		2971
…		…
2738	$Coro::current->{desc} = "enter_exit";	3039	$Coro::current->{desc} = "enter_exit";
2739		3040
2740	unless (eval {	3041	unless (eval {
2741	$self->deactivate_recursive; # just to be sure	3042	$self->deactivate_recursive; # just to be sure
2742		3043
2743	# random map handling
2744	{
2745	my $guard = cf::lock_acquire "exit_prepare:$exit";
2746
2747	prepare_random_map $exit
2748	if $exit->slaying eq "/!";
2749	}
2750
2751	my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;	3044	my $map = cf::map::normalise $exit->slaying, $exit->map;
2752	my $x = $exit->stats->hp;	3045	my $x = $exit->stats->hp;
2753	my $y = $exit->stats->sp;	3046	my $y = $exit->stats->sp;
		3047
		3048	# special map handling
		3049	my $slaying = $exit->slaying;
		3050
		3051	# special map handling
		3052	if ($slaying eq "/!") {
		3053	my $guard = cf::lock_acquire "exit_prepare:$exit";
		3054
		3055	prepare_random_map $exit
		3056	if $exit->slaying eq "/!"; # need to re-check after getting the lock
		3057
		3058	$map = $exit->slaying;
		3059
		3060	} elsif ($slaying eq '!up') {
		3061	$map = $exit->map->tile_path (cf::TILE_UP);
		3062	$x = $exit->x;
		3063	$y = $exit->y;
		3064
		3065	} elsif ($slaying eq '!down') {
		3066	$map = $exit->map->tile_path (cf::TILE_DOWN);
		3067	$x = $exit->x;
		3068	$y = $exit->y;
		3069	}
2754		3070
2755	$self->goto ($map, $x, $y);	3071	$self->goto ($map, $x, $y);
2756		3072
2757	# if exit is damned, update players death & WoR home-position	3073	# if exit is damned, update players death & WoR home-position
2758	$self->contr->savebed ($map, $x, $y)	3074	$self->contr->savebed ($map, $x, $y)
…		…
2763	$self->message ("Something went wrong deep within the deliantra server. "	3079	$self->message ("Something went wrong deep within the deliantra server. "
2764	. "I'll try to bring you back to the map you were before. "	3080	. "I'll try to bring you back to the map you were before. "
2765	. "Please report this to the dungeon master!",	3081	. "Please report this to the dungeon master!",
2766	cf::NDI_UNIQUE | cf::NDI_RED);	3082	cf::NDI_UNIQUE | cf::NDI_RED);
2767		3083
2768	warn "ERROR in enter_exit: $@";	3084	error "ERROR in enter_exit: $@";
2769	$self->leave_link;	3085	$self->leave_link;
2770	}	3086	}
2771	})->prio (1);	3087	})->prio (1);
2772	}	3088	}
2773		3089
2774	=head3 cf::client	3090	=head3 cf::client
2775		3091
2776	=over 4	3092	=over 4
2777
2778	=item $client->send_drawinfo ($text, $flags)
2779
2780	Sends a drawinfo packet to the client. Circumvents output buffering so
2781	should not be used under normal circumstances.
2782
2783	=cut
2784
2785	sub cf::client::send_drawinfo {
2786	my ($self, $text, $flags) = @_;
2787
2788	utf8::encode $text;
2789	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2790	}
2791		3093
2792	=item $client->send_big_packet ($pkt)	3094	=item $client->send_big_packet ($pkt)
2793		3095
2794	Like C<send_packet>, but tries to compress large packets, and fragments	3096	Like C<send_packet>, but tries to compress large packets, and fragments
2795	them as required.	3097	them as required.
…		…
2814	$self->send_packet ($pkt);	3116	$self->send_packet ($pkt);
2815	}	3117	}
2816		3118
2817	=item $client->send_msg ($channel, $msg, $color, [extra...])	3119	=item $client->send_msg ($channel, $msg, $color, [extra...])
2818		3120
2819	Send a drawinfo or msg packet to the client, formatting the msg for the	3121	Send a msg packet to the client, formatting the msg for the client if
2820	client if neccessary. C<$type> should be a string identifying the type of	3122	necessary. C<$type> should be a string identifying the type of the
2821	the message, with C<log> being the default. If C<$color> is negative, suppress	3123	message, with C<log> being the default. If C<$color> is negative, suppress
2822	the message unless the client supports the msg packet.	3124	the message unless the client supports the msg packet.
2823		3125
2824	=cut	3126	=cut
2825		3127
2826	# non-persistent channels (usually the info channel)	3128	# non-persistent channels (usually the info channel)
…		…
2869	},	3171	},
2870	"c/body" => {	3172	"c/body" => {
2871	id => "infobox",	3173	id => "infobox",
2872	title => "Body Parts",	3174	title => "Body Parts",
2873	reply => undef,	3175	reply => undef,
2874	tooltip => "Shows which body parts you posess and are available",	3176	tooltip => "Shows which body parts you possess and are available",
2875	},	3177	},
2876	"c/statistics" => {	3178	"c/statistics" => {
2877	id => "infobox",	3179	id => "infobox",
2878	title => "Statistics",	3180	title => "Statistics",
2879	reply => undef,	3181	reply => undef,
…		…
2931	id => "death",	3233	id => "death",
2932	title => "Death",	3234	title => "Death",
2933	reply => undef,	3235	reply => undef,
2934	tooltip => "Reason for and more info about your most recent death",	3236	tooltip => "Reason for and more info about your most recent death",
2935	},	3237	},
		3238	"c/fatal" => {
		3239	id => "fatal",
		3240	title => "Fatal Error",
		3241	reply => undef,
		3242	tooltip => "Reason for the server disconnect",
		3243	},
2936	"c/say" => $SAY_CHANNEL,	3244	"c/say" => $SAY_CHANNEL,
2937	"c/chat" => $CHAT_CHANNEL,	3245	"c/chat" => $CHAT_CHANNEL,
2938	);	3246	);
2939		3247
2940	sub cf::client::send_msg {	3248	sub cf::client::send_msg {
…		…
2983	=cut	3291	=cut
2984		3292
2985	sub cf::client::ext_msg($$@) {	3293	sub cf::client::ext_msg($$@) {
2986	my ($self, $type, @msg) = @_;	3294	my ($self, $type, @msg) = @_;
2987		3295
2988	if ($self->extcmd == 2) {
2989	$self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));	3296	$self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2990	} elsif ($self->extcmd == 1) { # TODO: remove
2991	push @msg, msgtype => "event_$type";
2992	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2993	}
2994	}
2995
2996	=item $client->ext_reply ($msgid, @msg)
2997
2998	Sends an ext reply to the client.
2999
3000	=cut
3001
3002	sub cf::client::ext_reply($$@) {
3003	my ($self, $id, @msg) = @_;
3004
3005	if ($self->extcmd == 2) {
3006	$self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3007	} elsif ($self->extcmd == 1) {
3008	#TODO: version 1, remove
3009	unshift @msg, msgtype => "reply", msgid => $id;
3010	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3011	}
3012	}	3297	}
3013		3298
3014	=item $success = $client->query ($flags, "text", \&cb)	3299	=item $success = $client->query ($flags, "text", \&cb)
3015		3300
3016	Queues a query to the client, calling the given callback with	3301	Queues a query to the client, calling the given callback with
…		…
3036		3321
3037	$self->send_packet ($self->{query_queue}[0][0])	3322	$self->send_packet ($self->{query_queue}[0][0])
3038	if @{ $self->{query_queue} } == 1;	3323	if @{ $self->{query_queue} } == 1;
3039		3324
3040	1	3325	1
		3326	}
		3327
		3328	=item $client->update_command_faces
		3329
		3330	=cut
		3331
		3332	our %COMMAND_FACE;
		3333
		3334	sub cf::client::update_command_faces {
		3335	my ($self) = @_;
		3336
		3337	my @faces = grep $_,
		3338	$COMMAND_FACE{preferred},
		3339	$COMMAND_FACE{standard},
		3340	$COMMAND_FACE{skill},
		3341	$self->pl->ob->flag (cf::FLAG_WIZ) ? $COMMAND_FACE{dm} : (),
		3342	$COMMAND_FACE{emote},
		3343	;
		3344
		3345	$self->send_face ($_)
		3346	for @faces;
		3347	$self->flush_fx;
		3348
		3349	$self->ext_msg (command_list => @faces);
		3350	}
		3351
		3352	=item cf::client::set_command_face $type, $commands
		3353
		3354	=cut
		3355
		3356	sub cf::client::set_command_face {
		3357	my ($type, $list) = @_;
		3358
		3359	my $idx = &cf::face::set ( #d# ugly forward reference
		3360	"command_list/$type" => cf::FT_RSRC,
		3361	JSON::XS->new->utf8->encode ([ sort @$list ])
		3362	);
		3363
		3364	$COMMAND_FACE{$type} = $idx;
3041	}	3365	}
3042		3366
3043	cf::client->attach (	3367	cf::client->attach (
3044	on_connect => sub {	3368	on_connect => sub {
3045	my ($ns) = @_;	3369	my ($ns) = @_;
…		…
3071	my ($ns, $buf) = @_;	3395	my ($ns, $buf) = @_;
3072		3396
3073	my $msg = eval { $ns->{json_coder}->decode ($buf) };	3397	my $msg = eval { $ns->{json_coder}->decode ($buf) };
3074		3398
3075	if (ref $msg) {	3399	if (ref $msg) {
3076	my ($type, $reply, @payload) =	3400	my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3077	"ARRAY" eq ref $msg
3078	? @$msg
3079	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3080		3401
3081	my @reply;
3082
3083	if (my $cb = $EXTICMD{$type}) {	3402	if (my $cb = $EXTIACMD{$type}) {
		3403	$cb->(
		3404	$ns,
		3405	sub {
		3406	$ns->ext_msg ("reply-$reply", @_)
		3407	if $reply;
		3408	},
		3409	@payload
		3410	);
		3411	} else {
		3412	my @reply;
		3413
		3414	if (my $cb = $EXTICMD{$type}) {
3084	@reply = $cb->($ns, @payload);	3415	@reply = $cb->($ns, @payload);
		3416	}
		3417
		3418	$ns->ext_msg ("reply-$reply", @reply)
		3419	if $reply;
3085	}	3420	}
3086
3087	$ns->ext_reply ($reply, @reply)
3088	if $reply;
3089
3090	} else {	3421	} else {
3091	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	3422	error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3092	}	3423	}
3093		3424
3094	cf::override;	3425	cf::override;
3095	},	3426	},
3096	);	3427	);
…		…
3116		3447
3117	$coro	3448	$coro
3118	}	3449	}
3119		3450
3120	cf::client->attach (	3451	cf::client->attach (
3121	on_destroy => sub {	3452	on_client_destroy => sub {
3122	my ($ns) = @_;	3453	my ($ns) = @_;
3123		3454
3124	$_->cancel for values %{ (delete $ns->{_coro}) || {} };	3455	$_->cancel for values %{ (delete $ns->{_coro}) || {} };
3125	},	3456	},
3126	);	3457	);
…		…
3142	our $safe_hole = new Safe::Hole;	3473	our $safe_hole = new Safe::Hole;
3143		3474
3144	$SIG{FPE} = 'IGNORE';	3475	$SIG{FPE} = 'IGNORE';
3145		3476
3146	$safe->permit_only (Opcode::opset qw(	3477	$safe->permit_only (Opcode::opset qw(
3147	:base_core :base_mem :base_orig :base_math	3478	:base_core :base_mem :base_orig :base_math :base_loop
3148	grepstart grepwhile mapstart mapwhile	3479	grepstart grepwhile mapstart mapwhile
3149	sort time	3480	sort time
3150	));	3481	));
3151		3482
3152	# here we export the classes and methods available to script code	3483	# here we export the classes and methods available to script code
…		…
3177	decrease split destroy change_exp value msg lore send_msg)],	3508	decrease split destroy change_exp value msg lore send_msg)],
3178	["cf::object::player" => qw(player)],	3509	["cf::object::player" => qw(player)],
3179	["cf::player" => qw(peaceful send_msg)],	3510	["cf::player" => qw(peaceful send_msg)],
3180	["cf::map" => qw(trigger)],	3511	["cf::map" => qw(trigger)],
3181	) {	3512	) {
3182	no strict 'refs';
3183	my ($pkg, @funs) = @$_;	3513	my ($pkg, @funs) = @$_;
3184	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	3514	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3185	for @funs;	3515	for @funs;
3186	}	3516	}
3187		3517
…		…
3204	$qcode =~ s/"/‟/g; # not allowed in #line filenames	3534	$qcode =~ s/"/‟/g; # not allowed in #line filenames
3205	$qcode =~ s/\n/\\n/g;	3535	$qcode =~ s/\n/\\n/g;
3206		3536
3207	%vars = (_dummy => 0) unless %vars;	3537	%vars = (_dummy => 0) unless %vars;
3208		3538
		3539	my @res;
3209	local $_;	3540	local $_;
3210	local @safe::cf::_safe_eval_args = values %vars;
3211		3541
3212	my $eval =	3542	my $eval =
3213	"do {\n"	3543	"do {\n"
3214	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"	3544	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3215	. "#line 0 \"{$qcode}\"\n"	3545	. "#line 0 \"{$qcode}\"\n"
3216	. $code	3546	. $code
3217	. "\n}"	3547	. "\n}"
3218	;	3548	;
3219		3549
		3550	if ($CFG{safe_eval}) {
3220	sub_generation_inc;	3551	sub_generation_inc;
		3552	local @safe::cf::_safe_eval_args = values %vars;
3221	my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);	3553	@res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3222	sub_generation_inc;	3554	sub_generation_inc;
		3555	} else {
		3556	local @cf::_safe_eval_args = values %vars;
		3557	@res = wantarray ? eval eval : scalar eval $eval;
		3558	}
3223		3559
3224	if ($@) {	3560	if ($@) {
3225	warn "$@";	3561	warn "$@",
3226	warn "while executing safe code '$code'\n";	3562	"while executing safe code '$code'\n",
3227	warn "with arguments " . (join " ", %vars) . "\n";	3563	"with arguments " . (join " ", %vars) . "\n";
3228	}	3564	}
3229		3565
3230	wantarray ? @res : $res[0]	3566	wantarray ? @res : $res[0]
3231	}	3567	}
3232		3568
…		…
3246	=cut	3582	=cut
3247		3583
3248	sub register_script_function {	3584	sub register_script_function {
3249	my ($fun, $cb) = @_;	3585	my ($fun, $cb) = @_;
3250		3586
3251	no strict 'refs';	3587	$fun = "safe::$fun" if $CFG{safe_eval};
3252	*{"safe::$fun"} = $safe_hole->wrap ($cb);	3588	*$fun = $safe_hole->wrap ($cb);
3253	}	3589	}
3254		3590
3255	=back	3591	=back
3256		3592
3257	=cut	3593	=cut
3258		3594
3259	#############################################################################	3595	#############################################################################
3260	# the server's init and main functions	3596	# the server's init and main functions
3261		3597
		3598	{
		3599	package cf::face;
		3600
		3601	our %HASH; # hash => idx
		3602	our @DATA; # dynamically-created facedata, only faceste 0 used
		3603	our @FOFS; # file offset, if > 0
		3604	our @SIZE; # size of face, in octets
		3605	our @META; # meta hash of face, if any
		3606	our $DATAFH; # facedata filehandle
		3607
		3608	# internal api, not finalised
		3609	sub set {
		3610	my ($name, $type, $data) = @_;
		3611
		3612	my $idx = cf::face::find $name;
		3613
		3614	if ($idx) {
		3615	delete $HASH{cf::face::get_csum $idx};
		3616	} else {
		3617	$idx = cf::face::alloc $name;
		3618	}
		3619
		3620	my $hash = cf::face::mangle_csum Digest::MD5::md5 $data;
		3621
		3622	cf::face::set_type $idx, $type;
		3623	cf::face::set_csum $idx, 0, $hash;
		3624
		3625	# we need to destroy the SV itself, not just modify it, as a running ix
		3626	# might hold a reference to it: "delete" achieves that.
		3627	delete $FOFS[0][$idx];
		3628	delete $DATA[0][$idx];
		3629	$DATA[0][$idx] = $data;
		3630	$SIZE[0][$idx] = length $data;
		3631	delete $META[$idx];
		3632	$HASH{$hash} = $idx;#d#
		3633
		3634	$idx
		3635	}
		3636
		3637	sub _get_data($$$) {
		3638	my ($idx, $set, $cb) = @_;
		3639
		3640	if (defined $DATA[$set][$idx]) {
		3641	$cb->($DATA[$set][$idx]);
		3642	} elsif (my $fofs = $FOFS[$set][$idx]) {
		3643	my $size = $SIZE[$set][$idx];
		3644	my $buf;
		3645	IO::AIO::aio_read $DATAFH, $fofs, $size, $buf, 0, sub {
		3646	if ($_[0] == $size) {
		3647	#cf::debug "read face $idx, $size from $fofs as ", length $buf;#d#
		3648	$cb->($buf);
		3649	} else {
		3650	cf::error "INTERNAL ERROR: unable to read facedata for face $idx#$set ($size, $fofs), ignoring request.";
		3651	}
		3652	};
		3653	} else {
		3654	cf::error "requested facedata for unknown face $idx#$set, ignoring.";
		3655	}
		3656	}
		3657
		3658	# rather ineffient
		3659	sub cf::face::get_data($;$) {
		3660	my ($idx, $set) = @_;
		3661
		3662	_get_data $idx, $set, Coro::rouse_cb;
		3663	Coro::rouse_wait
		3664	}
		3665
		3666	sub cf::face::ix {
		3667	my ($ns, $set, $idx, $pri) = @_;
		3668
		3669	_get_data $idx, $set, sub {
		3670	$ns->ix_send ($idx, $pri, $_[0]);
		3671	};
		3672	}
		3673	}
		3674
3262	sub load_facedata($) {	3675	sub load_facedata($) {
3263	my ($path) = @_;	3676	my ($path) = @_;
3264		3677
3265	# HACK to clear player env face cache, we need some signal framework
3266	# for this (global event?)
3267	%ext::player_env::MUSIC_FACE_CACHE = ();
3268
3269	my $enc = JSON::XS->new->utf8->canonical->relaxed;	3678	my $enc = JSON::XS->new->utf8->canonical->relaxed;
3270		3679
3271	warn "loading facedata from $path\n";	3680	trace "loading facedata from $path\n";
3272		3681
3273	my $facedata;	3682	my $facedata = decode_storable load_file "$path/faceinfo";
3274	0 < aio_load $path, $facedata
3275	or die "$path: $!";
3276
3277	$facedata = Coro::Storable::thaw $facedata;
3278		3683
3279	$facedata->{version} == 2	3684	$facedata->{version} == 2
3280	or cf::cleanup "$path: version mismatch, cannot proceed.";	3685	or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";
3281		3686
3282	# patch in the exptable	3687	my $fh = aio_open "$DATADIR/facedata", IO::AIO::O_RDONLY, 0
3283	$facedata->{resource}{"res/exp_table"} = {	3688	or cf::cleanup "$path/facedata: $!, cannot proceed.";
3284	type => FT_RSRC,	3689
3285	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),	3690	get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
3286	};	3691
3287	cf::cede_to_tick;	3692	# BEGIN ATOMIC
		3693	# from here on, everything must be atomic - no thread switch allowed
		3694	my $t1 = EV::time;
3288		3695
3289	{	3696	{
3290	my $faces = $facedata->{faceinfo};	3697	my $faces = $facedata->{faceinfo};
3291		3698
3292	while (my ($face, $info) = each %$faces) {	3699	for my $face (sort keys %$faces) {
		3700	my $info = $faces->{$face};
3293	my $idx = (cf::face::find $face) || cf::face::alloc $face;	3701	my $idx = (cf::face::find $face) || cf::face::alloc $face;
3294		3702
3295	cf::face::set_visibility $idx, $info->{visibility};	3703	cf::face::set_visibility $idx, $info->{visibility};
3296	cf::face::set_magicmap $idx, $info->{magicmap};	3704	cf::face::set_magicmap $idx, $info->{magicmap};
3297	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};	3705	cf::face::set_csum $idx, 0, $info->{hash64}; $cf::face::SIZE[0][$idx] = $info->{size64}; $cf::face::FOFS[0][$idx] = $info->{fofs64};
3298	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};	3706	cf::face::set_csum $idx, 1, $info->{hash32}; $cf::face::SIZE[1][$idx] = $info->{size32}; $cf::face::FOFS[1][$idx] = $info->{fofs32};
3299		3707	cf::face::set_csum $idx, 2, $info->{glyph}; $cf::face::DATA[2][$idx] = $info->{glyph};
3300	cf::cede_to_tick;	3708	$cf::face::HASH{$info->{hash64}} = $idx;
		3709	delete $cf::face::META[$idx];
3301	}	3710	}
3302		3711
3303	while (my ($face, $info) = each %$faces) {	3712	while (my ($face, $info) = each %$faces) {
3304	next unless $info->{smooth};	3713	next unless $info->{smooth};
3305		3714
…		…
3308		3717
3309	if (my $smooth = cf::face::find $info->{smooth}) {	3718	if (my $smooth = cf::face::find $info->{smooth}) {
3310	cf::face::set_smooth $idx, $smooth;	3719	cf::face::set_smooth $idx, $smooth;
3311	cf::face::set_smoothlevel $idx, $info->{smoothlevel};	3720	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3312	} else {	3721	} else {
3313	warn "smooth face '$info->{smooth}' not found for face '$face'";	3722	error "smooth face '$info->{smooth}' not found for face '$face'";
3314	}	3723	}
3315
3316	cf::cede_to_tick;
3317	}	3724	}
3318	}	3725	}
3319		3726
3320	{	3727	{
3321	my $anims = $facedata->{animinfo};	3728	my $anims = $facedata->{animinfo};
3322		3729
3323	while (my ($anim, $info) = each %$anims) {	3730	while (my ($anim, $info) = each %$anims) {
3324	cf::anim::set $anim, $info->{frames}, $info->{facings};	3731	cf::anim::set $anim, $info->{frames}, $info->{facings};
3325	cf::cede_to_tick;
3326	}	3732	}
3327		3733
3328	cf::anim::invalidate_all; # d'oh	3734	cf::anim::invalidate_all; # d'oh
3329	}	3735	}
3330		3736
3331	{	3737	{
3332	# TODO: for gcfclient pleasure, we should give resources
3333	# that gcfclient doesn't grok a >10000 face index.
3334	my $res = $facedata->{resource};	3738	my $res = $facedata->{resource};
3335		3739
3336	while (my ($name, $info) = each %$res) {	3740	while (my ($name, $info) = each %$res) {
3337	if (defined $info->{type}) {	3741	if (defined (my $type = $info->{type})) {
		3742	# TODO: different hash - must free and use new index, or cache ixface data queue
3338	my $idx = (cf::face::find $name) || cf::face::alloc $name;	3743	my $idx = (cf::face::find $name) || cf::face::alloc $name;
3339	my $data;
3340		3744
3341	if ($info->{type} & 1) {
3342	# prepend meta info
3343
3344	my $meta = $enc->encode ({
3345	name => $name,
3346	%{ $info->{meta} || {} },
3347	});
3348
3349	$data = pack "(w/a*)*", $meta, $info->{data};
3350	} else {
3351	$data = $info->{data};
3352	}
3353
3354	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3355	cf::face::set_type $idx, $info->{type};	3745	cf::face::set_type $idx, $type;
		3746	cf::face::set_csum $idx, 0, $info->{hash};
		3747	$cf::face::SIZE[0][$idx] = $info->{size};
		3748	$cf::face::FOFS[0][$idx] = $info->{fofs};
		3749	$cf::face::META[$idx] = $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
		3750	$cf::face::HASH{$info->{hash}} = $idx;
3356	} else {	3751	} else {
3357	$RESOURCE{$name} = $info;	3752	# $RESOURCE{$name} = $info; # unused
3358	}	3753	}
3359
3360	cf::cede_to_tick;
3361	}	3754	}
3362	}	3755	}
		3756
		3757	($fh, $cf::face::DATAFH) = ($cf::face::DATAFH, $fh);
		3758
		3759	# HACK to clear player env face cache, we need some signal framework
		3760	# for this (global event?)
		3761	%ext::player_env::MUSIC_FACE_CACHE = ();
		3762
		3763	# END ATOMIC
		3764
		3765	cf::debug "facedata atomic update time ", EV::time - $t1;
3363		3766
3364	cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);	3767	cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3365		3768
		3769	aio_close $fh if $fh; # close old facedata
		3770
3366	1	3771	1
3367	}	3772	}
3368
3369	cf::global->attach (on_resource_update => sub {
3370	if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3371	$soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3372
3373	for (0 .. SOUND_CAST_SPELL_0 - 1) {
3374	my $sound = $soundconf->{compat}[$_]
3375	or next;
3376
3377	my $face = cf::face::find "sound/$sound->[1]";
3378	cf::sound::set $sound->[0] => $face;
3379	cf::sound::old_sound_index $_, $face; # gcfclient-compat
3380	}
3381
3382	while (my ($k, $v) = each %{$soundconf->{event}}) {
3383	my $face = cf::face::find "sound/$v";
3384	cf::sound::set $k => $face;
3385	}
3386	}
3387	});
3388		3773
3389	register_exticmd fx_want => sub {	3774	register_exticmd fx_want => sub {
3390	my ($ns, $want) = @_;	3775	my ($ns, $want) = @_;
3391		3776
3392	while (my ($k, $v) = each %$want) {	3777	while (my ($k, $v) = each %$want) {
…		…
3400	my $status = load_resource_file_ $_[0];	3785	my $status = load_resource_file_ $_[0];
3401	get_slot 0.1, 100;	3786	get_slot 0.1, 100;
3402	cf::arch::commit_load;	3787	cf::arch::commit_load;
3403		3788
3404	$status	3789	$status
		3790	}
		3791
		3792	sub reload_exp_table {
		3793	_reload_exp_table;
		3794
		3795	cf::face::set
		3796	"res/exp_table" => FT_RSRC,
		3797	JSON::XS->new->utf8->canonical->encode (
		3798	[map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
		3799	);
		3800	}
		3801
		3802	sub reload_materials {
		3803	_reload_materials;
3405	}	3804	}
3406		3805
3407	sub reload_regions {	3806	sub reload_regions {
3408	# HACK to clear player env face cache, we need some signal framework	3807	# HACK to clear player env face cache, we need some signal framework
3409	# for this (global event?)	3808	# for this (global event?)
…		…
3417	if exists $_->{match};	3816	if exists $_->{match};
3418	}	3817	}
3419	}	3818	}
3420		3819
3421	sub reload_facedata {	3820	sub reload_facedata {
3422	load_facedata "$DATADIR/facedata"	3821	load_facedata $DATADIR
3423	or die "unable to load facedata\n";	3822	or die "unable to load facedata\n";
3424	}	3823	}
3425		3824
3426	sub reload_archetypes {	3825	sub reload_archetypes {
3427	load_resource_file "$DATADIR/archetypes"	3826	load_resource_file "$DATADIR/archetypes"
3428	or die "unable to load archetypes\n";	3827	or die "unable to load archetypes\n";
		3828
		3829	cf::face::set
		3830	"res/skill_info" => FT_RSRC,
		3831	JSON::XS->new->utf8->canonical->encode (
		3832	[map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
		3833	);
		3834
		3835	cf::face::set
		3836	"res/spell_paths" => FT_RSRC,
		3837	JSON::XS->new->utf8->canonical->encode (
		3838	[map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
		3839	);
		3840
		3841	# command completion
		3842	my @commands;
		3843
		3844	for (0..cf::arch::skillvec_size - 1) {
		3845	my $skill = cf::arch::skillvec $_;
		3846	my $name = $skill->name;
		3847	my $flags = cf::skill_flags $skill->subtype;
		3848
		3849	push @commands, "ready_skill $name" if $flags & (SF_COMBAT | SF_RANGED | SF_GRACE);
		3850	push @commands, "use_skill $name" if $flags & (SF_USE | SF_AUTARK | SF_GRACE);
		3851	}
		3852
		3853	cf::client::set_command_face skill => \@commands;
3429	}	3854	}
3430		3855
3431	sub reload_treasures {	3856	sub reload_treasures {
3432	load_resource_file "$DATADIR/treasures"	3857	load_resource_file "$DATADIR/treasures"
3433	or die "unable to load treasurelists\n";	3858	or die "unable to load treasurelists\n";
3434	}	3859	}
3435		3860
		3861	sub reload_sound {
		3862	trace "loading sound config from $DATADIR/sound\n";
		3863
		3864	my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
		3865
		3866	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3867	my $sound = $soundconf->{compat}[$_]
		3868	or next;
		3869
		3870	my $face = cf::face::find "sound/$sound->[1]";
		3871	cf::sound::set $sound->[0] => $face;
		3872	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3873	}
		3874
		3875	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3876	my $face = cf::face::find "sound/$v";
		3877	cf::sound::set $k => $face;
		3878	}
		3879	}
		3880
3436	sub reload_resources {	3881	sub reload_resources {
3437	warn "reloading resource files...\n";	3882	trace "reloading resource files...\n";
3438		3883
		3884	reload_materials;
3439	reload_facedata;	3885	reload_facedata;
		3886	reload_exp_table;
		3887	reload_sound;
3440	reload_archetypes;	3888	reload_archetypes;
3441	reload_regions;	3889	reload_regions;
3442	reload_treasures;	3890	reload_treasures;
3443		3891
3444	warn "finished reloading resource files\n";	3892	trace "finished reloading resource files\n";
3445	}	3893	}
3446		3894
3447	sub reload_config {	3895	sub reload_config {
3448	warn "reloading config file...\n";	3896	trace "reloading config file...\n";
3449		3897
3450	open my $fh, "<:utf8", "$CONFDIR/config"	3898	my $config = load_file "$CONFDIR/config";
3451	or return;	3899	utf8::decode $config;
		3900	*CFG = decode_yaml $config;
3452		3901
3453	local $/;
3454	*CFG = YAML::XS::Load scalar <$fh>;
3455
3456	$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];	3902	$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3457		3903
3458	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};	3904	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3459	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};	3905	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3460		3906
3461	if (exists $CFG{mlockall}) {	3907	if (exists $CFG{mlockall}) {
…		…
3463	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"	3909	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3464	and die "WARNING: m(un)lockall failed: $!\n";	3910	and die "WARNING: m(un)lockall failed: $!\n";
3465	};	3911	};
3466	warn $@ if $@;	3912	warn $@ if $@;
3467	}	3913	}
3468
3469	warn "finished reloading resource files\n";
3470	}	3914	}
3471		3915
3472	sub pidfile() {	3916	sub pidfile() {
3473	sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT	3917	sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3474	or die "$PIDFILE: $!";	3918	or die "$PIDFILE: $!";
…		…
3487	seek $fh, 0, 0;	3931	seek $fh, 0, 0;
3488	print $fh $$;	3932	print $fh $$;
3489	}	3933	}
3490		3934
3491	sub main_loop {	3935	sub main_loop {
3492	warn "EV::loop starting\n";	3936	trace "EV::run starting\n";
3493	if (1) {	3937	if (1) {
3494	EV::loop;	3938	EV::run;
3495	}	3939	}
3496	warn "EV::loop returned\n";	3940	trace "EV::run returned\n";
3497	goto &main_loop unless $REALLY_UNLOOP;	3941	goto &main_loop unless $REALLY_UNLOOP;
3498	}	3942	}
3499		3943
3500	sub main {	3944	sub main {
3501	cf::init_globals; # initialise logging	3945	cf::init_globals; # initialise logging
3502		3946
3503	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;	3947	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
		3948	LOG llevInfo, "Copyright (C) 2017-2018 Marc Alexander Lehmann / the Deliantra team.";
3504	LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";	3949	LOG llevInfo, "Copyright (C) 2005-2016 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3505	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";	3950	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3506	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";	3951	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3507		3952
3508	cf::init_experience;
3509	cf::init_anim;
3510	cf::init_attackmess;
3511	cf::init_dynamic;
3512
3513	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority	3953	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3514		3954
3515	# we must not ever block the main coroutine	3955	# we must not ever block the main coroutine
3516	local $Coro::idle = sub {	3956	$Coro::idle = sub {
3517	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#	3957	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3518	(async {	3958	(async {
3519	$Coro::current->{desc} = "IDLE BUG HANDLER";	3959	$Coro::current->{desc} = "IDLE BUG HANDLER";
3520	EV::loop EV::LOOP_ONESHOT;	3960	EV::run EV::RUN_ONCE;
3521	})->prio (Coro::PRIO_MAX);	3961	})->prio (Coro::PRIO_MAX);
3522	};	3962	};
3523		3963
3524	evthread_start IO::AIO::poll_fileno;	3964	evthread_start IO::AIO::poll_fileno;
3525		3965
3526	cf::sync_job {	3966	cf::sync_job {
		3967	cf::incloader::init ();
		3968
		3969	db_init;
		3970
		3971	cf::init_anim;
		3972	cf::init_attackmess;
		3973	cf::init_dynamic;
		3974
		3975	cf::load_settings;
		3976
3527	reload_resources;	3977	reload_resources;
3528	reload_config;	3978	reload_config;
3529	db_init;
3530		3979
3531	cf::load_settings;
3532	cf::load_materials;
3533	cf::init_uuid;	3980	cf::init_uuid;
3534	cf::init_signals;	3981	cf::init_signals;
3535	cf::init_commands;
3536	cf::init_skills;	3982	cf::init_skills;
3537		3983
3538	cf::init_beforeplay;	3984	cf::init_beforeplay;
3539		3985
3540	atomic;	3986	atomic;
…		…
3545		3991
3546	# no (long-running) fork's whatsoever before this point(!)	3992	# no (long-running) fork's whatsoever before this point(!)
3547	use POSIX ();	3993	use POSIX ();
3548	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};	3994	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3549		3995
3550	(pop @POST_INIT)->(0) while @POST_INIT;	3996	cf::_post_init 0;
3551	};	3997	};
3552		3998
		3999	cf::object::thawer::errors_are_fatal 0;
		4000	info "parse errors in files are no longer fatal from this point on.\n";
		4001
		4002	AE::postpone {
		4003	undef &main; # free gobs of memory :)
		4004	};
		4005
3553	main_loop;	4006	goto &main_loop;
3554	}	4007	}
3555		4008
3556	#############################################################################	4009	#############################################################################
3557	# initialisation and cleanup	4010	# initialisation and cleanup
3558		4011
3559	# install some emergency cleanup handlers	4012	# install some emergency cleanup handlers
3560	BEGIN {	4013	BEGIN {
3561	our %SIGWATCHER = ();	4014	our %SIGWATCHER = ();
3562	for my $signal (qw(INT HUP TERM)) {	4015	for my $signal (qw(INT HUP TERM)) {
3563	$SIGWATCHER{$signal} = EV::signal $signal, sub {	4016	$SIGWATCHER{$signal} = AE::signal $signal, sub {
3564	cf::cleanup "SIG$signal";	4017	cf::cleanup "SIG$signal";
3565	};	4018	};
3566	}	4019	}
3567	}	4020	}
3568		4021
3569	sub write_runtime_sync {	4022	sub write_runtime_sync {
		4023	my $t0 = AE::time;
		4024
3570	# first touch the runtime file to show we are still running:	4025	# first touch the runtime file to show we are still running:
3571	# the fsync below can take a very very long time.	4026	# the fsync below can take a very very long time.
3572		4027
3573	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;	4028	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3574		4029
3575	my $guard = cf::lock_acquire "write_runtime";	4030	my $guard = cf::lock_acquire "write_runtime";
3576		4031
3577	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644	4032	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3578	or return;	4033	or return;
3579		4034
3580	my $value = $cf::RUNTIME + 90 + 10;	4035	my $value = $cf::RUNTIME + 90 + 10;
3581	# 10 is the runtime save interval, for a monotonic clock	4036	# 10 is the runtime save interval, for a monotonic clock
3582	# 60 allows for the watchdog to kill the server.	4037	# 60 allows for the watchdog to kill the server.
…		…
3595	or return;	4050	or return;
3596		4051
3597	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE	4052	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3598	and return;	4053	and return;
3599		4054
3600	warn "runtime file written.\n";	4055	trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3601		4056
3602	1	4057	1
3603	}	4058	}
3604		4059
3605	our $uuid_lock;	4060	our $uuid_lock;
…		…
3617	or return;	4072	or return;
3618		4073
3619	my $value = uuid_seq uuid_cur;	4074	my $value = uuid_seq uuid_cur;
3620		4075
3621	unless ($value) {	4076	unless ($value) {
3622	warn "cowardly refusing to write zero uuid value!\n";	4077	info "cowardly refusing to write zero uuid value!\n";
3623	return;	4078	return;
3624	}	4079	}
3625		4080
3626	my $value = uuid_str $value + $uuid_skip;	4081	my $value = uuid_str $value + $uuid_skip;
3627	$uuid_skip = 0;	4082	$uuid_skip = 0;
…		…
3637	or return;	4092	or return;
3638		4093
3639	aio_rename "$uuid~", $uuid	4094	aio_rename "$uuid~", $uuid
3640	and return;	4095	and return;
3641		4096
3642	warn "uuid file written ($value).\n";	4097	trace "uuid file written ($value).\n";
3643		4098
3644	1	4099	1
3645		4100
3646	}	4101	}
3647		4102
…		…
3653	}	4108	}
3654		4109
3655	sub emergency_save() {	4110	sub emergency_save() {
3656	my $freeze_guard = cf::freeze_mainloop;	4111	my $freeze_guard = cf::freeze_mainloop;
3657		4112
3658	warn "emergency_perl_save: enter\n";	4113	info "emergency_perl_save: enter\n";
		4114
		4115	# this is a trade-off: we want to be very quick here, so
		4116	# save all maps without fsync, and later call a global sync
		4117	# (which in turn might be very very slow)
		4118	local $USE_FSYNC = 0;
3659		4119
3660	cf::sync_job {	4120	cf::sync_job {
3661	# this is a trade-off: we want to be very quick here, so	4121	cf::write_runtime_sync; # external watchdog should not bark
3662	# save all maps without fsync, and later call a global sync
3663	# (which in turn might be very very slow)
3664	local $USE_FSYNC = 0;
3665		4122
3666	# use a peculiar iteration method to avoid tripping on perl	4123	# use a peculiar iteration method to avoid tripping on perl
3667	# refcount bugs in for. also avoids problems with players	4124	# refcount bugs in for. also avoids problems with players
3668	# and maps saved/destroyed asynchronously.	4125	# and maps saved/destroyed asynchronously.
3669	warn "emergency_perl_save: begin player save\n";	4126	info "emergency_perl_save: begin player save\n";
3670	for my $login (keys %cf::PLAYER) {	4127	for my $login (keys %cf::PLAYER) {
3671	my $pl = $cf::PLAYER{$login} or next;	4128	my $pl = $cf::PLAYER{$login} or next;
3672	$pl->valid or next;	4129	$pl->valid or next;
3673	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt	4130	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3674	$pl->save;	4131	$pl->save;
3675	}	4132	}
3676	warn "emergency_perl_save: end player save\n";	4133	info "emergency_perl_save: end player save\n";
3677		4134
		4135	cf::write_runtime_sync; # external watchdog should not bark
		4136
3678	warn "emergency_perl_save: begin map save\n";	4137	info "emergency_perl_save: begin map save\n";
3679	for my $path (keys %cf::MAP) {	4138	for my $path (keys %cf::MAP) {
3680	my $map = $cf::MAP{$path} or next;	4139	my $map = $cf::MAP{$path} or next;
3681	$map->valid or next;	4140	$map->valid or next;
3682	$map->save;	4141	$map->save;
3683	}	4142	}
3684	warn "emergency_perl_save: end map save\n";	4143	info "emergency_perl_save: end map save\n";
3685		4144
		4145	cf::write_runtime_sync; # external watchdog should not bark
		4146
3686	warn "emergency_perl_save: begin database checkpoint\n";	4147	info "emergency_perl_save: begin database checkpoint\n";
3687	BDB::db_env_txn_checkpoint $DB_ENV;	4148	BDB::db_env_txn_checkpoint $DB_ENV;
3688	warn "emergency_perl_save: end database checkpoint\n";	4149	info "emergency_perl_save: end database checkpoint\n";
3689		4150
3690	warn "emergency_perl_save: begin write uuid\n";	4151	info "emergency_perl_save: begin write uuid\n";
3691	write_uuid_sync 1;	4152	write_uuid_sync 1;
3692	warn "emergency_perl_save: end write uuid\n";	4153	info "emergency_perl_save: end write uuid\n";
		4154
		4155	cf::write_runtime_sync; # external watchdog should not bark
		4156
		4157	trace "emergency_perl_save: syncing database to disk";
		4158	BDB::db_env_txn_checkpoint $DB_ENV;
		4159
		4160	info "emergency_perl_save: starting sync\n";
		4161	IO::AIO::aio_sync sub {
		4162	info "emergency_perl_save: finished sync\n";
		4163	};
		4164
		4165	cf::write_runtime_sync; # external watchdog should not bark
		4166
		4167	trace "emergency_perl_save: flushing outstanding aio requests";
		4168	while (IO::AIO::nreqs || BDB::nreqs) {
		4169	Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
		4170	}
		4171
		4172	cf::write_runtime_sync; # external watchdog should not bark
3693	};	4173	};
3694		4174
3695	warn "emergency_perl_save: starting sync()\n";
3696	IO::AIO::aio_sync sub {
3697	warn "emergency_perl_save: finished sync()\n";
3698	};
3699
3700	warn "emergency_perl_save: leave\n";	4175	info "emergency_perl_save: leave\n";
3701	}	4176	}
3702		4177
3703	sub post_cleanup {	4178	sub post_cleanup {
3704	my ($make_core) = @_;	4179	my ($make_core) = @_;
3705		4180
		4181	IO::AIO::flush;
		4182
3706	warn Carp::longmess "post_cleanup backtrace"	4183	error Carp::longmess "post_cleanup backtrace"
3707	if $make_core;	4184	if $make_core;
3708		4185
3709	my $fh = pidfile;	4186	my $fh = pidfile;
3710	unlink $PIDFILE if <$fh> == $$;	4187	unlink $PIDFILE if <$fh> == $$;
3711	}	4188	}
…		…
3731	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};	4208	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3732	for my $name (keys %$leaf_symtab) {	4209	for my $name (keys %$leaf_symtab) {
3733	_gv_clear *{"$pkg$name"};	4210	_gv_clear *{"$pkg$name"};
3734	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};	4211	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3735	}	4212	}
3736	warn "cleared package $pkg\n";#d#
3737	}	4213	}
3738		4214
3739	sub do_reload_perl() {	4215	sub do_reload_perl() {
3740	# can/must only be called in main	4216	# can/must only be called in main
3741	if ($Coro::current != $Coro::main) {	4217	unless (in_main) {
3742	warn "can only reload from main coroutine";	4218	error "can only reload from main coroutine";
3743	return;	4219	return;
3744	}	4220	}
3745		4221
3746	return if $RELOAD++;	4222	return if $RELOAD++;
3747		4223
3748	my $t1 = EV::time;	4224	my $t1 = AE::time;
3749		4225
3750	while ($RELOAD) {	4226	while ($RELOAD) {
3751	warn "reloading...";	4227	cf::get_slot 0.1, -1, "reload_perl";
		4228	info "perl_reload: reloading...";
3752		4229
3753	warn "entering sync_job";	4230	trace "perl_reload: entering sync_job";
3754		4231
3755	cf::sync_job {	4232	cf::sync_job {
3756	cf::write_runtime_sync; # external watchdog should not bark
3757	cf::emergency_save;	4233	#cf::emergency_save;
3758	cf::write_runtime_sync; # external watchdog should not bark
3759		4234
3760	warn "syncing database to disk";
3761	BDB::db_env_txn_checkpoint $DB_ENV;
3762
3763	# if anything goes wrong in here, we should simply crash as we already saved
3764
3765	warn "flushing outstanding aio requests";
3766	while (IO::AIO::nreqs || BDB::nreqs) {
3767	Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3768	}
3769
3770	warn "cancelling all extension coros";	4235	trace "perl_reload: cancelling all extension coros";
3771	$_->cancel for values %EXT_CORO;	4236	$_->cancel for values %EXT_CORO;
3772	%EXT_CORO = ();	4237	%EXT_CORO = ();
3773		4238
3774	warn "removing commands";	4239	trace "perl_reload: removing commands";
3775	%COMMAND = ();	4240	%COMMAND = ();
3776		4241
3777	warn "removing ext/exti commands";	4242	trace "perl_reload: removing ext/exti commands";
3778	%EXTCMD = ();	4243	%EXTCMD = ();
3779	%EXTICMD = ();	4244	%EXTICMD = ();
3780		4245
3781	warn "unloading/nuking all extensions";	4246	trace "perl_reload: unloading/nuking all extensions";
3782	for my $pkg (@EXTS) {	4247	for my $pkg (@EXTS) {
3783	warn "... unloading $pkg";	4248	trace "... unloading $pkg";
3784		4249
3785	if (my $cb = $pkg->can ("unload")) {	4250	if (my $cb = $pkg->can ("unload")) {
3786	eval {	4251	eval {
3787	$cb->($pkg);	4252	$cb->($pkg);
3788	1	4253	1
3789	} or warn "$pkg unloaded, but with errors: $@";	4254	} or error "$pkg unloaded, but with errors: $@";
3790	}	4255	}
3791		4256
3792	warn "... clearing $pkg";	4257	trace "... clearing $pkg";
3793	clear_package $pkg;	4258	clear_package $pkg;
3794	}	4259	}
3795		4260
3796	warn "unloading all perl modules loaded from $LIBDIR";	4261	trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3797	while (my ($k, $v) = each %INC) {	4262	while (my ($k, $v) = each %INC) {
3798	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;	4263	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3799		4264
3800	warn "... unloading $k";	4265	trace "... unloading $k";
3801	delete $INC{$k};	4266	delete $INC{$k};
3802		4267
3803	$k =~ s/\.pm$//;	4268	$k =~ s/\.pm$//;
3804	$k =~ s/\//::/g;	4269	$k =~ s/\//::/g;
3805		4270
…		…
3808	}	4273	}
3809		4274
3810	clear_package $k;	4275	clear_package $k;
3811	}	4276	}
3812		4277
3813	warn "getting rid of safe::, as good as possible";	4278	trace "perl_reload: getting rid of safe::, as good as possible";
3814	clear_package "safe::$_"	4279	clear_package "safe::$_"
3815	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	4280	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3816		4281
3817	warn "unloading cf.pm \"a bit\"";	4282	trace "perl_reload: unloading cf.pm \"a bit\"";
3818	delete $INC{"cf.pm"};	4283	delete $INC{"cf.pm"};
3819	delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;	4284	delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3820		4285
3821	# don't, removes xs symbols, too,	4286	# don't, removes xs symbols, too,
3822	# and global variables created in xs	4287	# and global variables created in xs
3823	#clear_package __PACKAGE__;	4288	#clear_package __PACKAGE__;
3824		4289
3825	warn "unload completed, starting to reload now";	4290	info "perl_reload: unload completed, starting to reload now";
3826		4291
3827	warn "reloading cf.pm";	4292	trace "perl_reload: reloading cf.pm";
3828	require cf;	4293	require cf;
3829	cf::_connect_to_perl_1;	4294	cf::_connect_to_perl_1;
3830		4295
3831	warn "loading config and database again";	4296	trace "perl_reload: loading config and database again";
3832	cf::reload_config;	4297	cf::reload_config;
3833		4298
3834	warn "loading extensions";	4299	trace "perl_reload: loading extensions";
3835	cf::load_extensions;	4300	cf::load_extensions;
3836		4301
3837	if ($REATTACH_ON_RELOAD) {	4302	if ($REATTACH_ON_RELOAD) {
3838	warn "reattaching attachments to objects/players";	4303	trace "perl_reload: reattaching attachments to objects/players";
3839	_global_reattach; # objects, sockets	4304	_global_reattach; # objects, sockets
3840	warn "reattaching attachments to maps";	4305	trace "perl_reload: reattaching attachments to maps";
3841	reattach $_ for values %MAP;	4306	reattach $_ for values %MAP;
3842	warn "reattaching attachments to players";	4307	trace "perl_reload: reattaching attachments to players";
3843	reattach $_ for values %PLAYER;	4308	reattach $_ for values %PLAYER;
3844	}	4309	}
3845		4310
3846	warn "running post_init jobs";	4311	cf::_post_init 1;
3847	(pop @POST_INIT)->(1) while @POST_INIT;
3848		4312
3849	warn "leaving sync_job";	4313	trace "perl_reload: leaving sync_job";
3850		4314
3851	1	4315	1
3852	} or do {	4316	} or do {
3853	warn $@;	4317	error $@;
3854	cf::cleanup "error while reloading, exiting.";	4318	cf::cleanup "perl_reload: error, exiting.";
3855	};	4319	};
3856		4320
3857	warn "reloaded";
3858	--$RELOAD;	4321	--$RELOAD;
3859	}	4322	}
3860		4323
3861	$t1 = EV::time - $t1;	4324	$t1 = AE::time - $t1;
3862	warn "reload completed in ${t1}s\n";	4325	info "perl_reload: completed in ${t1}s\n";
3863	};	4326	};
3864		4327
3865	our $RELOAD_WATCHER; # used only during reload	4328	our $RELOAD_WATCHER; # used only during reload
3866		4329
3867	sub reload_perl() {	4330	sub reload_perl() {
…		…
3869	# coro crashes during coro_state_free->destroy here.	4332	# coro crashes during coro_state_free->destroy here.
3870		4333
3871	$RELOAD_WATCHER ||= cf::async {	4334	$RELOAD_WATCHER ||= cf::async {
3872	Coro::AIO::aio_wait cache_extensions;	4335	Coro::AIO::aio_wait cache_extensions;
3873		4336
3874	$RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {	4337	$RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3875	do_reload_perl;	4338	do_reload_perl;
3876	undef $RELOAD_WATCHER;	4339	undef $RELOAD_WATCHER;
3877	};	4340	};
3878	};	4341	};
3879	}	4342	}
…		…
3888	reload_perl;	4351	reload_perl;
3889	};	4352	};
3890	}	4353	}
3891	};	4354	};
3892		4355
3893	unshift @INC, $LIBDIR;	4356	#############################################################################
3894		4357
3895	my $bug_warning = 0;	4358	my $bug_warning = 0;
3896		4359
3897	our @WAIT_FOR_TICK;
3898	our @WAIT_FOR_TICK_BEGIN;
3899
3900	sub wait_for_tick {	4360	sub wait_for_tick() {
3901	return if tick_inhibit || $Coro::current == $Coro::main;	4361	return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3902		4362
3903	my $signal = new Coro::Signal;	4363	$WAIT_FOR_TICK->wait;
3904	push @WAIT_FOR_TICK, $signal;
3905	$signal->wait;
3906	}	4364	}
3907		4365
3908	sub wait_for_tick_begin {	4366	sub wait_for_tick_begin() {
3909	return if tick_inhibit || $Coro::current == $Coro::main;	4367	return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3910		4368
3911	my $signal = new Coro::Signal;	4369	my $signal = new Coro::Signal;
3912	push @WAIT_FOR_TICK_BEGIN, $signal;	4370	push @WAIT_FOR_TICK_BEGIN, $signal;
3913	$signal->wait;	4371	$signal->wait;
3914	}	4372	}
…		…
3918	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"	4376	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3919	unless ++$bug_warning > 10;	4377	unless ++$bug_warning > 10;
3920	return;	4378	return;
3921	}	4379	}
3922		4380
3923	cf::server_tick; # one server iteration	4381	cf::one_tick; # one server iteration
		4382
		4383	#for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3924		4384
3925	if ($NOW >= $NEXT_RUNTIME_WRITE) {	4385	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3926	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;	4386	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3927	Coro::async_pool {	4387	Coro::async_pool {
3928	$Coro::current->{desc} = "runtime saver";	4388	$Coro::current->{desc} = "runtime saver";
3929	write_runtime_sync	4389	write_runtime_sync
3930	or warn "ERROR: unable to write runtime file: $!";	4390	or error "ERROR: unable to write runtime file: $!";
3931	};	4391	};
3932	}	4392	}
3933		4393
3934	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	4394	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3935	$sig->send;	4395	$sig->send;
3936	}	4396	}
3937	while (my $sig = shift @WAIT_FOR_TICK) {	4397	$WAIT_FOR_TICK->broadcast;
3938	$sig->send;
3939	}
3940		4398
3941	$LOAD = ($NOW - $TICK_START) / $TICK;	4399	$LOAD = ($NOW - $TICK_START) / $TICK;
3942	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	4400	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3943		4401
3944	if (0) {	4402	if (0) {
3945	if ($NEXT_TICK) {	4403	if ($NEXT_TICK) {
3946	my $jitter = $TICK_START - $NEXT_TICK;	4404	my $jitter = $TICK_START - $NEXT_TICK;
3947	$JITTER = $JITTER * 0.75 + $jitter * 0.25;	4405	$JITTER = $JITTER * 0.75 + $jitter * 0.25;
3948	warn "jitter $JITTER\n";#d#	4406	debug "jitter $JITTER\n";#d#
3949	}	4407	}
3950	}	4408	}
3951	}	4409	}
3952		4410
3953	{	4411	{
3954	# configure BDB	4412	# configure BDB
		4413	info "initialising database";
3955		4414
3956	BDB::min_parallel 8;	4415	BDB::min_parallel 16;
3957	BDB::max_poll_reqs $TICK * 0.1;	4416	BDB::max_poll_reqs $TICK * 0.1;
3958	$AnyEvent::BDB::WATCHER->priority (1);	4417	#$AnyEvent::BDB::WATCHER->priority (1);
3959		4418
3960	unless ($DB_ENV) {	4419	unless ($DB_ENV) {
3961	$DB_ENV = BDB::db_env_create;	4420	$DB_ENV = BDB::db_env_create;
3962	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);	4421	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3963	$DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;	4422	$DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
…		…
3988	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };	4447	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3989	};	4448	};
3990	$BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {	4449	$BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3991	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };	4450	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3992	};	4451	};
		4452
		4453	info "database initialised";
3993	}	4454	}
3994		4455
3995	{	4456	{
3996	# configure IO::AIO	4457	# configure IO::AIO
3997		4458
		4459	info "initialising aio";
3998	IO::AIO::min_parallel 8;	4460	IO::AIO::min_parallel 8;
3999	IO::AIO::max_poll_time $TICK * 0.1;	4461	IO::AIO::max_poll_time $TICK * 0.1;
4000	undef $AnyEvent::AIO::WATCHER;	4462	undef $AnyEvent::AIO::WATCHER;
		4463	info "aio initialised";
4001	}	4464	}
4002		4465
4003	my $_log_backtrace;	4466	our $_log_backtrace;
		4467	our $_log_backtrace_last;
4004		4468
4005	sub _log_backtrace {	4469	sub _log_backtrace {
4006	my ($msg, @addr) = @_;	4470	my ($msg, @addr) = @_;
4007		4471
4008	$msg =~ s/\n//;	4472	$msg =~ s/\n$//;
4009		4473
		4474	if ($_log_backtrace_last eq $msg) {
		4475	LOG llevInfo, "[ABT] $msg\n";
		4476	LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
4010	# limit the # of concurrent backtraces	4477	# limit the # of concurrent backtraces
4011	if ($_log_backtrace < 2) {	4478	} elsif ($_log_backtrace < 2) {
		4479	$_log_backtrace_last = $msg;
4012	++$_log_backtrace;	4480	++$_log_backtrace;
4013	my $perl_bt = Carp::longmess $msg;	4481	my $perl_bt = Carp::longmess $msg;
4014	async {	4482	async {
4015	$Coro::current->{desc} = "abt $msg";	4483	$Coro::current->{desc} = "abt $msg";
4016		4484
…		…
4036	LOG llevInfo, "[ABT] $_\n" for @bt;	4504	LOG llevInfo, "[ABT] $_\n" for @bt;
4037	--$_log_backtrace;	4505	--$_log_backtrace;
4038	};	4506	};
4039	} else {	4507	} else {
4040	LOG llevInfo, "[ABT] $msg\n";	4508	LOG llevInfo, "[ABT] $msg\n";
4041	LOG llevInfo, "[ABT] [suppressed]\n";	4509	LOG llevInfo, "[ABT] [overload, suppressed]\n";
4042	}	4510	}
4043	}	4511	}
4044		4512
4045	# load additional modules	4513	# load additional modules
4046	require "cf/$_.pm" for @EXTRA_MODULES;	4514	require "cf/$_.pm" for @EXTRA_MODULES;

Diff Legend

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