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.480 by root, Thu Oct 8 05:09:43 2009 UTC vs.
Revision 1.583 by root, Mon Oct 29 23:12:37 2012 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 (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team	4	# Copyright (©) 2006,2007,2008,2009,2010,2011,2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5	#	5	#
6	# Deliantra is free software: you can redistribute it and/or modify	6	# Deliantra is free software: you can redistribute it and/or modify it under
7	# it under the terms of the GNU General Public License as published by	7	# the terms of the Affero GNU General Public License as published by the
8	# the Free Software Foundation, either version 3 of the License, or	8	# Free Software Foundation, either version 3 of the License, or (at your
9	# (at your option) any later version.	9	# option) any later version.
10	#	10	#
11	# This program is distributed in the hope that it will be useful,	11	# This program is distributed in the hope that it will be useful,
12	# but WITHOUT ANY WARRANTY; without even the implied warranty of	12	# but WITHOUT ANY WARRANTY; without even the implied warranty of
13	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the	13	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14	# GNU General Public License for more details.	14	# GNU General Public License for more details.
15	#	15	#
16	# You should have received a copy of the GNU General Public License	16	# You should have received a copy of the Affero GNU General Public License
17	# along with this program. If not, see <http://www.gnu.org/licenses/>.	17	# and the GNU General Public License along with this program. If not, see
18	#	18	# <http://www.gnu.org/licenses/>.
		19	#
19	# The authors can be reached via e-mail to <support@deliantra.net>	20	# The authors can be reached via e-mail to <support@deliantra.net>
20	#	21	#
21		22
22	package cf;	23	package cf;
23		24
24	use 5.10.0;	25	use common::sense;
25	use utf8;
26	use strict qw(vars subs);
27		26
28	use Symbol;	27	use Symbol;
29	use List::Util;	28	use List::Util;
30	use Socket;	29	use Socket;
31	use EV;	30	use EV;
32	use Opcode;	31	use Opcode;
33	use Safe;	32	use Safe;
34	use Safe::Hole;	33	use Safe::Hole;
35	use Storable ();	34	use Storable ();
		35	use Carp ();
36		36
37	use Guard ();	37	use Guard ();
38	use Coro ();	38	use Coro ();
39	use Coro::State;	39	use Coro::State;
40	use Coro::Handle;	40	use Coro::Handle;
…		…
51	use Coro::Util ();	51	use Coro::Util ();
52		52
53	use JSON::XS 2.01 ();	53	use JSON::XS 2.01 ();
54	use BDB ();	54	use BDB ();
55	use Data::Dumper;	55	use Data::Dumper;
56	use Digest::MD5;
57	use Fcntl;	56	use Fcntl;
58	use YAML ();	57	use YAML::XS ();
59	use IO::AIO ();	58	use IO::AIO ();
60	use Time::HiRes;	59	use Time::HiRes;
61	use Compress::LZF;	60	use Compress::LZF;
62	use Digest::MD5 ();	61	use Digest::MD5 ();
63		62
…		…
76		75
77	# strictly for debugging	76	# strictly for debugging
78	$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };	77	$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
79		78
80	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	79	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
		80
		81	our @ORIG_INC;
81		82
82	our %COMMAND = ();	83	our %COMMAND = ();
83	our %COMMAND_TIME = ();	84	our %COMMAND_TIME = ();
84		85
85	our @EXTS = (); # list of extension package names	86	our @EXTS = (); # list of extension package names
…		…
92	our @EVENT;	93	our @EVENT;
93	our @REFLECT; # set by XS	94	our @REFLECT; # set by XS
94	our %REFLECT; # set by us	95	our %REFLECT; # set by us
95		96
96	our $CONFDIR = confdir;	97	our $CONFDIR = confdir;
		98
97	our $DATADIR = datadir;	99	our $DATADIR = datadir;
98	our $LIBDIR = "$DATADIR/ext";	100	our $LIBDIR = "$DATADIR/ext";
99	our $PODDIR = "$DATADIR/pod";	101	our $PODDIR = "$DATADIR/pod";
100	our $MAPDIR = "$DATADIR/" . mapdir;	102	our $MAPDIR = "$DATADIR/" . mapdir;
		103
101	our $LOCALDIR = localdir;	104	our $LOCALDIR = localdir;
102	our $TMPDIR = "$LOCALDIR/" . tmpdir;	105	our $TMPDIR = "$LOCALDIR/" . tmpdir;
103	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;	106	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
104	our $PLAYERDIR = "$LOCALDIR/" . playerdir;	107	our $PLAYERDIR = "$LOCALDIR/" . playerdir;
105	our $RANDOMDIR = "$LOCALDIR/random";	108	our $RANDOMDIR = "$LOCALDIR/random";
106	our $BDBDIR = "$LOCALDIR/db";	109	our $BDBDIR = "$LOCALDIR/db";
107	our $PIDFILE = "$LOCALDIR/pid";	110	our $PIDFILE = "$LOCALDIR/pid";
108	our $RUNTIMEFILE = "$LOCALDIR/runtime";	111	our $RUNTIMEFILE = "$LOCALDIR/runtime";
109		112
110	our %RESOURCE;	113	#our %RESOURCE; # unused
		114
		115	our $OUTPUT_RATE_MIN = 3000;
		116	our $OUTPUT_RATE_MAX = 1000000;
		117
		118	our $MAX_LINKS = 32; # how many chained exits to follow
		119	our $VERBOSE_IO = 1;
111		120
112	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	121	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
113	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	122	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
114	our $NEXT_TICK;	123	our $NEXT_TICK;
115	our $USE_FSYNC = 1; # use fsync to write maps - default on	124	our $USE_FSYNC = 1; # use fsync to write maps - default on
…		…
117	our $BDB_DEADLOCK_WATCHER;	126	our $BDB_DEADLOCK_WATCHER;
118	our $BDB_CHECKPOINT_WATCHER;	127	our $BDB_CHECKPOINT_WATCHER;
119	our $BDB_TRICKLE_WATCHER;	128	our $BDB_TRICKLE_WATCHER;
120	our $DB_ENV;	129	our $DB_ENV;
121		130
122	our @EXTRA_MODULES = qw(pod mapscript);	131	our @EXTRA_MODULES = qw(pod match mapscript incloader);
123		132
124	our %CFG;	133	our %CFG;
		134	our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
125		135
126	our $UPTIME; $UPTIME ||= time;	136	our $UPTIME; $UPTIME ||= time;
127	our $RUNTIME;	137	our $RUNTIME = 0;
		138	our $SERVER_TICK = 0;
128	our $NOW;	139	our $NOW;
129		140
130	our (%PLAYER, %PLAYER_LOADING); # all users	141	our (%PLAYER, %PLAYER_LOADING); # all users
131	our (%MAP, %MAP_LOADING ); # all maps	142	our (%MAP, %MAP_LOADING ); # all maps
132	our $LINK_MAP; # the special {link} map, which is always available	143	our $LINK_MAP; # the special {link} map, which is always available
…		…
141		152
142	our @POST_INIT;	153	our @POST_INIT;
143		154
144	our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)	155	our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
145	our $REALLY_UNLOOP; # never set to true, please :)	156	our $REALLY_UNLOOP; # never set to true, please :)
		157
		158	our $WAIT_FOR_TICK = new Coro::Signal;
		159	our @WAIT_FOR_TICK_BEGIN;
146		160
147	binmode STDOUT;	161	binmode STDOUT;
148	binmode STDERR;	162	binmode STDERR;
149		163
150	# read virtual server time, if available	164	# read virtual server time, if available
…		…
161		175
162	our $EMERGENCY_POSITION;	176	our $EMERGENCY_POSITION;
163		177
164	sub cf::map::normalise;	178	sub cf::map::normalise;
165		179
		180	sub in_main() {
		181	$Coro::current == $Coro::main
		182	}
		183
166	#############################################################################	184	#############################################################################
167		185
168	%REFLECT = ();	186	%REFLECT = ();
169	for (@REFLECT) {	187	for (@REFLECT) {
170	my $reflect = JSON::XS::decode_json $_;	188	my $reflect = JSON::XS::decode_json $_;
171	$REFLECT{$reflect->{class}} = $reflect;	189	$REFLECT{$reflect->{class}} = $reflect;
172	}	190	}
173		191
174	# this is decidedly evil	192	# this is decidedly evil
175	$REFLECT{object}{flags} = [grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"}];	193	$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
176		194
177	#############################################################################	195	#############################################################################
178		196
179	=head2 GLOBAL VARIABLES	197	=head2 GLOBAL VARIABLES
180		198
181	=over 4	199	=over 4
182		200
183	=item $cf::UPTIME	201	=item $cf::UPTIME
184		202
185	The timestamp of the server start (so not actually an uptime).	203	The timestamp of the server start (so not actually an "uptime").
		204
		205	=item $cf::SERVER_TICK
		206
		207	An unsigned integer that starts at zero when the server is started and is
		208	incremented on every tick.
		209
		210	=item $cf::NOW
		211
		212	The (real) time of the last (current) server tick - updated before and
		213	after tick processing, so this is useful only as a rough "what time is it
		214	now" estimate.
		215
		216	=item $cf::TICK
		217
		218	The interval between each server tick, in seconds.
186		219
187	=item $cf::RUNTIME	220	=item $cf::RUNTIME
188		221
189	The time this server has run, starts at 0 and is increased by $cf::TICK on	222	The time this server has run, starts at 0 and is increased by $cf::TICK on
190	every server tick.	223	every server tick.
…		…
196	Various directories - "/etc", read-only install directory, perl-library	229	Various directories - "/etc", read-only install directory, perl-library
197	directory, pod-directory, read-only maps directory, "/var", "/var/tmp",	230	directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
198	unique-items directory, player file directory, random maps directory and	231	unique-items directory, player file directory, random maps directory and
199	database environment.	232	database environment.
200		233
201	=item $cf::NOW
202
203	The time of the last (current) server tick.
204
205	=item $cf::TICK
206
207	The interval between server ticks, in seconds.
208
209	=item $cf::LOADAVG	234	=item $cf::LOADAVG
210		235
211	The current CPU load on the server (alpha-smoothed), as a value between 0	236	The current CPU load on the server (alpha-smoothed), as a value between 0
212	(none) and 1 (overloaded), indicating how much time is spent on processing	237	(none) and 1 (overloaded), indicating how much time is spent on processing
213	objects per tick. Healthy values are < 0.5.	238	objects per tick. Healthy values are < 0.5.
…		…
222	from wherever your confdir points to.	247	from wherever your confdir points to.
223		248
224	=item cf::wait_for_tick, cf::wait_for_tick_begin	249	=item cf::wait_for_tick, cf::wait_for_tick_begin
225		250
226	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	251	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
227	returns directly I<after> the tick processing (and consequently, can only wake one process	252	returns directly I<after> the tick processing (and consequently, can only wake one thread
228	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	253	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
229		254
		255	Note that cf::Wait_for_tick will immediately return when the server is not
		256	ticking, making it suitable for small pauses in threads that need to run
		257	when the server is paused. If that is not applicable (i.e. you I<really>
		258	want to wait, use C<$cf::WAIT_FOR_TICK>).
		259
		260	=item $cf::WAIT_FOR_TICK
		261
		262	Note that C<cf::wait_for_tick> is probably the correct thing to use. This
		263	variable contains a L<Coro::Signal> that is broadcats after every server
		264	tick. Calling C<< ->wait >> on it will suspend the caller until after the
		265	next server tick.
		266
		267	=cut
		268
		269	sub wait_for_tick();
		270	sub wait_for_tick_begin();
		271
230	=item @cf::INVOKE_RESULTS	272	=item @cf::INVOKE_RESULTS
231		273
232	This array contains the results of the last C<invoke ()> call. When	274	This array contains the results of the last C<invoke ()> call. When
233	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of	275	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
234	that call.	276	that call.
235		277
236	=item %cf::REFLECT	278	=item %cf::REFLECT
237		279
…		…
241		283
242	=back	284	=back
243		285
244	=cut	286	=cut
245		287
		288	sub error(@) { LOG llevError, join "", @_ }
		289	sub warn (@) { LOG llevWarn , join "", @_ }
		290	sub info (@) { LOG llevInfo , join "", @_ }
		291	sub debug(@) { LOG llevDebug, join "", @_ }
		292	sub trace(@) { LOG llevTrace, join "", @_ }
		293
246	$Coro::State::WARNHOOK = sub {	294	$Coro::State::WARNHOOK = sub {
247	my $msg = join "", @_;	295	my $msg = join "", @_;
248		296
249	$msg .= "\n"	297	$msg .= "\n"
250	unless $msg =~ /\n$/;	298	unless $msg =~ /\n$/;
251		299
252	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;	300	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
253		301
254	LOG llevError, $msg;	302	LOG llevWarn, $msg;
255	};	303	};
256		304
257	$Coro::State::DIEHOOK = sub {	305	$Coro::State::DIEHOOK = sub {
258	return unless $^S eq 0; # "eq", not "=="	306	return unless $^S eq 0; # "eq", not "=="
259		307
260	warn Carp::longmess $_[0];	308	error Carp::longmess $_[0];
261		309
262	if ($Coro::current == $Coro::main) {#d#	310	if (in_main) {#d#
263	warn "DIEHOOK called in main context, Coro bug?\n";#d#	311	error "DIEHOOK called in main context, Coro bug?\n";#d#
264	return;#d#	312	return;#d#
265	}#d#	313	}#d#
266		314
267	# kill coroutine otherwise	315	# kill coroutine otherwise
268	Coro::terminate	316	Coro::terminate
…		…
288	)) {	336	)) {
289	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	337	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
290	}	338	}
291		339
292	$EV::DIED = sub {	340	$EV::DIED = sub {
293	warn "error in event callback: @_";	341	Carp::cluck "error in event callback: @_";
294	};	342	};
		343
		344	#############################################################################
		345
		346	sub fork_call(&@);
		347	sub get_slot($;$$);
295		348
296	#############################################################################	349	#############################################################################
297		350
298	=head2 UTILITY FUNCTIONS	351	=head2 UTILITY FUNCTIONS
299		352
…		…
320	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;	373	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
321	$d	374	$d
322	} || "[unable to dump $_[0]: '$@']";	375	} || "[unable to dump $_[0]: '$@']";
323	}	376	}
324		377
		378	=item $scalar = cf::load_file $path
		379
		380	Loads the given file from path and returns its contents. Croaks on error
		381	and can block.
		382
		383	=cut
		384
		385	sub load_file($) {
		386	0 <= aio_load $_[0], my $data
		387	or Carp::croak "$_[0]: $!";
		388
		389	$data
		390	}
		391
		392	=item $success = cf::replace_file $path, $data, $sync
		393
		394	Atomically replaces the file at the given $path with new $data, and
		395	optionally $sync the data to disk before replacing the file.
		396
		397	=cut
		398
		399	sub replace_file($$;$) {
		400	my ($path, $data, $sync) = @_;
		401
		402	my $lock = cf::lock_acquire ("replace_file:$path");
		403
		404	my $fh = aio_open "$path~", Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_TRUNC, 0644
		405	or return;
		406
		407	$data = $data->() if ref $data;
		408
		409	length $data == aio_write $fh, 0, (length $data), $data, 0
		410	or return;
		411
		412	!$sync
		413	or !aio_fsync $fh
		414	or return;
		415
		416	aio_close $fh
		417	and return;
		418
		419	aio_rename "$path~", $path
		420	and return;
		421
		422	if ($sync) {
		423	$path =~ s%/[^/]*$%%;
		424	aio_pathsync $path;
		425	}
		426
		427	1
		428	}
		429
325	=item $ref = cf::decode_json $json	430	=item $ref = cf::decode_json $json
326		431
327	Converts a JSON string into the corresponding perl data structure.	432	Converts a JSON string into the corresponding perl data structure.
328		433
329	=item $json = cf::encode_json $ref	434	=item $json = cf::encode_json $ref
…		…
335	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max	440	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
336		441
337	sub encode_json($) { $json_coder->encode ($_[0]) }	442	sub encode_json($) { $json_coder->encode ($_[0]) }
338	sub decode_json($) { $json_coder->decode ($_[0]) }	443	sub decode_json($) { $json_coder->decode ($_[0]) }
339		444
		445	=item $ref = cf::decode_storable $scalar
		446
		447	Same as Coro::Storable::thaw, so blocks.
		448
		449	=cut
		450
		451	BEGIN { *decode_storable = \&Coro::Storable::thaw }
		452
		453	=item $ref = cf::decode_yaml $scalar
		454
		455	Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
		456
		457	=cut
		458
		459	sub decode_yaml($) {
		460	fork_call { YAML::XS::Load $_[0] } @_
		461	}
		462
		463	=item $scalar = cf::unlzf $scalar
		464
		465	Same as Compress::LZF::compress, but takes server ticks into account, so
		466	blocks.
		467
		468	=cut
		469
		470	sub unlzf($) {
		471	# we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
		472	cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
		473	Compress::LZF::decompress $_[0]
		474	}
		475
340	=item cf::post_init { BLOCK }	476	=item cf::post_init { BLOCK }
341		477
342	Execute the given codeblock, I<after> all extensions have been (re-)loaded,	478	Execute the given codeblock, I<after> all extensions have been (re-)loaded,
343	but I<before> the server starts ticking again.	479	but I<before> the server starts ticking again.
344		480
345	The cdoeblock will have a single boolean argument to indicate whether this	481	The codeblock will have a single boolean argument to indicate whether this
346	is a reload or not.	482	is a reload or not.
347		483
348	=cut	484	=cut
349		485
350	sub post_init(&) {	486	sub post_init(&) {
351	push @POST_INIT, shift;	487	push @POST_INIT, shift;
		488	}
		489
		490	sub _post_init {
		491	trace "running post_init jobs";
		492
		493	# run them in parallel...
		494
		495	my @join;
		496
		497	while () {
		498	push @join, map &Coro::async ($_, 0), @POST_INIT;
		499	@POST_INIT = ();
		500
		501	@join or last;
		502
		503	(pop @join)->join;
		504	}
352	}	505	}
353		506
354	=item cf::lock_wait $string	507	=item cf::lock_wait $string
355		508
356	Wait until the given lock is available. See cf::lock_acquire.	509	Wait until the given lock is available. See cf::lock_acquire.
…		…
395	}	548	}
396		549
397	=item cf::periodic $interval, $cb	550	=item cf::periodic $interval, $cb
398		551
399	Like EV::periodic, but randomly selects a starting point so that the actions	552	Like EV::periodic, but randomly selects a starting point so that the actions
400	get spread over timer.	553	get spread over time.
401		554
402	=cut	555	=cut
403		556
404	sub periodic($$) {	557	sub periodic($$) {
405	my ($interval, $cb) = @_;	558	my ($interval, $cb) = @_;
…		…
409	EV::periodic $start, $interval, 0, $cb	562	EV::periodic $start, $interval, 0, $cb
410	}	563	}
411		564
412	=item cf::get_slot $time[, $priority[, $name]]	565	=item cf::get_slot $time[, $priority[, $name]]
413		566
414	Allocate $time seconds of blocking CPU time at priority C<$priority>:	567	Allocate $time seconds of blocking CPU time at priority C<$priority>
415	This call blocks and returns only when you have at least C<$time> seconds	568	(default: 0): This call blocks and returns only when you have at least
416	of cpu time till the next tick. The slot is only valid till the next cede.	569	C<$time> seconds of cpu time till the next tick. The slot is only valid
		570	till the next cede.
		571
		572	Background jobs should use a priority les than zero, interactive jobs
		573	should use 100 or more.
417		574
418	The optional C<$name> can be used to identify the job to run. It might be	575	The optional C<$name> can be used to identify the job to run. It might be
419	used for statistical purposes and should identify the same time-class.	576	used for statistical purposes and should identify the same time-class.
420		577
421	Useful for short background jobs.	578	Useful for short background jobs.
422		579
423	=cut	580	=cut
424		581
425	our @SLOT_QUEUE;	582	our @SLOT_QUEUE;
426	our $SLOT_QUEUE;	583	our $SLOT_QUEUE;
		584	our $SLOT_DECAY = 0.9;
427		585
428	$SLOT_QUEUE->cancel if $SLOT_QUEUE;	586	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
429	$SLOT_QUEUE = Coro::async {	587	$SLOT_QUEUE = Coro::async {
430	$Coro::current->desc ("timeslot manager");	588	$Coro::current->desc ("timeslot manager");
431		589
432	my $signal = new Coro::Signal;	590	my $signal = new Coro::Signal;
		591	my $busy;
433		592
434	while () {	593	while () {
435	next_job:	594	next_job:
		595
436	my $avail = cf::till_tick;	596	my $avail = cf::till_tick;
437	if ($avail > 0.01) {	597
438	for (0 .. $#SLOT_QUEUE) {	598	for (0 .. $#SLOT_QUEUE) {
439	if ($SLOT_QUEUE[$_][0] < $avail) {	599	if ($SLOT_QUEUE[$_][0] <= $avail) {
		600	$busy = 0;
440	my $job = splice @SLOT_QUEUE, $_, 1, ();	601	my $job = splice @SLOT_QUEUE, $_, 1, ();
441	$job->[2]->send;	602	$job->[2]->send;
442	Coro::cede;	603	Coro::cede;
443	goto next_job;	604	goto next_job;
444	}	605	} else {
		606	$SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
445	}	607	}
446	}	608	}
447		609
448	if (@SLOT_QUEUE) {	610	if (@SLOT_QUEUE) {
449	# we do not use wait_for_tick() as it returns immediately when tick is inactive	611	# we do not use wait_for_tick() as it returns immediately when tick is inactive
450	push @cf::WAIT_FOR_TICK, $signal;	612	$WAIT_FOR_TICK->wait;
451	$signal->wait;
452	} else {	613	} else {
		614	$busy = 0;
453	Coro::schedule;	615	Coro::schedule;
454	}	616	}
455	}	617	}
456	};	618	};
457		619
458	sub get_slot($;$$) {	620	sub get_slot($;$$) {
459	return if tick_inhibit || $Coro::current == $Coro::main;	621	return if tick_inhibit || $Coro::current == $Coro::main;
460		622
461	my ($time, $pri, $name) = @_;	623	my ($time, $pri, $name) = @_;
462		624
463	$time = $TICK * .6 if $time > $TICK * .6;	625	$time = clamp $time, 0.01, $TICK * .6;
		626
464	my $sig = new Coro::Signal;	627	my $sig = new Coro::Signal;
465		628
466	push @SLOT_QUEUE, [$time, $pri, $sig, $name];	629	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
467	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;	630	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
468	$SLOT_QUEUE->ready;	631	$SLOT_QUEUE->ready;
…		…
494	=cut	657	=cut
495		658
496	sub sync_job(&) {	659	sub sync_job(&) {
497	my ($job) = @_;	660	my ($job) = @_;
498		661
499	if ($Coro::current == $Coro::main) {	662	if (in_main) {
500	my $time = EV::time;	663	my $time = AE::time;
501		664
502	# this is the main coro, too bad, we have to block	665	# this is the main coro, too bad, we have to block
503	# till the operation succeeds, freezing the server :/	666	# till the operation succeeds, freezing the server :/
504		667
505	LOG llevError, Carp::longmess "sync job";#d#	668	#LOG llevError, Carp::longmess "sync job";#d#
506		669
507	my $freeze_guard = freeze_mainloop;	670	my $freeze_guard = freeze_mainloop;
508		671
509	my $busy = 1;	672	my $busy = 1;
510	my @res;	673	my @res;
511		674
512	(async {	675	(async {
513	$Coro::current->desc ("sync job coro");	676	$Coro::current->desc ("sync job coro");
514	@res = eval { $job->() };	677	@res = eval { $job->() };
515	warn $@ if $@;	678	error $@ if $@;
516	undef $busy;	679	undef $busy;
517	})->prio (Coro::PRIO_MAX);	680	})->prio (Coro::PRIO_MAX);
518		681
519	while ($busy) {	682	while ($busy) {
520	if (Coro::nready) {	683	if (Coro::nready) {
…		…
522	} else {	685	} else {
523	EV::loop EV::LOOP_ONESHOT;	686	EV::loop EV::LOOP_ONESHOT;
524	}	687	}
525	}	688	}
526		689
527	my $time = EV::time - $time;	690	my $time = AE::time - $time;
528		691
529	$TICK_START += $time; # do not account sync jobs to server load	692	$TICK_START += $time; # do not account sync jobs to server load
530		693
531	wantarray ? @res : $res[0]	694	wantarray ? @res : $res[0]
532	} else {	695	} else {
…		…
554	$EXT_CORO{$coro+0} = $coro;	717	$EXT_CORO{$coro+0} = $coro;
555		718
556	$coro	719	$coro
557	}	720	}
558		721
559	=item fork_call { }, $args	722	=item fork_call { }, @args
560		723
561	Executes the given code block with the given arguments in a seperate	724	Executes the given code block with the given arguments in a seperate
562	process, returning the results. Everything must be serialisable with	725	process, returning the results. Everything must be serialisable with
563	Coro::Storable. May, of course, block. Note that the executed sub may	726	Coro::Storable. May, of course, block. Note that the executed sub may
564	never block itself or use any form of event handling.	727	never block itself or use any form of event handling.
565		728
566	=cut	729	=cut
567		730
		731	sub post_fork {
		732	reset_signals;
		733	}
		734
568	sub fork_call(&@) {	735	sub fork_call(&@) {
569	my ($cb, @args) = @_;	736	my ($cb, @args) = @_;
570		737
571	# we seemingly have to make a local copy of the whole thing,	738	# we seemingly have to make a local copy of the whole thing,
572	# otherwise perl prematurely frees the stuff :/	739	# otherwise perl prematurely frees the stuff :/
573	# TODO: investigate and fix (likely this will be rather laborious)	740	# TODO: investigate and fix (likely this will be rather laborious)
574		741
575	my @res = Coro::Util::fork_eval {	742	my @res = Coro::Util::fork_eval {
576	reset_signals;	743	cf::post_fork;
577	&$cb	744	&$cb
578	}, @args;	745	} @args;
579		746
580	wantarray ? @res : $res[-1]	747	wantarray ? @res : $res[-1]
		748	}
		749
		750	sub objinfo {
		751	(
		752	"counter value" => cf::object::object_count,
		753	"objects created" => cf::object::create_count,
		754	"objects destroyed" => cf::object::destroy_count,
		755	"freelist size" => cf::object::free_count,
		756	"allocated objects" => cf::object::objects_size,
		757	"active objects" => cf::object::actives_size,
		758	)
581	}	759	}
582		760
583	=item $coin = coin_from_name $name	761	=item $coin = coin_from_name $name
584		762
585	=cut	763	=cut
…		…
622	within each server.	800	within each server.
623		801
624	=cut	802	=cut
625		803
626	sub db_table($) {	804	sub db_table($) {
		805	cf::error "db_get called from main context"
		806	if $Coro::current == $Coro::main;
		807
627	my ($name) = @_;	808	my ($name) = @_;
628	my $db = BDB::db_create $DB_ENV;	809	my $db = BDB::db_create $DB_ENV;
629		810
630	eval {	811	eval {
631	$db->set_flags (BDB::CHKSUM);	812	$db->set_flags (BDB::CHKSUM);
…		…
641	}	822	}
642		823
643	our $DB;	824	our $DB;
644		825
645	sub db_init {	826	sub db_init {
646	cf::sync_job {
647	$DB ||= db_table "db";	827	$DB ||= db_table "db";
648	};
649	}	828	}
650		829
651	sub db_get($$) {	830	sub db_get($$) {
652	my $key = "$_[0]/$_[1]";	831	my $key = "$_[0]/$_[1]";
653		832
654	cf::sync_job {	833	cf::error "db_get called from main context"
		834	if $Coro::current == $Coro::main;
		835
655	BDB::db_get $DB, undef, $key, my $data;	836	BDB::db_get $DB, undef, $key, my $data;
656		837
657	$! ? ()	838	$! ? ()
658	: $data	839	: $data
659	}
660	}	840	}
661		841
662	sub db_put($$$) {	842	sub db_put($$$) {
663	BDB::dbreq_pri 4;	843	BDB::dbreq_pri 4;
664	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };	844	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
…		…
692		872
693	my @data;	873	my @data;
694	my $md5;	874	my $md5;
695		875
696	for (0 .. $#$src) {	876	for (0 .. $#$src) {
697	0 <= aio_load $src->[$_], $data[$_]	877	$data[$_] = load_file $src->[$_];
698	or Carp::croak "$src->[$_]: $!";
699	}	878	}
700		879
701	# if processing is expensive, check	880	# if processing is expensive, check
702	# checksum first	881	# checksum first
703	if (1) {	882	if (1) {
…		…
720		899
721	my $t1 = Time::HiRes::time;	900	my $t1 = Time::HiRes::time;
722	my $data = $process->(\@data);	901	my $data = $process->(\@data);
723	my $t2 = Time::HiRes::time;	902	my $t2 = Time::HiRes::time;
724		903
725	warn "cache: '$id' processed in ", $t2 - $t1, "s\n";	904	info "cache: '$id' processed in ", $t2 - $t1, "s\n";
726		905
727	db_put cache => "$id/data", $data;	906	db_put cache => "$id/data", $data;
728	db_put cache => "$id/md5" , $md5;	907	db_put cache => "$id/md5" , $md5;
729	db_put cache => "$id/meta", $meta;	908	db_put cache => "$id/meta", $meta;
730		909
…		…
740		919
741	=cut	920	=cut
742		921
743	sub datalog($@) {	922	sub datalog($@) {
744	my ($type, %kv) = @_;	923	my ($type, %kv) = @_;
745	warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });	924	info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
746	}	925	}
747		926
748	=back	927	=back
749		928
750	=cut	929	=cut
…		…
945		1124
946	} elsif (exists $cb_id{$type}) {	1125	} elsif (exists $cb_id{$type}) {
947	_attach_cb $registry, $cb_id{$type}, $prio, shift @arg;	1126	_attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
948		1127
949	} elsif (ref $type) {	1128	} elsif (ref $type) {
950	warn "attaching objects not supported, ignoring.\n";	1129	error "attaching objects not supported, ignoring.\n";
951		1130
952	} else {	1131	} else {
953	shift @arg;	1132	shift @arg;
954	warn "attach argument '$type' not supported, ignoring.\n";	1133	error "attach argument '$type' not supported, ignoring.\n";
955	}	1134	}
956	}	1135	}
957	}	1136	}
958		1137
959	sub _object_attach {	1138	sub _object_attach {
…		…
969	_attach $registry, $klass, @attach;	1148	_attach $registry, $klass, @attach;
970	}	1149	}
971		1150
972	$obj->{$name} = \%arg;	1151	$obj->{$name} = \%arg;
973	} else {	1152	} else {
974	warn "object uses attachment '$name' which is not available, postponing.\n";	1153	info "object uses attachment '$name' which is not available, postponing.\n";
975	}	1154	}
976		1155
977	$obj->{_attachment}{$name} = undef;	1156	$obj->{_attachment}{$name} = undef;
978	}	1157	}
979		1158
…		…
1038		1217
1039	for (@$callbacks) {	1218	for (@$callbacks) {
1040	eval { &{$_->[1]} };	1219	eval { &{$_->[1]} };
1041		1220
1042	if ($@) {	1221	if ($@) {
1043	warn "$@";
1044	warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";	1222	error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1045	override;	1223	override;
1046	}	1224	}
1047		1225
1048	return 1 if $override;	1226	return 1 if $override;
1049	}	1227	}
…		…
1128	for (@$attach) {	1306	for (@$attach) {
1129	my ($klass, @attach) = @$_;	1307	my ($klass, @attach) = @$_;
1130	_attach $registry, $klass, @attach;	1308	_attach $registry, $klass, @attach;
1131	}	1309	}
1132	} else {	1310	} else {
1133	warn "object uses attachment '$name' that is not available, postponing.\n";	1311	info "object uses attachment '$name' that is not available, postponing.\n";
1134	}	1312	}
1135	}	1313	}
1136	}	1314	}
1137		1315
1138	cf::attachable->attach (	1316	cf::attachable->attach (
…		…
1165	my ($filename, $rdata, $objs) = @_;	1343	my ($filename, $rdata, $objs) = @_;
1166		1344
1167	sync_job {	1345	sync_job {
1168	if (length $$rdata) {	1346	if (length $$rdata) {
1169	utf8::decode (my $decname = $filename);	1347	utf8::decode (my $decname = $filename);
1170	warn sprintf "saving %s (%d,%d)\n",	1348	trace sprintf "saving %s (%d,%d)\n",
1171	$decname, length $$rdata, scalar @$objs;	1349	$decname, length $$rdata, scalar @$objs
		1350	if $VERBOSE_IO;
1172		1351
1173	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {	1352	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1174	aio_chmod $fh, SAVE_MODE;	1353	aio_chmod $fh, SAVE_MODE;
1175	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1354	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1176	if ($cf::USE_FSYNC) {	1355	if ($cf::USE_FSYNC) {
…		…
1198	aio_rename "$filename~", $filename;	1377	aio_rename "$filename~", $filename;
1199		1378
1200	$filename =~ s%/[^/]+$%%;	1379	$filename =~ s%/[^/]+$%%;
1201	aio_pathsync $filename if $cf::USE_FSYNC;	1380	aio_pathsync $filename if $cf::USE_FSYNC;
1202	} else {	1381	} else {
1203	warn "unable to save objects: $filename~: $!\n";	1382	error "unable to save objects: $filename~: $!\n";
1204	}	1383	}
1205	} else {	1384	} else {
1206	aio_unlink $filename;	1385	aio_unlink $filename;
1207	aio_unlink "$filename.pst";	1386	aio_unlink "$filename.pst";
1208	}	1387	}
…		…
1232	my $st = eval { Coro::Storable::thaw $av };	1411	my $st = eval { Coro::Storable::thaw $av };
1233	$av = $st->{objs};	1412	$av = $st->{objs};
1234	}	1413	}
1235		1414
1236	utf8::decode (my $decname = $filename);	1415	utf8::decode (my $decname = $filename);
1237	warn sprintf "loading %s (%d,%d)\n",	1416	trace sprintf "loading %s (%d,%d)\n",
1238	$decname, length $data, scalar @{$av || []};	1417	$decname, length $data, scalar @{$av || []}
		1418	if $VERBOSE_IO;
1239		1419
1240	($data, $av)	1420	($data, $av)
1241	}	1421	}
1242		1422
1243	=head2 COMMAND CALLBACKS	1423	=head2 COMMAND CALLBACKS
…		…
1302	}	1482	}
1303		1483
1304	use File::Glob ();	1484	use File::Glob ();
1305		1485
1306	cf::player->attach (	1486	cf::player->attach (
1307	on_command => sub {	1487	on_unknown_command => sub {
1308	my ($pl, $name, $params) = @_;	1488	my ($pl, $name, $params) = @_;
1309		1489
1310	my $cb = $COMMAND{$name}	1490	my $cb = $COMMAND{$name}
1311	or return;	1491	or return;
1312		1492
…		…
1320	my ($pl, $buf) = @_;	1500	my ($pl, $buf) = @_;
1321		1501
1322	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1502	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1323		1503
1324	if (ref $msg) {	1504	if (ref $msg) {
1325	my ($type, $reply, @payload) =	1505	my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1326	"ARRAY" eq ref $msg
1327	? @$msg
1328	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1329		1506
1330	my @reply;	1507	my @reply;
1331		1508
1332	if (my $cb = $EXTCMD{$type}) {	1509	if (my $cb = $EXTCMD{$type}) {
1333	@reply = $cb->($pl, @payload);	1510	@reply = $cb->($pl, @payload);
…		…
1335		1512
1336	$pl->ext_reply ($reply, @reply)	1513	$pl->ext_reply ($reply, @reply)
1337	if $reply;	1514	if $reply;
1338		1515
1339	} else {	1516	} else {
1340	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1517	error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1341	}	1518	}
1342		1519
1343	cf::override;	1520	cf::override;
1344	},	1521	},
1345	);	1522	);
…		…
1355	};	1532	};
1356		1533
1357	$grp	1534	$grp
1358	}	1535	}
1359		1536
		1537	sub _ext_cfg_reg($$$$) {
		1538	my ($rvar, $varname, $cfgname, $default) = @_;
		1539
		1540	$cfgname = lc $varname
		1541	unless length $cfgname;
		1542
		1543	$EXT_CFG{$cfgname} = [$rvar, $default];
		1544
		1545	$$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
		1546	}
		1547
1360	sub load_extensions {	1548	sub load_extensions {
		1549	info "loading extensions...";
		1550
		1551	%EXT_CFG = ();
		1552
1361	cf::sync_job {	1553	cf::sync_job {
1362	my %todo;	1554	my %todo;
1363		1555
1364	for my $path (<$LIBDIR/*.ext>) {	1556	for my $path (<$LIBDIR/*.ext>) {
1365	next unless -r $path;	1557	next unless -r $path;
…		…
1383		1575
1384	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }	1576	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1385	if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;	1577	if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1386		1578
1387	$ext{source} =	1579	$ext{source} =
1388	"package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"	1580	"package $pkg; use common::sense;\n"
1389	. "#line 1 \"$path\"\n{\n"	1581	. "#line 1 \"$path\"\n{\n"
1390	. $source	1582	. $source
1391	. "\n};\n1";	1583	. "\n};\n1";
1392		1584
1393	$todo{$base} = \%ext;	1585	$todo{$base} = \%ext;
1394	}	1586	}
1395		1587
		1588	my $pass = 0;
1396	my %done;	1589	my %done;
1397	while (%todo) {	1590	while (%todo) {
1398	my $progress;	1591	my $progress;
1399		1592
		1593	++$pass;
		1594
		1595	ext:
1400	while (my ($k, $v) = each %todo) {	1596	while (my ($k, $v) = each %todo) {
1401	for (split /,\s*/, $v->{meta}{depends}) {	1597	for (split /,\s*/, $v->{meta}{depends}) {
1402	goto skip	1598	next ext
1403	unless exists $done{$_};	1599	unless exists $done{$_};
1404	}	1600	}
1405		1601
1406	warn "... loading '$k' into '$v->{pkg}'\n";	1602	trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1407		1603
1408	unless (eval $v->{source}) {	1604	my $source = $v->{source};
		1605
		1606	# support "CONF varname :confname = default" pseudo-statements
		1607	$source =~ s{
		1608	^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
		1609	}{
		1610	"our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
		1611	}gmxe;
		1612
		1613	my $active = eval $source;
		1614
		1615	if (length $@) {
1409	my $msg = $@ ? "$v->{path}: $@\n"	1616	error "$v->{path}: $@\n";
1410	: "$v->{base}: extension inactive.\n";
1411		1617
1412	if (exists $v->{meta}{mandatory}) {
1413	warn $msg;
1414	cf::cleanup "mandatory extension failed to load, exiting.";	1618	cf::cleanup "mandatory extension '$k' failed to load, exiting."
1415	}	1619	if exists $v->{meta}{mandatory};
1416		1620
1417	warn $msg;	1621	warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
		1622	delete $todo{$k};
		1623	} else {
		1624	$done{$k} = delete $todo{$k};
		1625	push @EXTS, $v->{pkg};
		1626	$progress = 1;
		1627
		1628	info "$v->{base}: extension inactive.\n"
		1629	unless $active;
1418	}	1630	}
1419
1420	$done{$k} = delete $todo{$k};
1421	push @EXTS, $v->{pkg};
1422	$progress = 1;
1423	}	1631	}
1424		1632
1425	skip:	1633	unless ($progress) {
1426	die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"	1634	warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1427	unless $progress;	1635
		1636	while (my ($k, $v) = each %todo) {
		1637	cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
		1638	if exists $v->{meta}{mandatory};
		1639	}
		1640
		1641	last;
		1642	}
1428	}	1643	}
1429	};	1644	};
1430	}	1645	}
1431		1646
1432	#############################################################################	1647	#############################################################################
…		…
1516	$cf::PLAYER{$login} = $pl	1731	$cf::PLAYER{$login} = $pl
1517	}	1732	}
1518	}	1733	}
1519	}	1734	}
1520		1735
		1736	cf::player->attach (
		1737	on_load => sub {
		1738	my ($pl, $path) = @_;
		1739
		1740	# restore slots saved in save, below
		1741	my $slots = delete $pl->{_slots};
		1742
		1743	$pl->ob->current_weapon ($slots->[0]);
		1744	$pl->combat_ob ($slots->[1]);
		1745	$pl->ranged_ob ($slots->[2]);
		1746	},
		1747	);
		1748
1521	sub save($) {	1749	sub save($) {
1522	my ($pl) = @_;	1750	my ($pl) = @_;
1523		1751
1524	return if $pl->{deny_save};	1752	return if $pl->{deny_save};
1525		1753
…		…
1530		1758
1531	aio_mkdir playerdir $pl, 0770;	1759	aio_mkdir playerdir $pl, 0770;
1532	$pl->{last_save} = $cf::RUNTIME;	1760	$pl->{last_save} = $cf::RUNTIME;
1533		1761
1534	cf::get_slot 0.01;	1762	cf::get_slot 0.01;
		1763
		1764	# save slots, to be restored later
		1765	local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1535		1766
1536	$pl->save_pl ($path);	1767	$pl->save_pl ($path);
1537	cf::cede_to_tick;	1768	cf::cede_to_tick;
1538	}	1769	}
1539		1770
…		…
1573	my $name = $pl->ob->name;	1804	my $name = $pl->ob->name;
1574		1805
1575	$pl->{deny_save} = 1;	1806	$pl->{deny_save} = 1;
1576	$pl->password ("*"); # this should lock out the player until we have nuked the dir	1807	$pl->password ("*"); # this should lock out the player until we have nuked the dir
1577		1808
1578	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;	1809	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1579	$pl->deactivate;	1810	$pl->deactivate;
		1811
1580	my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;	1812	my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1581	$pl->ob->check_score;
1582	$pl->invoke (cf::EVENT_PLAYER_QUIT);	1813	$pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
		1814	ext::highscore::check ($pl->ob);
		1815
1583	$pl->ns->destroy if $pl->ns;	1816	$pl->ns->destroy if $pl->ns;
1584		1817
1585	my $path = playerdir $pl;	1818	my $path = playerdir $pl;
1586	my $temp = "$path~$cf::RUNTIME~deleting~";	1819	my $temp = "$path~$cf::RUNTIME~deleting~";
1587	aio_rename $path, $temp;	1820	aio_rename $path, $temp;
…		…
1641	\@logins	1874	\@logins
1642	}	1875	}
1643		1876
1644	=item $player->maps	1877	=item $player->maps
1645		1878
		1879	=item cf::player::maps $login
		1880
1646	Returns an arrayref of map paths that are private for this	1881	Returns an arrayref of map paths that are private for this
1647	player. May block.	1882	player. May block.
1648		1883
1649	=cut	1884	=cut
1650		1885
…		…
1712	=cut	1947	=cut
1713		1948
1714	sub find_by_path($) {	1949	sub find_by_path($) {
1715	my ($path) = @_;	1950	my ($path) = @_;
1716		1951
		1952	$path =~ s/^~[^\/]*//; # skip ~login
		1953
1717	my ($match, $specificity);	1954	my ($match, $specificity);
1718		1955
1719	for my $region (list) {	1956	for my $region (list) {
1720	if ($region->{match} && $path =~ $region->{match}) {	1957	if ($region->{match} && $path =~ $region->{match}) {
1721	($match, $specificity) = ($region, $region->specificity)	1958	($match, $specificity) = ($region, $region->specificity)
…		…
1749	sub generate_random_map {	1986	sub generate_random_map {
1750	my ($self, $rmp) = @_;	1987	my ($self, $rmp) = @_;
1751		1988
1752	my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM	1989	my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1753		1990
1754	# mit "rum" bekleckern, nicht
1755	$self->_create_random_map (	1991	$self->_create_random_map ($rmp);
1756	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1757	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1758	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1759	$rmp->{exit_on_final_map},
1760	$rmp->{xsize}, $rmp->{ysize},
1761	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1762	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1763	$rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1764	$rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1765	$rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1766	(cf::region::find $rmp->{region}), $rmp->{custom}
1767	)
1768	}	1992	}
1769		1993
1770	=item cf::map->register ($regex, $prio)	1994	=item cf::map->register ($regex, $prio)
1771		1995
1772	Register a handler for the map path matching the given regex at the	1996	Register a handler for the map path matching the given regex at the
…		…
1777		2001
1778	sub register {	2002	sub register {
1779	my (undef, $regex, $prio) = @_;	2003	my (undef, $regex, $prio) = @_;
1780	my $pkg = caller;	2004	my $pkg = caller;
1781		2005
1782	no strict;
1783	push @{"$pkg\::ISA"}, __PACKAGE__;	2006	push @{"$pkg\::ISA"}, __PACKAGE__;
1784		2007
1785	$EXT_MAP{$pkg} = [$prio, qr<$regex>];	2008	$EXT_MAP{$pkg} = [$prio, qr<$regex>];
1786	}	2009	}
1787		2010
1788	# also paths starting with '/'	2011	# also paths starting with '/'
1789	$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];	2012	$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1790		2013
1791	sub thawer_merge {	2014	sub thawer_merge {
1792	my ($self, $merge) = @_;	2015	my ($self, $merge) = @_;
1793		2016
1794	# we have to keep some variables in memory intact	2017	# we have to keep some variables in memory intact
…		…
1799	}	2022	}
1800		2023
1801	sub normalise {	2024	sub normalise {
1802	my ($path, $base) = @_;	2025	my ($path, $base) = @_;
1803		2026
1804	$path = "$path"; # make sure its a string	2027	$path = "$path"; # make sure it's a string
1805		2028
1806	$path =~ s/\.map$//;	2029	$path =~ s/\.map$//;
1807		2030
1808	# map plan:	2031	# map plan:
1809	#	2032	#
…		…
1824	$base =~ s{[^/]+/?$}{};	2047	$base =~ s{[^/]+/?$}{};
1825	$path = "$base/$path";	2048	$path = "$base/$path";
1826	}	2049	}
1827		2050
1828	for ($path) {	2051	for ($path) {
1829	redo if s{//}{/};
1830	redo if s{/\.?/}{/};	2052	redo if s{/\.?/}{/};
1831	redo if s{/[^/]+/\.\./}{/};	2053	redo if s{/[^/]+/\.\./}{/};
1832	}	2054	}
1833		2055
1834	$path	2056	$path
…		…
1848	$self->init; # pass $1 etc.	2070	$self->init; # pass $1 etc.
1849	return $self;	2071	return $self;
1850	}	2072	}
1851	}	2073	}
1852		2074
1853	Carp::cluck "unable to resolve path '$path' (base '$base').";	2075	Carp::cluck "unable to resolve path '$path' (base '$base')";
1854	()	2076	()
1855	}	2077	}
1856		2078
		2079	# may re-bless or do other evil things
1857	sub init {	2080	sub init {
1858	my ($self) = @_;	2081	my ($self) = @_;
1859		2082
1860	$self	2083	$self
1861	}	2084	}
…		…
1926	$self->{load_path} = $path;	2149	$self->{load_path} = $path;
1927		2150
1928	1	2151	1
1929	}	2152	}
1930		2153
		2154	# used to laod the header of an original map
1931	sub load_header_orig {	2155	sub load_header_orig {
1932	my ($self) = @_;	2156	my ($self) = @_;
1933		2157
1934	$self->load_header_from ($self->load_path)	2158	$self->load_header_from ($self->load_path)
1935	}	2159	}
1936		2160
		2161	# used to laod the header of an instantiated map
1937	sub load_header_temp {	2162	sub load_header_temp {
1938	my ($self) = @_;	2163	my ($self) = @_;
1939		2164
1940	$self->load_header_from ($self->save_path)	2165	$self->load_header_from ($self->save_path)
1941	}	2166	}
1942		2167
		2168	# called after loading the header from an instantiated map
1943	sub prepare_temp {	2169	sub prepare_temp {
1944	my ($self) = @_;	2170	my ($self) = @_;
1945		2171
1946	$self->last_access ((delete $self->{last_access})	2172	$self->last_access ((delete $self->{last_access})
1947	|| $cf::RUNTIME); #d#	2173	|| $cf::RUNTIME); #d#
1948	# safety	2174	# safety
1949	$self->{instantiate_time} = $cf::RUNTIME	2175	$self->{instantiate_time} = $cf::RUNTIME
1950	if $self->{instantiate_time} > $cf::RUNTIME;	2176	if $self->{instantiate_time} > $cf::RUNTIME;
1951	}	2177	}
1952		2178
		2179	# called after loading the header from an original map
1953	sub prepare_orig {	2180	sub prepare_orig {
1954	my ($self) = @_;	2181	my ($self) = @_;
1955		2182
1956	$self->{load_original} = 1;	2183	$self->{load_original} = 1;
1957	$self->{instantiate_time} = $cf::RUNTIME;	2184	$self->{instantiate_time} = $cf::RUNTIME;
…		…
1981		2208
1982	sub find;	2209	sub find;
1983	sub find {	2210	sub find {
1984	my ($path, $origin) = @_;	2211	my ($path, $origin) = @_;
1985		2212
		2213	cf::cede_to_tick;
		2214
1986	$path = normalise $path, $origin && $origin->path;	2215	$path = normalise $path, $origin;
1987		2216
1988	my $guard1 = cf::lock_acquire "map_data:$path";#d#remove	2217	my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1989	my $guard2 = cf::lock_acquire "map_find:$path";	2218	my $guard2 = cf::lock_acquire "map_find:$path";
1990		2219
1991	$cf::MAP{$path} || do {	2220	$cf::MAP{$path} || do {
…		…
2008		2237
2009	$cf::MAP{$path} = $map	2238	$cf::MAP{$path} = $map
2010	}	2239	}
2011	}	2240	}
2012		2241
2013	sub pre_load { }	2242	sub pre_load { }
2014	sub post_load { }	2243	#sub post_load { } # XS
2015		2244
2016	sub load {	2245	sub load {
2017	my ($self) = @_;	2246	my ($self) = @_;
2018		2247
2019	local $self->{deny_reset} = 1; # loading can take a long time	2248	local $self->{deny_reset} = 1; # loading can take a long time
…		…
2022		2251
2023	{	2252	{
2024	my $guard = cf::lock_acquire "map_data:$path";	2253	my $guard = cf::lock_acquire "map_data:$path";
2025		2254
2026	return unless $self->valid;	2255	return unless $self->valid;
2027	return unless $self->in_memory == cf::MAP_SWAPPED;	2256	return unless $self->state == cf::MAP_SWAPPED;
2028
2029	$self->in_memory (cf::MAP_LOADING);
2030		2257
2031	$self->alloc;	2258	$self->alloc;
2032		2259
2033	$self->pre_load;	2260	$self->pre_load;
2034	cf::cede_to_tick;	2261	cf::cede_to_tick;
2035		2262
		2263	if (exists $self->{load_path}) {
2036	my $f = new_from_file cf::object::thawer $self->{load_path};	2264	my $f = new_from_file cf::object::thawer $self->{load_path};
2037	$f->skip_block;	2265	$f->skip_block;
2038	$self->_load_objects ($f)	2266	$self->_load_objects ($f)
2039	or return;	2267	or return;
2040		2268
2041	$self->post_load_original	2269	$self->post_load_original
2042	if delete $self->{load_original};	2270	if delete $self->{load_original};
2043		2271
2044	if (my $uniq = $self->uniq_path) {	2272	if (my $uniq = $self->uniq_path) {
2045	utf8::encode $uniq;	2273	utf8::encode $uniq;
2046	unless (aio_stat $uniq) {	2274	unless (aio_stat $uniq) {
2047	if (my $f = new_from_file cf::object::thawer $uniq) {	2275	if (my $f = new_from_file cf::object::thawer $uniq) {
2048	$self->clear_unique_items;	2276	$self->clear_unique_items;
2049	$self->_load_objects ($f);	2277	$self->_load_objects ($f);
2050	$f->resolve_delayed_derefs;	2278	$f->resolve_delayed_derefs;
		2279	}
2051	}	2280	}
2052	}	2281	}
2053	}
2054		2282
2055	$f->resolve_delayed_derefs;	2283	$f->resolve_delayed_derefs;
		2284	} else {
		2285	$self->post_load_original
		2286	if delete $self->{load_original};
		2287	}
		2288
		2289	$self->state (cf::MAP_INACTIVE);
2056		2290
2057	cf::cede_to_tick;	2291	cf::cede_to_tick;
2058	# now do the right thing for maps	2292	# now do the right thing for maps
2059	$self->link_multipart_objects;	2293	$self->link_multipart_objects;
2060	$self->difficulty ($self->estimate_difficulty)	2294	$self->difficulty ($self->estimate_difficulty)
…		…
2064	unless ($self->{deny_activate}) {	2298	unless ($self->{deny_activate}) {
2065	$self->decay_objects;	2299	$self->decay_objects;
2066	$self->fix_auto_apply;	2300	$self->fix_auto_apply;
2067	$self->update_buttons;	2301	$self->update_buttons;
2068	cf::cede_to_tick;	2302	cf::cede_to_tick;
2069	$self->activate;	2303	#$self->activate; # no longer activate maps automatically
2070	}	2304	}
2071		2305
2072	$self->{last_save} = $cf::RUNTIME;	2306	$self->{last_save} = $cf::RUNTIME;
2073	$self->last_access ($cf::RUNTIME);	2307	$self->last_access ($cf::RUNTIME);
2074
2075	$self->in_memory (cf::MAP_ACTIVE);
2076	}	2308	}
2077		2309
2078	$self->post_load;	2310	$self->post_load;
2079	}
2080		2311
		2312	1
		2313	}
		2314
		2315	# customize the map for a given player, i.e.
		2316	# return the _real_ map. used by e.g. per-player
		2317	# maps to change the path to ~playername/mappath
2081	sub customise_for {	2318	sub customise_for {
2082	my ($self, $ob) = @_;	2319	my ($self, $ob) = @_;
2083		2320
2084	return find "~" . $ob->name . "/" . $self->{path}	2321	return find "~" . $ob->name . "/" . $self->{path}
2085	if $self->per_player;	2322	if $self->per_player;
…		…
2088	# if $self->per_party;	2325	# if $self->per_party;
2089		2326
2090	$self	2327	$self
2091	}	2328	}
2092		2329
2093	# find and load all maps in the 3x3 area around a map
2094	sub load_neighbours {
2095	my ($map) = @_;
2096
2097	my @neigh; # diagonal neighbours
2098
2099	for (0 .. 3) {
2100	my $neigh = $map->tile_path ($_)
2101	or next;
2102	$neigh = find $neigh, $map
2103	or next;
2104	$neigh->load;
2105
2106	push @neigh,
2107	[$neigh->tile_path (($_ + 3) % 4), $neigh],
2108	[$neigh->tile_path (($_ + 1) % 4), $neigh];
2109	}
2110
2111	for (grep defined $_->[0], @neigh) {
2112	my ($path, $origin) = @$_;
2113	my $neigh = find $path, $origin
2114	or next;
2115	$neigh->load;
2116	}
2117	}
2118
2119	sub find_sync {	2330	sub find_sync {
2120	my ($path, $origin) = @_;	2331	my ($path, $origin) = @_;
2121		2332
2122	cf::sync_job { find $path, $origin }	2333	# it's a bug to call this from the main context
		2334	return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
		2335	if $Coro::current == $Coro::main;
		2336
		2337	find $path, $origin
2123	}	2338	}
2124		2339
2125	sub do_load_sync {	2340	sub do_load_sync {
2126	my ($map) = @_;	2341	my ($map) = @_;
2127		2342
		2343	# it's a bug to call this from the main context
2128	cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"	2344	return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2129	if $Coro::current == $Coro::main;	2345	if $Coro::current == $Coro::main;
2130		2346
2131	cf::sync_job { $map->load };	2347	$map->load;
2132	}	2348	}
2133		2349
2134	our %MAP_PREFETCH;	2350	our %MAP_PREFETCH;
2135	our $MAP_PREFETCHER = undef;	2351	our $MAP_PREFETCHER = undef;
2136		2352
2137	sub find_async {	2353	sub find_async {
2138	my ($path, $origin, $load) = @_;	2354	my ($path, $origin, $load) = @_;
2139		2355
2140	$path = normalise $path, $origin && $origin->{path};	2356	$path = normalise $path, $origin;
2141		2357
2142	if (my $map = $cf::MAP{$path}) {	2358	if (my $map = $cf::MAP{$path}) {
2143	return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;	2359	return $map if !$load || $map->linkable;
2144	}	2360	}
2145		2361
2146	$MAP_PREFETCH{$path} |= $load;	2362	$MAP_PREFETCH{$path} |= $load;
2147		2363
2148	$MAP_PREFETCHER ||= cf::async {	2364	$MAP_PREFETCHER ||= cf::async {
…		…
2162	$MAP_PREFETCHER->prio (6);	2378	$MAP_PREFETCHER->prio (6);
2163		2379
2164	()	2380	()
2165	}	2381	}
2166		2382
		2383	# common code, used by both ->save and ->swapout
2167	sub save {	2384	sub _save {
2168	my ($self) = @_;	2385	my ($self) = @_;
2169
2170	my $lock = cf::lock_acquire "map_data:$self->{path}";
2171		2386
2172	$self->{last_save} = $cf::RUNTIME;	2387	$self->{last_save} = $cf::RUNTIME;
2173		2388
2174	return unless $self->dirty;	2389	return unless $self->dirty;
2175		2390
…		…
2195	} else {	2410	} else {
2196	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);	2411	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2197	}	2412	}
2198	}	2413	}
2199		2414
		2415	sub save {
		2416	my ($self) = @_;
		2417
		2418	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2419
		2420	$self->_save;
		2421	}
		2422
2200	sub swap_out {	2423	sub swap_out {
2201	my ($self) = @_;	2424	my ($self) = @_;
2202		2425
2203	# save first because save cedes
2204	$self->save;
2205
2206	my $lock = cf::lock_acquire "map_data:$self->{path}";	2426	my $lock = cf::lock_acquire "map_data:$self->{path}";
2207		2427
		2428	return if !$self->linkable;
		2429	return if $self->{deny_save};
2208	return if $self->players;	2430	return if $self->players;
2209	return if $self->in_memory != cf::MAP_ACTIVE;	2431
		2432	# first deactivate the map and "unlink" it from the core
		2433	$self->deactivate;
		2434	$_->clear_links_to ($self) for values %cf::MAP;
		2435	$self->state (cf::MAP_SWAPPED);
		2436
		2437	# then atomically save
		2438	$self->_save;
		2439
		2440	# then free the map
		2441	$self->clear;
		2442	}
		2443
		2444	sub reset_at {
		2445	my ($self) = @_;
		2446
		2447	# TODO: safety, remove and allow resettable per-player maps
2210	return if $self->{deny_save};	2448	return 1e99 if $self->{deny_reset};
2211		2449
		2450	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
		2451	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
		2452
		2453	$time + $to
		2454	}
		2455
		2456	sub should_reset {
		2457	my ($self) = @_;
		2458
		2459	$self->reset_at <= $cf::RUNTIME
		2460	}
		2461
		2462	sub reset {
		2463	my ($self) = @_;
		2464
		2465	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2466
		2467	return if $self->players;
		2468
		2469	cf::trace "resetting map ", $self->path, "\n";
		2470
2212	$self->in_memory (cf::MAP_SWAPPED);	2471	$self->state (cf::MAP_SWAPPED);
		2472
		2473	# need to save uniques path
		2474	unless ($self->{deny_save}) {
		2475	my $uniq = $self->uniq_path; utf8::encode $uniq;
		2476
		2477	$self->_save_objects ($uniq, cf::IO_UNIQUES)
		2478	if $uniq;
		2479	}
		2480
		2481	delete $cf::MAP{$self->path};
2213		2482
2214	$self->deactivate;	2483	$self->deactivate;
2215	$_->clear_links_to ($self) for values %cf::MAP;	2484	$_->clear_links_to ($self) for values %cf::MAP;
2216	$self->clear;	2485	$self->clear;
2217	}
2218
2219	sub reset_at {
2220	my ($self) = @_;
2221
2222	# TODO: safety, remove and allow resettable per-player maps
2223	return 1e99 if $self->{deny_reset};
2224
2225	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2226	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2227
2228	$time + $to
2229	}
2230
2231	sub should_reset {
2232	my ($self) = @_;
2233
2234	$self->reset_at <= $cf::RUNTIME
2235	}
2236
2237	sub reset {
2238	my ($self) = @_;
2239
2240	my $lock = cf::lock_acquire "map_data:$self->{path}";
2241
2242	return if $self->players;
2243
2244	warn "resetting map ", $self->path, "\n";
2245
2246	$self->in_memory (cf::MAP_SWAPPED);
2247
2248	# need to save uniques path
2249	unless ($self->{deny_save}) {
2250	my $uniq = $self->uniq_path; utf8::encode $uniq;
2251
2252	$self->_save_objects ($uniq, cf::IO_UNIQUES)
2253	if $uniq;
2254	}
2255
2256	delete $cf::MAP{$self->path};
2257
2258	$self->deactivate;
2259	$_->clear_links_to ($self) for values %cf::MAP;
2260	$self->clear;
2261		2486
2262	$self->unlink_save;	2487	$self->unlink_save;
2263	$self->destroy;	2488	$self->destroy;
2264	}	2489	}
2265		2490
…		…
2273		2498
2274	delete $cf::MAP{$self->path};	2499	delete $cf::MAP{$self->path};
2275		2500
2276	$self->unlink_save;	2501	$self->unlink_save;
2277		2502
2278	bless $self, "cf::map";	2503	bless $self, "cf::map::wrap";
2279	delete $self->{deny_reset};	2504	delete $self->{deny_reset};
2280	$self->{deny_save} = 1;	2505	$self->{deny_save} = 1;
2281	$self->reset_timeout (1);	2506	$self->reset_timeout (1);
2282	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2507	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2283		2508
…		…
2340	: normalise $_	2565	: normalise $_
2341	} @{ aio_readdir $UNIQUEDIR or [] }	2566	} @{ aio_readdir $UNIQUEDIR or [] }
2342	]	2567	]
2343	}	2568	}
2344		2569
		2570	=item cf::map::static_maps
		2571
		2572	Returns an arrayref if paths of all static maps (all preinstalled F<.map>
		2573	file in the shared directory excluding F</styles> and F</editor>). May
		2574	block.
		2575
		2576	=cut
		2577
		2578	sub static_maps() {
		2579	my @dirs = "";
		2580	my @maps;
		2581
		2582	while (@dirs) {
		2583	my $dir = shift @dirs;
		2584
		2585	next if $dir eq "/styles" || $dir eq "/editor";
		2586
		2587	my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
		2588	or return;
		2589
		2590	for (@$files) {
		2591	s/\.map$// or next;
		2592	utf8::decode $_;
		2593	push @maps, "$dir/$_";
		2594	}
		2595
		2596	push @dirs, map "$dir/$_", @$dirs;
		2597	}
		2598
		2599	\@maps
		2600	}
		2601
2345	=back	2602	=back
2346		2603
2347	=head3 cf::object	2604	=head3 cf::object
2348		2605
2349	=cut	2606	=cut
…		…
2481		2738
2482	Freezes the player and moves him/her to a special map (C<{link}>).	2739	Freezes the player and moves him/her to a special map (C<{link}>).
2483		2740
2484	The player should be reasonably safe there for short amounts of time (e.g.	2741	The player should be reasonably safe there for short amounts of time (e.g.
2485	for loading a map). You I<MUST> call C<leave_link> as soon as possible,	2742	for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2486	though, as the palyer cannot control the character while it is on the link	2743	though, as the player cannot control the character while it is on the link
2487	map.	2744	map.
2488		2745
2489	Will never block.	2746	Will never block.
2490		2747
2491	=item $player_object->leave_link ($map, $x, $y)	2748	=item $player_object->leave_link ($map, $x, $y)
…		…
2512	sub cf::object::player::enter_link {	2769	sub cf::object::player::enter_link {
2513	my ($self) = @_;	2770	my ($self) = @_;
2514		2771
2515	$self->deactivate_recursive;	2772	$self->deactivate_recursive;
2516		2773
		2774	++$self->{_link_recursion};
		2775
2517	return if UNIVERSAL::isa $self->map, "ext::map_link";	2776	return if UNIVERSAL::isa $self->map, "ext::map_link";
2518		2777
2519	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]	2778	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2520	if $self->map && $self->map->{path} ne "{link}";	2779	if $self->map && $self->map->{path} ne "{link}";
2521		2780
2522	$self->enter_map ($LINK_MAP || link_map, 10, 10);	2781	$self->enter_map ($LINK_MAP || link_map, 3, 3);
2523	}	2782	}
2524		2783
2525	sub cf::object::player::leave_link {	2784	sub cf::object::player::leave_link {
2526	my ($self, $map, $x, $y) = @_;	2785	my ($self, $map, $x, $y) = @_;
2527		2786
…		…
2544	($x, $y) = (-1, -1)	2803	($x, $y) = (-1, -1)
2545	unless (defined $x) && (defined $y);	2804	unless (defined $x) && (defined $y);
2546		2805
2547	# use -1 or undef as default coordinates, not 0, 0	2806	# use -1 or undef as default coordinates, not 0, 0
2548	($x, $y) = ($map->enter_x, $map->enter_y)	2807	($x, $y) = ($map->enter_x, $map->enter_y)
2549	if $x <=0 && $y <= 0;	2808	if $x <= 0 && $y <= 0;
2550		2809
2551	$map->load;	2810	$map->load;
2552	$map->load_neighbours;
2553		2811
2554	return unless $self->contr->active;	2812	return unless $self->contr->active;
2555		2813
2556	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2814	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2557	$self->enter_map ($map, $x, $y);	2815	if ($self->enter_map ($map, $x, $y)) {
2558		2816	# entering was successful
		2817	delete $self->{_link_recursion};
2559	# only activate afterwards, to support waiting in hooks	2818	# only activate afterwards, to support waiting in hooks
2560	$self->activate_recursive;	2819	$self->activate_recursive;
2561	}	2820	}
2562		2821
		2822	}
		2823
2563	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])	2824	=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2564		2825
2565	Moves the player to the given map-path and coordinates by first freezing	2826	Moves the player to the given map-path and coordinates by first freezing
2566	her, loading and preparing them map, calling the provided $check callback	2827	her, loading and preparing them map, calling the provided $check callback
2567	that has to return the map if sucecssful, and then unfreezes the player on	2828	that has to return the map if sucecssful, and then unfreezes the player on
2568	the new (success) or old (failed) map position. In either case, $done will	2829	the new (success) or old (failed) map position. In either case, $done will
…		…
2575		2836
2576	our $GOTOGEN;	2837	our $GOTOGEN;
2577		2838
2578	sub cf::object::player::goto {	2839	sub cf::object::player::goto {
2579	my ($self, $path, $x, $y, $check, $done) = @_;	2840	my ($self, $path, $x, $y, $check, $done) = @_;
		2841
		2842	if ($self->{_link_recursion} >= $MAX_LINKS) {
		2843	error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
		2844	$self->failmsg ("Something went wrong inside the server - please contact an administrator!");
		2845	($path, $x, $y) = @$EMERGENCY_POSITION;
		2846	}
2580		2847
2581	# do generation counting so two concurrent goto's will be executed in-order	2848	# do generation counting so two concurrent goto's will be executed in-order
2582	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2849	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2583		2850
2584	$self->enter_link;	2851	$self->enter_link;
…		…
2604	($path, $x, $y) = (undef, undef, undef);	2871	($path, $x, $y) = (undef, undef, undef);
2605	}	2872	}
2606	}	2873	}
2607		2874
2608	my $map = eval {	2875	my $map = eval {
2609	my $map = defined $path ? cf::map::find $path : undef;	2876	my $map = defined $path ? cf::map::find $path, $self->map : undef;
2610		2877
2611	if ($map) {	2878	if ($map) {
2612	$map = $map->customise_for ($self);	2879	$map = $map->customise_for ($self);
2613	$map = $check->($map) if $check && $map;	2880	$map = $check->($map, $x, $y, $self) if $check && $map;
2614	} else {	2881	} else {
2615	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);	2882	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2616	}	2883	}
2617		2884
2618	$map	2885	$map
…		…
2626	if ($gen == $self->{_goto_generation}) {	2893	if ($gen == $self->{_goto_generation}) {
2627	delete $self->{_goto_generation};	2894	delete $self->{_goto_generation};
2628	$self->leave_link ($map, $x, $y);	2895	$self->leave_link ($map, $x, $y);
2629	}	2896	}
2630		2897
2631	$done->() if $done;	2898	$done->($self) if $done;
2632	})->prio (1);	2899	})->prio (1);
2633	}	2900	}
2634		2901
2635	=item $player_object->enter_exit ($exit_object)	2902	=item $player_object->enter_exit ($exit_object)
2636		2903
…		…
2704	$Coro::current->{desc} = "enter_exit";	2971	$Coro::current->{desc} = "enter_exit";
2705		2972
2706	unless (eval {	2973	unless (eval {
2707	$self->deactivate_recursive; # just to be sure	2974	$self->deactivate_recursive; # just to be sure
2708		2975
2709	# random map handling
2710	{
2711	my $guard = cf::lock_acquire "exit_prepare:$exit";
2712
2713	prepare_random_map $exit
2714	if $exit->slaying eq "/!";
2715	}
2716
2717	my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;	2976	my $map = cf::map::normalise $exit->slaying, $exit->map;
2718	my $x = $exit->stats->hp;	2977	my $x = $exit->stats->hp;
2719	my $y = $exit->stats->sp;	2978	my $y = $exit->stats->sp;
		2979
		2980	# special map handling
		2981	my $slaying = $exit->slaying;
		2982
		2983	# special map handling
		2984	if ($slaying eq "/!") {
		2985	my $guard = cf::lock_acquire "exit_prepare:$exit";
		2986
		2987	prepare_random_map $exit
		2988	if $exit->slaying eq "/!"; # need to re-check after getting the lock
		2989
		2990	$map = $exit->slaying;
		2991
		2992	} elsif ($slaying eq '!up') {
		2993	$map = $exit->map->tile_path (cf::TILE_UP);
		2994	$x = $exit->x;
		2995	$y = $exit->y;
		2996
		2997	} elsif ($slaying eq '!down') {
		2998	$map = $exit->map->tile_path (cf::TILE_DOWN);
		2999	$x = $exit->x;
		3000	$y = $exit->y;
		3001	}
2720		3002
2721	$self->goto ($map, $x, $y);	3003	$self->goto ($map, $x, $y);
2722		3004
2723	# if exit is damned, update players death & WoR home-position	3005	# if exit is damned, update players death & WoR home-position
2724	$self->contr->savebed ($map, $x, $y)	3006	$self->contr->savebed ($map, $x, $y)
…		…
2729	$self->message ("Something went wrong deep within the deliantra server. "	3011	$self->message ("Something went wrong deep within the deliantra server. "
2730	. "I'll try to bring you back to the map you were before. "	3012	. "I'll try to bring you back to the map you were before. "
2731	. "Please report this to the dungeon master!",	3013	. "Please report this to the dungeon master!",
2732	cf::NDI_UNIQUE | cf::NDI_RED);	3014	cf::NDI_UNIQUE | cf::NDI_RED);
2733		3015
2734	warn "ERROR in enter_exit: $@";	3016	error "ERROR in enter_exit: $@";
2735	$self->leave_link;	3017	$self->leave_link;
2736	}	3018	}
2737	})->prio (1);	3019	})->prio (1);
2738	}	3020	}
2739		3021
…		…
2751	sub cf::client::send_drawinfo {	3033	sub cf::client::send_drawinfo {
2752	my ($self, $text, $flags) = @_;	3034	my ($self, $text, $flags) = @_;
2753		3035
2754	utf8::encode $text;	3036	utf8::encode $text;
2755	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);	3037	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
		3038	}
		3039
		3040	=item $client->send_big_packet ($pkt)
		3041
		3042	Like C<send_packet>, but tries to compress large packets, and fragments
		3043	them as required.
		3044
		3045	=cut
		3046
		3047	our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
		3048
		3049	sub cf::client::send_big_packet {
		3050	my ($self, $pkt) = @_;
		3051
		3052	# try lzf for large packets
		3053	$pkt = "lzf " . Compress::LZF::compress $pkt
		3054	if 1024 <= length $pkt and $self->{can_lzf};
		3055
		3056	# split very large packets
		3057	if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
		3058	$self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
		3059	$pkt = "frag";
		3060	}
		3061
		3062	$self->send_packet ($pkt);
2756	}	3063	}
2757		3064
2758	=item $client->send_msg ($channel, $msg, $color, [extra...])	3065	=item $client->send_msg ($channel, $msg, $color, [extra...])
2759		3066
2760	Send a drawinfo or msg packet to the client, formatting the msg for the	3067	Send a drawinfo or msg packet to the client, formatting the msg for the
…		…
2764		3071
2765	=cut	3072	=cut
2766		3073
2767	# non-persistent channels (usually the info channel)	3074	# non-persistent channels (usually the info channel)
2768	our %CHANNEL = (	3075	our %CHANNEL = (
		3076	"c/motd" => {
		3077	id => "infobox",
		3078	title => "MOTD",
		3079	reply => undef,
		3080	tooltip => "The message of the day",
		3081	},
2769	"c/identify" => {	3082	"c/identify" => {
2770	id => "infobox",	3083	id => "infobox",
2771	title => "Identify",	3084	title => "Identify",
2772	reply => undef,	3085	reply => undef,
2773	tooltip => "Items recently identified",	3086	tooltip => "Items recently identified",
…		…
2775	"c/examine" => {	3088	"c/examine" => {
2776	id => "infobox",	3089	id => "infobox",
2777	title => "Examine",	3090	title => "Examine",
2778	reply => undef,	3091	reply => undef,
2779	tooltip => "Signs and other items you examined",	3092	tooltip => "Signs and other items you examined",
		3093	},
		3094	"c/shopinfo" => {
		3095	id => "infobox",
		3096	title => "Shop Info",
		3097	reply => undef,
		3098	tooltip => "What your bargaining skill tells you about the shop",
2780	},	3099	},
2781	"c/book" => {	3100	"c/book" => {
2782	id => "infobox",	3101	id => "infobox",
2783	title => "Book",	3102	title => "Book",
2784	reply => undef,	3103	reply => undef,
…		…
2900	my $pkt = "msg "	3219	my $pkt = "msg "
2901	. $self->{json_coder}->encode (	3220	. $self->{json_coder}->encode (
2902	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]	3221	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2903	);	3222	);
2904		3223
2905	# try lzf for large packets
2906	$pkt = "lzf " . Compress::LZF::compress $pkt
2907	if 1024 <= length $pkt and $self->{can_lzf};
2908
2909	# split very large packets
2910	if (8192 < length $pkt and $self->{can_lzf}) {
2911	$self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2912	$pkt = "frag";
2913	}
2914
2915	$self->send_packet ($pkt);	3224	$self->send_big_packet ($pkt);
2916	}	3225	}
2917		3226
2918	=item $client->ext_msg ($type, @msg)	3227	=item $client->ext_msg ($type, @msg)
2919		3228
2920	Sends an ext event to the client.	3229	Sends an ext event to the client.
…		…
2923		3232
2924	sub cf::client::ext_msg($$@) {	3233	sub cf::client::ext_msg($$@) {
2925	my ($self, $type, @msg) = @_;	3234	my ($self, $type, @msg) = @_;
2926		3235
2927	if ($self->extcmd == 2) {	3236	if ($self->extcmd == 2) {
2928	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));	3237	$self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2929	} elsif ($self->extcmd == 1) { # TODO: remove	3238	} elsif ($self->extcmd == 1) { # TODO: remove
2930	push @msg, msgtype => "event_$type";	3239	push @msg, msgtype => "event_$type";
2931	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));	3240	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2932	}	3241	}
2933	}	3242	}
2934		3243
2935	=item $client->ext_reply ($msgid, @msg)	3244	=item $client->ext_reply ($msgid, @msg)
2936		3245
…		…
2939	=cut	3248	=cut
2940		3249
2941	sub cf::client::ext_reply($$@) {	3250	sub cf::client::ext_reply($$@) {
2942	my ($self, $id, @msg) = @_;	3251	my ($self, $id, @msg) = @_;
2943		3252
2944	if ($self->extcmd == 2) {	3253	return unless $self->extcmd == 2;
		3254
2945	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));	3255	$self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2946	} elsif ($self->extcmd == 1) {
2947	#TODO: version 1, remove
2948	unshift @msg, msgtype => "reply", msgid => $id;
2949	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2950	}
2951	}	3256	}
2952		3257
2953	=item $success = $client->query ($flags, "text", \&cb)	3258	=item $success = $client->query ($flags, "text", \&cb)
2954		3259
2955	Queues a query to the client, calling the given callback with	3260	Queues a query to the client, calling the given callback with
…		…
3010	my ($ns, $buf) = @_;	3315	my ($ns, $buf) = @_;
3011		3316
3012	my $msg = eval { $ns->{json_coder}->decode ($buf) };	3317	my $msg = eval { $ns->{json_coder}->decode ($buf) };
3013		3318
3014	if (ref $msg) {	3319	if (ref $msg) {
3015	my ($type, $reply, @payload) =	3320	my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3016	"ARRAY" eq ref $msg
3017	? @$msg
3018	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3019		3321
3020	my @reply;	3322	my @reply;
3021		3323
3022	if (my $cb = $EXTICMD{$type}) {	3324	if (my $cb = $EXTICMD{$type}) {
3023	@reply = $cb->($ns, @payload);	3325	@reply = $cb->($ns, @payload);
…		…
3025		3327
3026	$ns->ext_reply ($reply, @reply)	3328	$ns->ext_reply ($reply, @reply)
3027	if $reply;	3329	if $reply;
3028		3330
3029	} else {	3331	} else {
3030	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	3332	error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3031	}	3333	}
3032		3334
3033	cf::override;	3335	cf::override;
3034	},	3336	},
3035	);	3337	);
…		…
3055		3357
3056	$coro	3358	$coro
3057	}	3359	}
3058		3360
3059	cf::client->attach (	3361	cf::client->attach (
3060	on_destroy => sub {	3362	on_client_destroy => sub {
3061	my ($ns) = @_;	3363	my ($ns) = @_;
3062		3364
3063	$_->cancel for values %{ (delete $ns->{_coro}) || {} };	3365	$_->cancel for values %{ (delete $ns->{_coro}) || {} };
3064	},	3366	},
3065	);	3367	);
…		…
3081	our $safe_hole = new Safe::Hole;	3383	our $safe_hole = new Safe::Hole;
3082		3384
3083	$SIG{FPE} = 'IGNORE';	3385	$SIG{FPE} = 'IGNORE';
3084		3386
3085	$safe->permit_only (Opcode::opset qw(	3387	$safe->permit_only (Opcode::opset qw(
3086	:base_core :base_mem :base_orig :base_math	3388	:base_core :base_mem :base_orig :base_math :base_loop
3087	grepstart grepwhile mapstart mapwhile	3389	grepstart grepwhile mapstart mapwhile
3088	sort time	3390	sort time
3089	));	3391	));
3090		3392
3091	# here we export the classes and methods available to script code	3393	# here we export the classes and methods available to script code
…		…
3116	decrease split destroy change_exp value msg lore send_msg)],	3418	decrease split destroy change_exp value msg lore send_msg)],
3117	["cf::object::player" => qw(player)],	3419	["cf::object::player" => qw(player)],
3118	["cf::player" => qw(peaceful send_msg)],	3420	["cf::player" => qw(peaceful send_msg)],
3119	["cf::map" => qw(trigger)],	3421	["cf::map" => qw(trigger)],
3120	) {	3422	) {
3121	no strict 'refs';
3122	my ($pkg, @funs) = @$_;	3423	my ($pkg, @funs) = @$_;
3123	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	3424	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3124	for @funs;	3425	for @funs;
3125	}	3426	}
3126		3427
…		…
3143	$qcode =~ s/"/‟/g; # not allowed in #line filenames	3444	$qcode =~ s/"/‟/g; # not allowed in #line filenames
3144	$qcode =~ s/\n/\\n/g;	3445	$qcode =~ s/\n/\\n/g;
3145		3446
3146	%vars = (_dummy => 0) unless %vars;	3447	%vars = (_dummy => 0) unless %vars;
3147		3448
		3449	my @res;
3148	local $_;	3450	local $_;
3149	local @safe::cf::_safe_eval_args = values %vars;
3150		3451
3151	my $eval =	3452	my $eval =
3152	"do {\n"	3453	"do {\n"
3153	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"	3454	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3154	. "#line 0 \"{$qcode}\"\n"	3455	. "#line 0 \"{$qcode}\"\n"
3155	. $code	3456	. $code
3156	. "\n}"	3457	. "\n}"
3157	;	3458	;
3158		3459
		3460	if ($CFG{safe_eval}) {
3159	sub_generation_inc;	3461	sub_generation_inc;
		3462	local @safe::cf::_safe_eval_args = values %vars;
3160	my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);	3463	@res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3161	sub_generation_inc;	3464	sub_generation_inc;
		3465	} else {
		3466	local @cf::_safe_eval_args = values %vars;
		3467	@res = wantarray ? eval eval : scalar eval $eval;
		3468	}
3162		3469
3163	if ($@) {	3470	if ($@) {
3164	warn "$@";	3471	warn "$@",
3165	warn "while executing safe code '$code'\n";	3472	"while executing safe code '$code'\n",
3166	warn "with arguments " . (join " ", %vars) . "\n";	3473	"with arguments " . (join " ", %vars) . "\n";
3167	}	3474	}
3168		3475
3169	wantarray ? @res : $res[0]	3476	wantarray ? @res : $res[0]
3170	}	3477	}
3171		3478
…		…
3185	=cut	3492	=cut
3186		3493
3187	sub register_script_function {	3494	sub register_script_function {
3188	my ($fun, $cb) = @_;	3495	my ($fun, $cb) = @_;
3189		3496
3190	no strict 'refs';	3497	$fun = "safe::$fun" if $CFG{safe_eval};
3191	*{"safe::$fun"} = $safe_hole->wrap ($cb);	3498	*$fun = $safe_hole->wrap ($cb);
3192	}	3499	}
3193		3500
3194	=back	3501	=back
3195		3502
3196	=cut	3503	=cut
…		…
3205	# for this (global event?)	3512	# for this (global event?)
3206	%ext::player_env::MUSIC_FACE_CACHE = ();	3513	%ext::player_env::MUSIC_FACE_CACHE = ();
3207		3514
3208	my $enc = JSON::XS->new->utf8->canonical->relaxed;	3515	my $enc = JSON::XS->new->utf8->canonical->relaxed;
3209		3516
3210	warn "loading facedata from $path\n";	3517	trace "loading facedata from $path\n";
3211		3518
3212	my $facedata;	3519	my $facedata = decode_storable load_file $path;
3213	0 < aio_load $path, $facedata
3214	or die "$path: $!";
3215
3216	$facedata = Coro::Storable::thaw $facedata;
3217		3520
3218	$facedata->{version} == 2	3521	$facedata->{version} == 2
3219	or cf::cleanup "$path: version mismatch, cannot proceed.";	3522	or cf::cleanup "$path: version mismatch, cannot proceed.";
3220		3523
3221	# patch in the exptable	3524	# patch in the exptable
		3525	my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3222	$facedata->{resource}{"res/exp_table"} = {	3526	$facedata->{resource}{"res/exp_table"} = {
3223	type => FT_RSRC,	3527	type => FT_RSRC,
3224	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),	3528	data => $exp_table,
		3529	hash => (Digest::MD5::md5 $exp_table),
3225	};	3530	};
3226	cf::cede_to_tick;	3531	cf::cede_to_tick;
3227		3532
3228	{	3533	{
3229	my $faces = $facedata->{faceinfo};	3534	my $faces = $facedata->{faceinfo};
…		…
3231	while (my ($face, $info) = each %$faces) {	3536	while (my ($face, $info) = each %$faces) {
3232	my $idx = (cf::face::find $face) || cf::face::alloc $face;	3537	my $idx = (cf::face::find $face) || cf::face::alloc $face;
3233		3538
3234	cf::face::set_visibility $idx, $info->{visibility};	3539	cf::face::set_visibility $idx, $info->{visibility};
3235	cf::face::set_magicmap $idx, $info->{magicmap};	3540	cf::face::set_magicmap $idx, $info->{magicmap};
3236	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};	3541	cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3237	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};	3542	cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
		3543	cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3238		3544
3239	cf::cede_to_tick;	3545	cf::cede_to_tick;
3240	}	3546	}
3241		3547
3242	while (my ($face, $info) = each %$faces) {	3548	while (my ($face, $info) = each %$faces) {
…		…
3247		3553
3248	if (my $smooth = cf::face::find $info->{smooth}) {	3554	if (my $smooth = cf::face::find $info->{smooth}) {
3249	cf::face::set_smooth $idx, $smooth;	3555	cf::face::set_smooth $idx, $smooth;
3250	cf::face::set_smoothlevel $idx, $info->{smoothlevel};	3556	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3251	} else {	3557	} else {
3252	warn "smooth face '$info->{smooth}' not found for face '$face'";	3558	error "smooth face '$info->{smooth}' not found for face '$face'";
3253	}	3559	}
3254		3560
3255	cf::cede_to_tick;	3561	cf::cede_to_tick;
3256	}	3562	}
3257	}	3563	}
…		…
3266		3572
3267	cf::anim::invalidate_all; # d'oh	3573	cf::anim::invalidate_all; # d'oh
3268	}	3574	}
3269		3575
3270	{	3576	{
3271	# TODO: for gcfclient pleasure, we should give resources
3272	# that gcfclient doesn't grok a >10000 face index.
3273	my $res = $facedata->{resource};	3577	my $res = $facedata->{resource};
3274		3578
3275	while (my ($name, $info) = each %$res) {	3579	while (my ($name, $info) = each %$res) {
3276	if (defined $info->{type}) {	3580	if (defined (my $type = $info->{type})) {
		3581	# TODO: different hash - must free and use new index, or cache ixface data queue
3277	my $idx = (cf::face::find $name) || cf::face::alloc $name;	3582	my $idx = (cf::face::find $name) || cf::face::alloc $name;
3278	my $data;
3279		3583
3280	if ($info->{type} & 1) {	3584	cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3281	# prepend meta info
3282
3283	my $meta = $enc->encode ({
3284	name => $name,
3285	%{ $info->{meta} || {} },
3286	});
3287
3288	$data = pack "(w/a*)*", $meta, $info->{data};
3289	} else {
3290	$data = $info->{data};
3291	}
3292
3293	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3294	cf::face::set_type $idx, $info->{type};	3585	cf::face::set_type $idx, $type;
		3586	cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3295	} else {	3587	} else {
3296	$RESOURCE{$name} = $info;	3588	# $RESOURCE{$name} = $info; # unused
3297	}	3589	}
3298		3590
3299	cf::cede_to_tick;	3591	cf::cede_to_tick;
3300	}	3592	}
3301	}	3593	}
3302		3594
3303	cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);	3595	cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3304		3596
3305	1	3597	1
3306	}	3598	}
3307
3308	cf::global->attach (on_resource_update => sub {
3309	if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3310	$soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3311
3312	for (0 .. SOUND_CAST_SPELL_0 - 1) {
3313	my $sound = $soundconf->{compat}[$_]
3314	or next;
3315
3316	my $face = cf::face::find "sound/$sound->[1]";
3317	cf::sound::set $sound->[0] => $face;
3318	cf::sound::old_sound_index $_, $face; # gcfclient-compat
3319	}
3320
3321	while (my ($k, $v) = each %{$soundconf->{event}}) {
3322	my $face = cf::face::find "sound/$v";
3323	cf::sound::set $k => $face;
3324	}
3325	}
3326	});
3327		3599
3328	register_exticmd fx_want => sub {	3600	register_exticmd fx_want => sub {
3329	my ($ns, $want) = @_;	3601	my ($ns, $want) = @_;
3330		3602
3331	while (my ($k, $v) = each %$want) {	3603	while (my ($k, $v) = each %$want) {
…		…
3370	sub reload_treasures {	3642	sub reload_treasures {
3371	load_resource_file "$DATADIR/treasures"	3643	load_resource_file "$DATADIR/treasures"
3372	or die "unable to load treasurelists\n";	3644	or die "unable to load treasurelists\n";
3373	}	3645	}
3374		3646
		3647	sub reload_sound {
		3648	trace "loading sound config from $DATADIR/sound\n";
		3649
		3650	my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
		3651
		3652	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3653	my $sound = $soundconf->{compat}[$_]
		3654	or next;
		3655
		3656	my $face = cf::face::find "sound/$sound->[1]";
		3657	cf::sound::set $sound->[0] => $face;
		3658	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3659	}
		3660
		3661	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3662	my $face = cf::face::find "sound/$v";
		3663	cf::sound::set $k => $face;
		3664	}
		3665	}
		3666
3375	sub reload_resources {	3667	sub reload_resources {
3376	warn "reloading resource files...\n";	3668	trace "reloading resource files...\n";
3377		3669
		3670	reload_exp_table;
		3671	reload_materials;
3378	reload_facedata;	3672	reload_facedata;
		3673	reload_sound;
3379	reload_archetypes;	3674	reload_archetypes;
3380	reload_regions;	3675	reload_regions;
3381	reload_treasures;	3676	reload_treasures;
3382		3677
3383	warn "finished reloading resource files\n";	3678	trace "finished reloading resource files\n";
3384	}	3679	}
3385		3680
3386	sub reload_config {	3681	sub reload_config {
3387	open my $fh, "<:utf8", "$CONFDIR/config"	3682	trace "reloading config file...\n";
3388	or return;
3389		3683
3390	local $/;	3684	my $config = load_file "$CONFDIR/config";
3391	*CFG = YAML::Load <$fh>;	3685	utf8::decode $config;
		3686	*CFG = decode_yaml $config;
3392		3687
3393	$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];	3688	$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3394		3689
3395	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};	3690	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3396	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};	3691	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3397		3692
3398	if (exists $CFG{mlockall}) {	3693	if (exists $CFG{mlockall}) {
…		…
3422	seek $fh, 0, 0;	3717	seek $fh, 0, 0;
3423	print $fh $$;	3718	print $fh $$;
3424	}	3719	}
3425		3720
3426	sub main_loop {	3721	sub main_loop {
3427	warn "EV::loop starting\n";	3722	trace "EV::loop starting\n";
3428	if (1) {	3723	if (1) {
3429	EV::loop;	3724	EV::loop;
3430	}	3725	}
3431	warn "EV::loop returned\n";	3726	trace "EV::loop returned\n";
3432	goto &main_loop unless $REALLY_UNLOOP;	3727	goto &main_loop unless $REALLY_UNLOOP;
3433	}	3728	}
3434		3729
3435	sub main {	3730	sub main {
3436	cf::init_globals; # initialise logging	3731	cf::init_globals; # initialise logging
3437		3732
3438	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;	3733	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3439	LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";	3734	LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3440	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";	3735	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3441	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";	3736	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3442
3443	cf::init_experience;
3444	cf::init_anim;
3445	cf::init_attackmess;
3446	cf::init_dynamic;
3447		3737
3448	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority	3738	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3449		3739
3450	# we must not ever block the main coroutine	3740	# we must not ever block the main coroutine
3451	local $Coro::idle = sub {	3741	local $Coro::idle = sub {
…		…
3457	};	3747	};
3458		3748
3459	evthread_start IO::AIO::poll_fileno;	3749	evthread_start IO::AIO::poll_fileno;
3460		3750
3461	cf::sync_job {	3751	cf::sync_job {
		3752	cf::incloader::init ();
		3753
		3754	cf::init_anim;
		3755	cf::init_attackmess;
		3756	cf::init_dynamic;
		3757
		3758	cf::load_settings;
		3759
3462	reload_resources;	3760	reload_resources;
3463	reload_config;	3761	reload_config;
3464	db_init;	3762	db_init;
3465		3763
3466	cf::load_settings;
3467	cf::load_materials;
3468	cf::init_uuid;	3764	cf::init_uuid;
3469	cf::init_signals;	3765	cf::init_signals;
3470	cf::init_commands;
3471	cf::init_skills;	3766	cf::init_skills;
3472		3767
3473	cf::init_beforeplay;	3768	cf::init_beforeplay;
3474		3769
3475	atomic;	3770	atomic;
…		…
3480		3775
3481	# no (long-running) fork's whatsoever before this point(!)	3776	# no (long-running) fork's whatsoever before this point(!)
3482	use POSIX ();	3777	use POSIX ();
3483	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};	3778	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3484		3779
3485	(pop @POST_INIT)->(0) while @POST_INIT;	3780	cf::_post_init 0;
3486	};	3781	};
3487		3782
		3783	cf::object::thawer::errors_are_fatal 0;
		3784	info "parse errors in files are no longer fatal from this point on.\n";
		3785
		3786	AE::postpone {
		3787	undef &main; # free gobs of memory :)
		3788	};
		3789
3488	main_loop;	3790	goto &main_loop;
3489	}	3791	}
3490		3792
3491	#############################################################################	3793	#############################################################################
3492	# initialisation and cleanup	3794	# initialisation and cleanup
3493		3795
3494	# install some emergency cleanup handlers	3796	# install some emergency cleanup handlers
3495	BEGIN {	3797	BEGIN {
3496	our %SIGWATCHER = ();	3798	our %SIGWATCHER = ();
3497	for my $signal (qw(INT HUP TERM)) {	3799	for my $signal (qw(INT HUP TERM)) {
3498	$SIGWATCHER{$signal} = EV::signal $signal, sub {	3800	$SIGWATCHER{$signal} = AE::signal $signal, sub {
3499	cf::cleanup "SIG$signal";	3801	cf::cleanup "SIG$signal";
3500	};	3802	};
3501	}	3803	}
3502	}	3804	}
3503		3805
3504	sub write_runtime_sync {	3806	sub write_runtime_sync {
		3807	my $t0 = AE::time;
		3808
3505	# first touch the runtime file to show we are still running:	3809	# first touch the runtime file to show we are still running:
3506	# the fsync below can take a very very long time.	3810	# the fsync below can take a very very long time.
3507		3811
3508	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;	3812	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3509		3813
3510	my $guard = cf::lock_acquire "write_runtime";	3814	my $guard = cf::lock_acquire "write_runtime";
3511		3815
3512	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644	3816	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3513	or return;	3817	or return;
3514		3818
3515	my $value = $cf::RUNTIME + 90 + 10;	3819	my $value = $cf::RUNTIME + 90 + 10;
3516	# 10 is the runtime save interval, for a monotonic clock	3820	# 10 is the runtime save interval, for a monotonic clock
3517	# 60 allows for the watchdog to kill the server.	3821	# 60 allows for the watchdog to kill the server.
…		…
3530	or return;	3834	or return;
3531		3835
3532	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE	3836	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3533	and return;	3837	and return;
3534		3838
3535	warn "runtime file written.\n";	3839	trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3536		3840
3537	1	3841	1
3538	}	3842	}
3539		3843
3540	our $uuid_lock;	3844	our $uuid_lock;
…		…
3552	or return;	3856	or return;
3553		3857
3554	my $value = uuid_seq uuid_cur;	3858	my $value = uuid_seq uuid_cur;
3555		3859
3556	unless ($value) {	3860	unless ($value) {
3557	warn "cowardly refusing to write zero uuid value!\n";	3861	info "cowardly refusing to write zero uuid value!\n";
3558	return;	3862	return;
3559	}	3863	}
3560		3864
3561	my $value = uuid_str $value + $uuid_skip;	3865	my $value = uuid_str $value + $uuid_skip;
3562	$uuid_skip = 0;	3866	$uuid_skip = 0;
…		…
3572	or return;	3876	or return;
3573		3877
3574	aio_rename "$uuid~", $uuid	3878	aio_rename "$uuid~", $uuid
3575	and return;	3879	and return;
3576		3880
3577	warn "uuid file written ($value).\n";	3881	trace "uuid file written ($value).\n";
3578		3882
3579	1	3883	1
3580		3884
3581	}	3885	}
3582		3886
…		…
3588	}	3892	}
3589		3893
3590	sub emergency_save() {	3894	sub emergency_save() {
3591	my $freeze_guard = cf::freeze_mainloop;	3895	my $freeze_guard = cf::freeze_mainloop;
3592		3896
3593	warn "emergency_perl_save: enter\n";	3897	info "emergency_perl_save: enter\n";
		3898
		3899	# this is a trade-off: we want to be very quick here, so
		3900	# save all maps without fsync, and later call a global sync
		3901	# (which in turn might be very very slow)
		3902	local $USE_FSYNC = 0;
3594		3903
3595	cf::sync_job {	3904	cf::sync_job {
3596	# this is a trade-off: we want to be very quick here, so	3905	cf::write_runtime_sync; # external watchdog should not bark
3597	# save all maps without fsync, and later call a global sync
3598	# (which in turn might be very very slow)
3599	local $USE_FSYNC = 0;
3600		3906
3601	# use a peculiar iteration method to avoid tripping on perl	3907	# use a peculiar iteration method to avoid tripping on perl
3602	# refcount bugs in for. also avoids problems with players	3908	# refcount bugs in for. also avoids problems with players
3603	# and maps saved/destroyed asynchronously.	3909	# and maps saved/destroyed asynchronously.
3604	warn "emergency_perl_save: begin player save\n";	3910	info "emergency_perl_save: begin player save\n";
3605	for my $login (keys %cf::PLAYER) {	3911	for my $login (keys %cf::PLAYER) {
3606	my $pl = $cf::PLAYER{$login} or next;	3912	my $pl = $cf::PLAYER{$login} or next;
3607	$pl->valid or next;	3913	$pl->valid or next;
3608	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt	3914	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3609	$pl->save;	3915	$pl->save;
3610	}	3916	}
3611	warn "emergency_perl_save: end player save\n";	3917	info "emergency_perl_save: end player save\n";
3612		3918
		3919	cf::write_runtime_sync; # external watchdog should not bark
		3920
3613	warn "emergency_perl_save: begin map save\n";	3921	info "emergency_perl_save: begin map save\n";
3614	for my $path (keys %cf::MAP) {	3922	for my $path (keys %cf::MAP) {
3615	my $map = $cf::MAP{$path} or next;	3923	my $map = $cf::MAP{$path} or next;
3616	$map->valid or next;	3924	$map->valid or next;
3617	$map->save;	3925	$map->save;
3618	}	3926	}
3619	warn "emergency_perl_save: end map save\n";	3927	info "emergency_perl_save: end map save\n";
3620		3928
		3929	cf::write_runtime_sync; # external watchdog should not bark
		3930
3621	warn "emergency_perl_save: begin database checkpoint\n";	3931	info "emergency_perl_save: begin database checkpoint\n";
3622	BDB::db_env_txn_checkpoint $DB_ENV;	3932	BDB::db_env_txn_checkpoint $DB_ENV;
3623	warn "emergency_perl_save: end database checkpoint\n";	3933	info "emergency_perl_save: end database checkpoint\n";
3624		3934
3625	warn "emergency_perl_save: begin write uuid\n";	3935	info "emergency_perl_save: begin write uuid\n";
3626	write_uuid_sync 1;	3936	write_uuid_sync 1;
3627	warn "emergency_perl_save: end write uuid\n";	3937	info "emergency_perl_save: end write uuid\n";
		3938
		3939	cf::write_runtime_sync; # external watchdog should not bark
		3940
		3941	trace "emergency_perl_save: syncing database to disk";
		3942	BDB::db_env_txn_checkpoint $DB_ENV;
		3943
		3944	info "emergency_perl_save: starting sync\n";
		3945	IO::AIO::aio_sync sub {
		3946	info "emergency_perl_save: finished sync\n";
		3947	};
		3948
		3949	cf::write_runtime_sync; # external watchdog should not bark
		3950
		3951	trace "emergency_perl_save: flushing outstanding aio requests";
		3952	while (IO::AIO::nreqs || BDB::nreqs) {
		3953	Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
		3954	}
		3955
		3956	cf::write_runtime_sync; # external watchdog should not bark
3628	};	3957	};
3629		3958
3630	warn "emergency_perl_save: starting sync()\n";
3631	IO::AIO::aio_sync sub {
3632	warn "emergency_perl_save: finished sync()\n";
3633	};
3634
3635	warn "emergency_perl_save: leave\n";	3959	info "emergency_perl_save: leave\n";
3636	}	3960	}
3637		3961
3638	sub post_cleanup {	3962	sub post_cleanup {
3639	my ($make_core) = @_;	3963	my ($make_core) = @_;
3640		3964
		3965	IO::AIO::flush;
		3966
3641	warn Carp::longmess "post_cleanup backtrace"	3967	error Carp::longmess "post_cleanup backtrace"
3642	if $make_core;	3968	if $make_core;
3643		3969
3644	my $fh = pidfile;	3970	my $fh = pidfile;
3645	unlink $PIDFILE if <$fh> == $$;	3971	unlink $PIDFILE if <$fh> == $$;
3646	}	3972	}
…		…
3666	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};	3992	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3667	for my $name (keys %$leaf_symtab) {	3993	for my $name (keys %$leaf_symtab) {
3668	_gv_clear *{"$pkg$name"};	3994	_gv_clear *{"$pkg$name"};
3669	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};	3995	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3670	}	3996	}
3671	warn "cleared package $pkg\n";#d#
3672	}	3997	}
3673		3998
3674	sub do_reload_perl() {	3999	sub do_reload_perl() {
3675	# can/must only be called in main	4000	# can/must only be called in main
3676	if ($Coro::current != $Coro::main) {	4001	unless (in_main) {
3677	warn "can only reload from main coroutine";	4002	error "can only reload from main coroutine";
3678	return;	4003	return;
3679	}	4004	}
3680		4005
3681	return if $RELOAD++;	4006	return if $RELOAD++;
3682		4007
3683	my $t1 = EV::time;	4008	my $t1 = AE::time;
3684		4009
3685	while ($RELOAD) {	4010	while ($RELOAD) {
3686	warn "reloading...";	4011	cf::get_slot 0.1, -1, "reload_perl";
		4012	info "perl_reload: reloading...";
3687		4013
3688	warn "entering sync_job";	4014	trace "perl_reload: entering sync_job";
3689		4015
3690	cf::sync_job {	4016	cf::sync_job {
3691	cf::write_runtime_sync; # external watchdog should not bark
3692	cf::emergency_save;	4017	#cf::emergency_save;
3693	cf::write_runtime_sync; # external watchdog should not bark
3694		4018
3695	warn "syncing database to disk";
3696	BDB::db_env_txn_checkpoint $DB_ENV;
3697
3698	# if anything goes wrong in here, we should simply crash as we already saved
3699
3700	warn "flushing outstanding aio requests";
3701	while (IO::AIO::nreqs || BDB::nreqs) {
3702	Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3703	}
3704
3705	warn "cancelling all extension coros";	4019	trace "perl_reload: cancelling all extension coros";
3706	$_->cancel for values %EXT_CORO;	4020	$_->cancel for values %EXT_CORO;
3707	%EXT_CORO = ();	4021	%EXT_CORO = ();
3708		4022
3709	warn "removing commands";	4023	trace "perl_reload: removing commands";
3710	%COMMAND = ();	4024	%COMMAND = ();
3711		4025
3712	warn "removing ext/exti commands";	4026	trace "perl_reload: removing ext/exti commands";
3713	%EXTCMD = ();	4027	%EXTCMD = ();
3714	%EXTICMD = ();	4028	%EXTICMD = ();
3715		4029
3716	warn "unloading/nuking all extensions";	4030	trace "perl_reload: unloading/nuking all extensions";
3717	for my $pkg (@EXTS) {	4031	for my $pkg (@EXTS) {
3718	warn "... unloading $pkg";	4032	trace "... unloading $pkg";
3719		4033
3720	if (my $cb = $pkg->can ("unload")) {	4034	if (my $cb = $pkg->can ("unload")) {
3721	eval {	4035	eval {
3722	$cb->($pkg);	4036	$cb->($pkg);
3723	1	4037	1
3724	} or warn "$pkg unloaded, but with errors: $@";	4038	} or error "$pkg unloaded, but with errors: $@";
3725	}	4039	}
3726		4040
3727	warn "... clearing $pkg";	4041	trace "... clearing $pkg";
3728	clear_package $pkg;	4042	clear_package $pkg;
3729	}	4043	}
3730		4044
3731	warn "unloading all perl modules loaded from $LIBDIR";	4045	trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3732	while (my ($k, $v) = each %INC) {	4046	while (my ($k, $v) = each %INC) {
3733	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;	4047	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3734		4048
3735	warn "... unloading $k";	4049	trace "... unloading $k";
3736	delete $INC{$k};	4050	delete $INC{$k};
3737		4051
3738	$k =~ s/\.pm$//;	4052	$k =~ s/\.pm$//;
3739	$k =~ s/\//::/g;	4053	$k =~ s/\//::/g;
3740		4054
…		…
3743	}	4057	}
3744		4058
3745	clear_package $k;	4059	clear_package $k;
3746	}	4060	}
3747		4061
3748	warn "getting rid of safe::, as good as possible";	4062	trace "perl_reload: getting rid of safe::, as good as possible";
3749	clear_package "safe::$_"	4063	clear_package "safe::$_"
3750	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	4064	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3751		4065
3752	warn "unloading cf.pm \"a bit\"";	4066	trace "perl_reload: unloading cf.pm \"a bit\"";
3753	delete $INC{"cf.pm"};	4067	delete $INC{"cf.pm"};
3754	delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;	4068	delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3755		4069
3756	# don't, removes xs symbols, too,	4070	# don't, removes xs symbols, too,
3757	# and global variables created in xs	4071	# and global variables created in xs
3758	#clear_package __PACKAGE__;	4072	#clear_package __PACKAGE__;
3759		4073
3760	warn "unload completed, starting to reload now";	4074	info "perl_reload: unload completed, starting to reload now";
3761		4075
3762	warn "reloading cf.pm";	4076	trace "perl_reload: reloading cf.pm";
3763	require cf;	4077	require cf;
3764	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	4078	cf::_connect_to_perl_1;
3765		4079
3766	warn "loading config and database again";	4080	trace "perl_reload: loading config and database again";
3767	cf::reload_config;	4081	cf::reload_config;
3768		4082
3769	warn "loading extensions";	4083	trace "perl_reload: loading extensions";
3770	cf::load_extensions;	4084	cf::load_extensions;
3771		4085
3772	if ($REATTACH_ON_RELOAD) {	4086	if ($REATTACH_ON_RELOAD) {
3773	warn "reattaching attachments to objects/players";	4087	trace "perl_reload: reattaching attachments to objects/players";
3774	_global_reattach; # objects, sockets	4088	_global_reattach; # objects, sockets
3775	warn "reattaching attachments to maps";	4089	trace "perl_reload: reattaching attachments to maps";
3776	reattach $_ for values %MAP;	4090	reattach $_ for values %MAP;
3777	warn "reattaching attachments to players";	4091	trace "perl_reload: reattaching attachments to players";
3778	reattach $_ for values %PLAYER;	4092	reattach $_ for values %PLAYER;
3779	}	4093	}
3780		4094
3781	warn "running post_init jobs";	4095	cf::_post_init 1;
3782	(pop @POST_INIT)->(1) while @POST_INIT;
3783		4096
3784	warn "leaving sync_job";	4097	trace "perl_reload: leaving sync_job";
3785		4098
3786	1	4099	1
3787	} or do {	4100	} or do {
3788	warn $@;	4101	error $@;
3789	cf::cleanup "error while reloading, exiting.";	4102	cf::cleanup "perl_reload: error, exiting.";
3790	};	4103	};
3791		4104
3792	warn "reloaded";
3793	--$RELOAD;	4105	--$RELOAD;
3794	}	4106	}
3795		4107
3796	$t1 = EV::time - $t1;	4108	$t1 = AE::time - $t1;
3797	warn "reload completed in ${t1}s\n";	4109	info "perl_reload: completed in ${t1}s\n";
3798	};	4110	};
3799		4111
3800	our $RELOAD_WATCHER; # used only during reload	4112	our $RELOAD_WATCHER; # used only during reload
3801		4113
3802	sub reload_perl() {	4114	sub reload_perl() {
…		…
3804	# coro crashes during coro_state_free->destroy here.	4116	# coro crashes during coro_state_free->destroy here.
3805		4117
3806	$RELOAD_WATCHER ||= cf::async {	4118	$RELOAD_WATCHER ||= cf::async {
3807	Coro::AIO::aio_wait cache_extensions;	4119	Coro::AIO::aio_wait cache_extensions;
3808		4120
3809	$RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {	4121	$RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3810	do_reload_perl;	4122	do_reload_perl;
3811	undef $RELOAD_WATCHER;	4123	undef $RELOAD_WATCHER;
3812	};	4124	};
3813	};	4125	};
3814	}	4126	}
…		…
3823	reload_perl;	4135	reload_perl;
3824	};	4136	};
3825	}	4137	}
3826	};	4138	};
3827		4139
3828	unshift @INC, $LIBDIR;	4140	#############################################################################
3829		4141
3830	my $bug_warning = 0;	4142	my $bug_warning = 0;
3831		4143
3832	our @WAIT_FOR_TICK;
3833	our @WAIT_FOR_TICK_BEGIN;
3834
3835	sub wait_for_tick {	4144	sub wait_for_tick() {
3836	return if tick_inhibit || $Coro::current == $Coro::main;	4145	return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3837		4146
3838	my $signal = new Coro::Signal;	4147	$WAIT_FOR_TICK->wait;
3839	push @WAIT_FOR_TICK, $signal;
3840	$signal->wait;
3841	}	4148	}
3842		4149
3843	sub wait_for_tick_begin {	4150	sub wait_for_tick_begin() {
3844	return if tick_inhibit || $Coro::current == $Coro::main;	4151	return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3845		4152
3846	my $signal = new Coro::Signal;	4153	my $signal = new Coro::Signal;
3847	push @WAIT_FOR_TICK_BEGIN, $signal;	4154	push @WAIT_FOR_TICK_BEGIN, $signal;
3848	$signal->wait;	4155	$signal->wait;
3849	}	4156	}
…		…
3853	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"	4160	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3854	unless ++$bug_warning > 10;	4161	unless ++$bug_warning > 10;
3855	return;	4162	return;
3856	}	4163	}
3857		4164
3858	cf::server_tick; # one server iteration	4165	cf::one_tick; # one server iteration
		4166
		4167	#for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3859		4168
3860	if ($NOW >= $NEXT_RUNTIME_WRITE) {	4169	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3861	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;	4170	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3862	Coro::async_pool {	4171	Coro::async_pool {
3863	$Coro::current->{desc} = "runtime saver";	4172	$Coro::current->{desc} = "runtime saver";
3864	write_runtime_sync	4173	write_runtime_sync
3865	or warn "ERROR: unable to write runtime file: $!";	4174	or error "ERROR: unable to write runtime file: $!";
3866	};	4175	};
3867	}	4176	}
3868		4177
3869	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	4178	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3870	$sig->send;	4179	$sig->send;
3871	}	4180	}
3872	while (my $sig = shift @WAIT_FOR_TICK) {	4181	$WAIT_FOR_TICK->broadcast;
3873	$sig->send;
3874	}
3875		4182
3876	$LOAD = ($NOW - $TICK_START) / $TICK;	4183	$LOAD = ($NOW - $TICK_START) / $TICK;
3877	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	4184	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3878		4185
3879	if (0) {	4186	if (0) {
3880	if ($NEXT_TICK) {	4187	if ($NEXT_TICK) {
3881	my $jitter = $TICK_START - $NEXT_TICK;	4188	my $jitter = $TICK_START - $NEXT_TICK;
3882	$JITTER = $JITTER * 0.75 + $jitter * 0.25;	4189	$JITTER = $JITTER * 0.75 + $jitter * 0.25;
3883	warn "jitter $JITTER\n";#d#	4190	debug "jitter $JITTER\n";#d#
3884	}	4191	}
3885	}	4192	}
3886	}	4193	}
3887		4194
3888	{	4195	{
3889	# configure BDB	4196	# configure BDB
3890		4197
3891	BDB::min_parallel 8;	4198	BDB::min_parallel 16;
3892	BDB::max_poll_reqs $TICK * 0.1;	4199	BDB::max_poll_reqs $TICK * 0.1;
3893	$AnyEvent::BDB::WATCHER->priority (1);	4200	#$AnyEvent::BDB::WATCHER->priority (1);
3894		4201
3895	unless ($DB_ENV) {	4202	unless ($DB_ENV) {
3896	$DB_ENV = BDB::db_env_create;	4203	$DB_ENV = BDB::db_env_create;
3897	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);	4204	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3898	$DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;	4205	$DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
…		…
3933	IO::AIO::min_parallel 8;	4240	IO::AIO::min_parallel 8;
3934	IO::AIO::max_poll_time $TICK * 0.1;	4241	IO::AIO::max_poll_time $TICK * 0.1;
3935	undef $AnyEvent::AIO::WATCHER;	4242	undef $AnyEvent::AIO::WATCHER;
3936	}	4243	}
3937		4244
3938	my $_log_backtrace;	4245	our $_log_backtrace;
		4246	our $_log_backtrace_last;
3939		4247
3940	sub _log_backtrace {	4248	sub _log_backtrace {
3941	my ($msg, @addr) = @_;	4249	my ($msg, @addr) = @_;
3942		4250
3943	$msg =~ s/\n//;	4251	$msg =~ s/\n$//;
3944		4252
		4253	if ($_log_backtrace_last eq $msg) {
		4254	LOG llevInfo, "[ABT] $msg\n";
		4255	LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
3945	# limit the # of concurrent backtraces	4256	# limit the # of concurrent backtraces
3946	if ($_log_backtrace < 2) {	4257	} elsif ($_log_backtrace < 2) {
		4258	$_log_backtrace_last = $msg;
3947	++$_log_backtrace;	4259	++$_log_backtrace;
3948	my $perl_bt = Carp::longmess $msg;	4260	my $perl_bt = Carp::longmess $msg;
3949	async {	4261	async {
3950	$Coro::current->{desc} = "abt $msg";	4262	$Coro::current->{desc} = "abt $msg";
3951		4263
…		…
3971	LOG llevInfo, "[ABT] $_\n" for @bt;	4283	LOG llevInfo, "[ABT] $_\n" for @bt;
3972	--$_log_backtrace;	4284	--$_log_backtrace;
3973	};	4285	};
3974	} else {	4286	} else {
3975	LOG llevInfo, "[ABT] $msg\n";	4287	LOG llevInfo, "[ABT] $msg\n";
3976	LOG llevInfo, "[ABT] [suppressed]\n";	4288	LOG llevInfo, "[ABT] [overload, suppressed]\n";
3977	}	4289	}
3978	}	4290	}
3979		4291
3980	# load additional modules	4292	# load additional modules
3981	require "cf/$_.pm" for @EXTRA_MODULES;	4293	require "cf/$_.pm" for @EXTRA_MODULES;
		4294	cf::_connect_to_perl_2;
3982		4295
3983	END { cf::emergency_save }	4296	END { cf::emergency_save }
3984		4297
3985	1	4298	1
3986		4299

Diff Legend

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