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.493 by root, Mon Oct 26 02:34:37 2009 UTC vs.
Revision 1.574 by root, Sun May 8 21:51:27 2011 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 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5	#	5	#
6	# Deliantra is free software: you can redistribute it and/or modify it under	6	# Deliantra is free software: you can redistribute it and/or modify it under
7	# the terms of the Affero GNU General Public License as published by the	7	# the terms of the Affero GNU General Public License as published by the
8	# Free Software Foundation, either version 3 of the License, or (at your	8	# Free Software Foundation, either version 3 of the License, or (at your
9	# option) any later version.	9	# option) any later version.
…		…
20	# 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>
21	#	21	#
22		22
23	package cf;	23	package cf;
24		24
25	use 5.10.0;	25	use common::sense;
26	use utf8;
27	use strict qw(vars subs);
28		26
29	use Symbol;	27	use Symbol;
30	use List::Util;	28	use List::Util;
31	use Socket;	29	use Socket;
32	use EV;	30	use EV;
…		…
53	use Coro::Util ();	51	use Coro::Util ();
54		52
55	use JSON::XS 2.01 ();	53	use JSON::XS 2.01 ();
56	use BDB ();	54	use BDB ();
57	use Data::Dumper;	55	use Data::Dumper;
58	use Digest::MD5;
59	use Fcntl;	56	use Fcntl;
60	use YAML::XS ();	57	use YAML::XS ();
61	use IO::AIO ();	58	use IO::AIO ();
62	use Time::HiRes;	59	use Time::HiRes;
63	use Compress::LZF;	60	use Compress::LZF;
…		…
79	# strictly for debugging	76	# strictly for debugging
80	$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };	77	$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
81		78
82	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	79	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
83		80
		81	our @ORIG_INC;
		82
84	our %COMMAND = ();	83	our %COMMAND = ();
85	our %COMMAND_TIME = ();	84	our %COMMAND_TIME = ();
86		85
87	our @EXTS = (); # list of extension package names	86	our @EXTS = (); # list of extension package names
88	our %EXTCMD = ();	87	our %EXTCMD = ();
…		…
94	our @EVENT;	93	our @EVENT;
95	our @REFLECT; # set by XS	94	our @REFLECT; # set by XS
96	our %REFLECT; # set by us	95	our %REFLECT; # set by us
97		96
98	our $CONFDIR = confdir;	97	our $CONFDIR = confdir;
		98
99	our $DATADIR = datadir;	99	our $DATADIR = datadir;
100	our $LIBDIR = "$DATADIR/ext";	100	our $LIBDIR = "$DATADIR/ext";
101	our $PODDIR = "$DATADIR/pod";	101	our $PODDIR = "$DATADIR/pod";
102	our $MAPDIR = "$DATADIR/" . mapdir;	102	our $MAPDIR = "$DATADIR/" . mapdir;
		103
103	our $LOCALDIR = localdir;	104	our $LOCALDIR = localdir;
104	our $TMPDIR = "$LOCALDIR/" . tmpdir;	105	our $TMPDIR = "$LOCALDIR/" . tmpdir;
105	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;	106	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
106	our $PLAYERDIR = "$LOCALDIR/" . playerdir;	107	our $PLAYERDIR = "$LOCALDIR/" . playerdir;
107	our $RANDOMDIR = "$LOCALDIR/random";	108	our $RANDOMDIR = "$LOCALDIR/random";
108	our $BDBDIR = "$LOCALDIR/db";	109	our $BDBDIR = "$LOCALDIR/db";
109	our $PIDFILE = "$LOCALDIR/pid";	110	our $PIDFILE = "$LOCALDIR/pid";
110	our $RUNTIMEFILE = "$LOCALDIR/runtime";	111	our $RUNTIMEFILE = "$LOCALDIR/runtime";
111		112
112	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;
113		120
114	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	121	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
115	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	122	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
116	our $NEXT_TICK;	123	our $NEXT_TICK;
117	our $USE_FSYNC = 1; # use fsync to write maps - default on	124	our $USE_FSYNC = 1; # use fsync to write maps - default on
…		…
119	our $BDB_DEADLOCK_WATCHER;	126	our $BDB_DEADLOCK_WATCHER;
120	our $BDB_CHECKPOINT_WATCHER;	127	our $BDB_CHECKPOINT_WATCHER;
121	our $BDB_TRICKLE_WATCHER;	128	our $BDB_TRICKLE_WATCHER;
122	our $DB_ENV;	129	our $DB_ENV;
123		130
124	our @EXTRA_MODULES = qw(pod match mapscript);	131	our @EXTRA_MODULES = qw(pod match mapscript incloader);
125		132
126	our %CFG;	133	our %CFG;
127		134
128	our $UPTIME; $UPTIME ||= time;	135	our $UPTIME; $UPTIME ||= time;
129	our $RUNTIME;	136	our $RUNTIME = 0;
		137	our $SERVER_TICK = 0;
130	our $NOW;	138	our $NOW;
131		139
132	our (%PLAYER, %PLAYER_LOADING); # all users	140	our (%PLAYER, %PLAYER_LOADING); # all users
133	our (%MAP, %MAP_LOADING ); # all maps	141	our (%MAP, %MAP_LOADING ); # all maps
134	our $LINK_MAP; # the special {link} map, which is always available	142	our $LINK_MAP; # the special {link} map, which is always available
…		…
143		151
144	our @POST_INIT;	152	our @POST_INIT;
145		153
146	our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)	154	our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
147	our $REALLY_UNLOOP; # never set to true, please :)	155	our $REALLY_UNLOOP; # never set to true, please :)
		156
		157	our $WAIT_FOR_TICK = new Coro::Signal;
		158	our @WAIT_FOR_TICK_BEGIN;
148		159
149	binmode STDOUT;	160	binmode STDOUT;
150	binmode STDERR;	161	binmode STDERR;
151		162
152	# read virtual server time, if available	163	# read virtual server time, if available
…		…
163		174
164	our $EMERGENCY_POSITION;	175	our $EMERGENCY_POSITION;
165		176
166	sub cf::map::normalise;	177	sub cf::map::normalise;
167		178
		179	sub in_main() {
		180	$Coro::current == $Coro::main
		181	}
		182
168	#############################################################################	183	#############################################################################
169		184
170	%REFLECT = ();	185	%REFLECT = ();
171	for (@REFLECT) {	186	for (@REFLECT) {
172	my $reflect = JSON::XS::decode_json $_;	187	my $reflect = JSON::XS::decode_json $_;
…		…
182		197
183	=over 4	198	=over 4
184		199
185	=item $cf::UPTIME	200	=item $cf::UPTIME
186		201
187	The timestamp of the server start (so not actually an uptime).	202	The timestamp of the server start (so not actually an "uptime").
		203
		204	=item $cf::SERVER_TICK
		205
		206	An unsigned integer that starts at zero when the server is started and is
		207	incremented on every tick.
		208
		209	=item $cf::NOW
		210
		211	The (real) time of the last (current) server tick - updated before and
		212	after tick processing, so this is useful only as a rough "what time is it
		213	now" estimate.
		214
		215	=item $cf::TICK
		216
		217	The interval between each server tick, in seconds.
188		218
189	=item $cf::RUNTIME	219	=item $cf::RUNTIME
190		220
191	The time this server has run, starts at 0 and is increased by $cf::TICK on	221	The time this server has run, starts at 0 and is increased by $cf::TICK on
192	every server tick.	222	every server tick.
…		…
198	Various directories - "/etc", read-only install directory, perl-library	228	Various directories - "/etc", read-only install directory, perl-library
199	directory, pod-directory, read-only maps directory, "/var", "/var/tmp",	229	directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
200	unique-items directory, player file directory, random maps directory and	230	unique-items directory, player file directory, random maps directory and
201	database environment.	231	database environment.
202		232
203	=item $cf::NOW
204
205	The time of the last (current) server tick.
206
207	=item $cf::TICK
208
209	The interval between server ticks, in seconds.
210
211	=item $cf::LOADAVG	233	=item $cf::LOADAVG
212		234
213	The current CPU load on the server (alpha-smoothed), as a value between 0	235	The current CPU load on the server (alpha-smoothed), as a value between 0
214	(none) and 1 (overloaded), indicating how much time is spent on processing	236	(none) and 1 (overloaded), indicating how much time is spent on processing
215	objects per tick. Healthy values are < 0.5.	237	objects per tick. Healthy values are < 0.5.
…		…
224	from wherever your confdir points to.	246	from wherever your confdir points to.
225		247
226	=item cf::wait_for_tick, cf::wait_for_tick_begin	248	=item cf::wait_for_tick, cf::wait_for_tick_begin
227		249
228	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	250	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
229	returns directly I<after> the tick processing (and consequently, can only wake one process	251	returns directly I<after> the tick processing (and consequently, can only wake one thread
230	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	252	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
		253
		254	Note that cf::Wait_for_tick will immediately return when the server is not
		255	ticking, making it suitable for small pauses in threads that need to run
		256	when the server is paused. If that is not applicable (i.e. you I<really>
		257	want to wait, use C<$cf::WAIT_FOR_TICK>).
		258
		259	=item $cf::WAIT_FOR_TICK
		260
		261	Note that C<cf::wait_for_tick> is probably the correct thing to use. This
		262	variable contains a L<Coro::Signal> that is broadcats after every server
		263	tick. Calling C<< ->wait >> on it will suspend the caller until after the
		264	next server tick.
		265
		266	=cut
		267
		268	sub wait_for_tick();
		269	sub wait_for_tick_begin();
231		270
232	=item @cf::INVOKE_RESULTS	271	=item @cf::INVOKE_RESULTS
233		272
234	This array contains the results of the last C<invoke ()> call. When	273	This array contains the results of the last C<invoke ()> call. When
235	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of	274	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
…		…
243		282
244	=back	283	=back
245		284
246	=cut	285	=cut
247		286
		287	sub error(@) { LOG llevError, join "", @_ }
		288	sub warn (@) { LOG llevWarn , join "", @_ }
		289	sub info (@) { LOG llevInfo , join "", @_ }
		290	sub debug(@) { LOG llevDebug, join "", @_ }
		291	sub trace(@) { LOG llevTrace, join "", @_ }
		292
248	$Coro::State::WARNHOOK = sub {	293	$Coro::State::WARNHOOK = sub {
249	my $msg = join "", @_;	294	my $msg = join "", @_;
250		295
251	$msg .= "\n"	296	$msg .= "\n"
252	unless $msg =~ /\n$/;	297	unless $msg =~ /\n$/;
253		298
254	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;	299	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
255		300
256	LOG llevError, $msg;	301	LOG llevWarn, $msg;
257	};	302	};
258		303
259	$Coro::State::DIEHOOK = sub {	304	$Coro::State::DIEHOOK = sub {
260	return unless $^S eq 0; # "eq", not "=="	305	return unless $^S eq 0; # "eq", not "=="
261		306
262	warn Carp::longmess $_[0];	307	error Carp::longmess $_[0];
263		308
264	if ($Coro::current == $Coro::main) {#d#	309	if (in_main) {#d#
265	warn "DIEHOOK called in main context, Coro bug?\n";#d#	310	error "DIEHOOK called in main context, Coro bug?\n";#d#
266	return;#d#	311	return;#d#
267	}#d#	312	}#d#
268		313
269	# kill coroutine otherwise	314	# kill coroutine otherwise
270	Coro::terminate	315	Coro::terminate
…		…
292	}	337	}
293		338
294	$EV::DIED = sub {	339	$EV::DIED = sub {
295	Carp::cluck "error in event callback: @_";	340	Carp::cluck "error in event callback: @_";
296	};	341	};
		342
		343	#############################################################################
		344
		345	sub fork_call(&@);
		346	sub get_slot($;$$);
297		347
298	#############################################################################	348	#############################################################################
299		349
300	=head2 UTILITY FUNCTIONS	350	=head2 UTILITY FUNCTIONS
301		351
…		…
322	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;	372	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
323	$d	373	$d
324	} || "[unable to dump $_[0]: '$@']";	374	} || "[unable to dump $_[0]: '$@']";
325	}	375	}
326		376
		377	=item $scalar = load_file $path
		378
		379	Loads the given file from path and returns its contents. Croaks on error
		380	and can block.
		381
		382	=cut
		383
		384	sub load_file($) {
		385	0 <= aio_load $_[0], my $data
		386	or Carp::croak "$_[0]: $!";
		387
		388	$data
		389	}
		390
327	=item $ref = cf::decode_json $json	391	=item $ref = cf::decode_json $json
328		392
329	Converts a JSON string into the corresponding perl data structure.	393	Converts a JSON string into the corresponding perl data structure.
330		394
331	=item $json = cf::encode_json $ref	395	=item $json = cf::encode_json $ref
…		…
337	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max	401	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
338		402
339	sub encode_json($) { $json_coder->encode ($_[0]) }	403	sub encode_json($) { $json_coder->encode ($_[0]) }
340	sub decode_json($) { $json_coder->decode ($_[0]) }	404	sub decode_json($) { $json_coder->decode ($_[0]) }
341		405
		406	=item $ref = cf::decode_storable $scalar
		407
		408	Same as Coro::Storable::thaw, so blocks.
		409
		410	=cut
		411
		412	BEGIN { *decode_storable = \&Coro::Storable::thaw }
		413
		414	=item $ref = cf::decode_yaml $scalar
		415
		416	Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
		417
		418	=cut
		419
		420	sub decode_yaml($) {
		421	fork_call { YAML::XS::Load $_[0] } @_
		422	}
		423
		424	=item $scalar = cf::unlzf $scalar
		425
		426	Same as Compress::LZF::compress, but takes server ticks into account, so
		427	blocks.
		428
		429	=cut
		430
		431	sub unlzf($) {
		432	# we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
		433	cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
		434	Compress::LZF::decompress $_[0]
		435	}
		436
342	=item cf::post_init { BLOCK }	437	=item cf::post_init { BLOCK }
343		438
344	Execute the given codeblock, I<after> all extensions have been (re-)loaded,	439	Execute the given codeblock, I<after> all extensions have been (re-)loaded,
345	but I<before> the server starts ticking again.	440	but I<before> the server starts ticking again.
346		441
347	The cdoeblock will have a single boolean argument to indicate whether this	442	The codeblock will have a single boolean argument to indicate whether this
348	is a reload or not.	443	is a reload or not.
349		444
350	=cut	445	=cut
351		446
352	sub post_init(&) {	447	sub post_init(&) {
353	push @POST_INIT, shift;	448	push @POST_INIT, shift;
		449	}
		450
		451	sub _post_init {
		452	trace "running post_init jobs";
		453
		454	# run them in parallel...
		455
		456	my @join;
		457
		458	while () {
		459	push @join, map &Coro::async ($_, 0), @POST_INIT;
		460	@POST_INIT = ();
		461
		462	@join or last;
		463
		464	(pop @join)->join;
		465	}
354	}	466	}
355		467
356	=item cf::lock_wait $string	468	=item cf::lock_wait $string
357		469
358	Wait until the given lock is available. See cf::lock_acquire.	470	Wait until the given lock is available. See cf::lock_acquire.
…		…
397	}	509	}
398		510
399	=item cf::periodic $interval, $cb	511	=item cf::periodic $interval, $cb
400		512
401	Like EV::periodic, but randomly selects a starting point so that the actions	513	Like EV::periodic, but randomly selects a starting point so that the actions
402	get spread over timer.	514	get spread over time.
403		515
404	=cut	516	=cut
405		517
406	sub periodic($$) {	518	sub periodic($$) {
407	my ($interval, $cb) = @_;	519	my ($interval, $cb) = @_;
…		…
411	EV::periodic $start, $interval, 0, $cb	523	EV::periodic $start, $interval, 0, $cb
412	}	524	}
413		525
414	=item cf::get_slot $time[, $priority[, $name]]	526	=item cf::get_slot $time[, $priority[, $name]]
415		527
416	Allocate $time seconds of blocking CPU time at priority C<$priority>:	528	Allocate $time seconds of blocking CPU time at priority C<$priority>
417	This call blocks and returns only when you have at least C<$time> seconds	529	(default: 0): This call blocks and returns only when you have at least
418	of cpu time till the next tick. The slot is only valid till the next cede.	530	C<$time> seconds of cpu time till the next tick. The slot is only valid
		531	till the next cede.
		532
		533	Background jobs should use a priority les than zero, interactive jobs
		534	should use 100 or more.
419		535
420	The optional C<$name> can be used to identify the job to run. It might be	536	The optional C<$name> can be used to identify the job to run. It might be
421	used for statistical purposes and should identify the same time-class.	537	used for statistical purposes and should identify the same time-class.
422		538
423	Useful for short background jobs.	539	Useful for short background jobs.
424		540
425	=cut	541	=cut
426		542
427	our @SLOT_QUEUE;	543	our @SLOT_QUEUE;
428	our $SLOT_QUEUE;	544	our $SLOT_QUEUE;
		545	our $SLOT_DECAY = 0.9;
429		546
430	$SLOT_QUEUE->cancel if $SLOT_QUEUE;	547	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
431	$SLOT_QUEUE = Coro::async {	548	$SLOT_QUEUE = Coro::async {
432	$Coro::current->desc ("timeslot manager");	549	$Coro::current->desc ("timeslot manager");
433		550
434	my $signal = new Coro::Signal;	551	my $signal = new Coro::Signal;
		552	my $busy;
435		553
436	while () {	554	while () {
437	next_job:	555	next_job:
		556
438	my $avail = cf::till_tick;	557	my $avail = cf::till_tick;
439	if ($avail > 0.01) {	558
440	for (0 .. $#SLOT_QUEUE) {	559	for (0 .. $#SLOT_QUEUE) {
441	if ($SLOT_QUEUE[$_][0] < $avail) {	560	if ($SLOT_QUEUE[$_][0] <= $avail) {
		561	$busy = 0;
442	my $job = splice @SLOT_QUEUE, $_, 1, ();	562	my $job = splice @SLOT_QUEUE, $_, 1, ();
443	$job->[2]->send;	563	$job->[2]->send;
444	Coro::cede;	564	Coro::cede;
445	goto next_job;	565	goto next_job;
446	}	566	} else {
		567	$SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
447	}	568	}
448	}	569	}
449		570
450	if (@SLOT_QUEUE) {	571	if (@SLOT_QUEUE) {
451	# we do not use wait_for_tick() as it returns immediately when tick is inactive	572	# we do not use wait_for_tick() as it returns immediately when tick is inactive
452	push @cf::WAIT_FOR_TICK, $signal;	573	$WAIT_FOR_TICK->wait;
453	$signal->wait;
454	} else {	574	} else {
		575	$busy = 0;
455	Coro::schedule;	576	Coro::schedule;
456	}	577	}
457	}	578	}
458	};	579	};
459		580
460	sub get_slot($;$$) {	581	sub get_slot($;$$) {
461	return if tick_inhibit || $Coro::current == $Coro::main;	582	return if tick_inhibit || $Coro::current == $Coro::main;
462		583
463	my ($time, $pri, $name) = @_;	584	my ($time, $pri, $name) = @_;
464		585
465	$time = $TICK * .6 if $time > $TICK * .6;	586	$time = clamp $time, 0.01, $TICK * .6;
		587
466	my $sig = new Coro::Signal;	588	my $sig = new Coro::Signal;
467		589
468	push @SLOT_QUEUE, [$time, $pri, $sig, $name];	590	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
469	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;	591	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
470	$SLOT_QUEUE->ready;	592	$SLOT_QUEUE->ready;
…		…
496	=cut	618	=cut
497		619
498	sub sync_job(&) {	620	sub sync_job(&) {
499	my ($job) = @_;	621	my ($job) = @_;
500		622
501	if ($Coro::current == $Coro::main) {	623	if (in_main) {
502	my $time = EV::time;	624	my $time = AE::time;
503		625
504	# this is the main coro, too bad, we have to block	626	# this is the main coro, too bad, we have to block
505	# till the operation succeeds, freezing the server :/	627	# till the operation succeeds, freezing the server :/
506		628
507	LOG llevError, Carp::longmess "sync job";#d#	629	#LOG llevError, Carp::longmess "sync job";#d#
508		630
509	my $freeze_guard = freeze_mainloop;	631	my $freeze_guard = freeze_mainloop;
510		632
511	my $busy = 1;	633	my $busy = 1;
512	my @res;	634	my @res;
513		635
514	(async {	636	(async {
515	$Coro::current->desc ("sync job coro");	637	$Coro::current->desc ("sync job coro");
516	@res = eval { $job->() };	638	@res = eval { $job->() };
517	warn $@ if $@;	639	error $@ if $@;
518	undef $busy;	640	undef $busy;
519	})->prio (Coro::PRIO_MAX);	641	})->prio (Coro::PRIO_MAX);
520		642
521	while ($busy) {	643	while ($busy) {
522	if (Coro::nready) {	644	if (Coro::nready) {
…		…
524	} else {	646	} else {
525	EV::loop EV::LOOP_ONESHOT;	647	EV::loop EV::LOOP_ONESHOT;
526	}	648	}
527	}	649	}
528		650
529	my $time = EV::time - $time;	651	my $time = AE::time - $time;
530		652
531	$TICK_START += $time; # do not account sync jobs to server load	653	$TICK_START += $time; # do not account sync jobs to server load
532		654
533	wantarray ? @res : $res[0]	655	wantarray ? @res : $res[0]
534	} else {	656	} else {
…		…
556	$EXT_CORO{$coro+0} = $coro;	678	$EXT_CORO{$coro+0} = $coro;
557		679
558	$coro	680	$coro
559	}	681	}
560		682
561	=item fork_call { }, $args	683	=item fork_call { }, @args
562		684
563	Executes the given code block with the given arguments in a seperate	685	Executes the given code block with the given arguments in a seperate
564	process, returning the results. Everything must be serialisable with	686	process, returning the results. Everything must be serialisable with
565	Coro::Storable. May, of course, block. Note that the executed sub may	687	Coro::Storable. May, of course, block. Note that the executed sub may
566	never block itself or use any form of event handling.	688	never block itself or use any form of event handling.
567		689
568	=cut	690	=cut
569		691
		692	sub post_fork {
		693	reset_signals;
		694	}
		695
570	sub fork_call(&@) {	696	sub fork_call(&@) {
571	my ($cb, @args) = @_;	697	my ($cb, @args) = @_;
572		698
573	# we seemingly have to make a local copy of the whole thing,	699	# we seemingly have to make a local copy of the whole thing,
574	# otherwise perl prematurely frees the stuff :/	700	# otherwise perl prematurely frees the stuff :/
575	# TODO: investigate and fix (likely this will be rather laborious)	701	# TODO: investigate and fix (likely this will be rather laborious)
576		702
577	my @res = Coro::Util::fork_eval {	703	my @res = Coro::Util::fork_eval {
578	reset_signals;	704	cf::post_fork;
579	&$cb	705	&$cb
580	}, @args;	706	} @args;
581		707
582	wantarray ? @res : $res[-1]	708	wantarray ? @res : $res[-1]
		709	}
		710
		711	sub objinfo {
		712	(
		713	"counter value" => cf::object::object_count,
		714	"objects created" => cf::object::create_count,
		715	"objects destroyed" => cf::object::destroy_count,
		716	"freelist size" => cf::object::free_count,
		717	"allocated objects" => cf::object::objects_size,
		718	"active objects" => cf::object::actives_size,
		719	)
583	}	720	}
584		721
585	=item $coin = coin_from_name $name	722	=item $coin = coin_from_name $name
586		723
587	=cut	724	=cut
…		…
624	within each server.	761	within each server.
625		762
626	=cut	763	=cut
627		764
628	sub db_table($) {	765	sub db_table($) {
		766	cf::error "db_get called from main context"
		767	if $Coro::current == $Coro::main;
		768
629	my ($name) = @_;	769	my ($name) = @_;
630	my $db = BDB::db_create $DB_ENV;	770	my $db = BDB::db_create $DB_ENV;
631		771
632	eval {	772	eval {
633	$db->set_flags (BDB::CHKSUM);	773	$db->set_flags (BDB::CHKSUM);
…		…
643	}	783	}
644		784
645	our $DB;	785	our $DB;
646		786
647	sub db_init {	787	sub db_init {
648	cf::sync_job {
649	$DB ||= db_table "db";	788	$DB ||= db_table "db";
650	};
651	}	789	}
652		790
653	sub db_get($$) {	791	sub db_get($$) {
654	my $key = "$_[0]/$_[1]";	792	my $key = "$_[0]/$_[1]";
655		793
656	cf::sync_job {	794	cf::error "db_get called from main context"
		795	if $Coro::current == $Coro::main;
		796
657	BDB::db_get $DB, undef, $key, my $data;	797	BDB::db_get $DB, undef, $key, my $data;
658		798
659	$! ? ()	799	$! ? ()
660	: $data	800	: $data
661	}
662	}	801	}
663		802
664	sub db_put($$$) {	803	sub db_put($$$) {
665	BDB::dbreq_pri 4;	804	BDB::dbreq_pri 4;
666	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };	805	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
…		…
694		833
695	my @data;	834	my @data;
696	my $md5;	835	my $md5;
697		836
698	for (0 .. $#$src) {	837	for (0 .. $#$src) {
699	0 <= aio_load $src->[$_], $data[$_]	838	$data[$_] = load_file $src->[$_];
700	or Carp::croak "$src->[$_]: $!";
701	}	839	}
702		840
703	# if processing is expensive, check	841	# if processing is expensive, check
704	# checksum first	842	# checksum first
705	if (1) {	843	if (1) {
…		…
722		860
723	my $t1 = Time::HiRes::time;	861	my $t1 = Time::HiRes::time;
724	my $data = $process->(\@data);	862	my $data = $process->(\@data);
725	my $t2 = Time::HiRes::time;	863	my $t2 = Time::HiRes::time;
726		864
727	warn "cache: '$id' processed in ", $t2 - $t1, "s\n";	865	info "cache: '$id' processed in ", $t2 - $t1, "s\n";
728		866
729	db_put cache => "$id/data", $data;	867	db_put cache => "$id/data", $data;
730	db_put cache => "$id/md5" , $md5;	868	db_put cache => "$id/md5" , $md5;
731	db_put cache => "$id/meta", $meta;	869	db_put cache => "$id/meta", $meta;
732		870
…		…
742		880
743	=cut	881	=cut
744		882
745	sub datalog($@) {	883	sub datalog($@) {
746	my ($type, %kv) = @_;	884	my ($type, %kv) = @_;
747	warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });	885	info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
748	}	886	}
749		887
750	=back	888	=back
751		889
752	=cut	890	=cut
…		…
947		1085
948	} elsif (exists $cb_id{$type}) {	1086	} elsif (exists $cb_id{$type}) {
949	_attach_cb $registry, $cb_id{$type}, $prio, shift @arg;	1087	_attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
950		1088
951	} elsif (ref $type) {	1089	} elsif (ref $type) {
952	warn "attaching objects not supported, ignoring.\n";	1090	error "attaching objects not supported, ignoring.\n";
953		1091
954	} else {	1092	} else {
955	shift @arg;	1093	shift @arg;
956	warn "attach argument '$type' not supported, ignoring.\n";	1094	error "attach argument '$type' not supported, ignoring.\n";
957	}	1095	}
958	}	1096	}
959	}	1097	}
960		1098
961	sub _object_attach {	1099	sub _object_attach {
…		…
971	_attach $registry, $klass, @attach;	1109	_attach $registry, $klass, @attach;
972	}	1110	}
973		1111
974	$obj->{$name} = \%arg;	1112	$obj->{$name} = \%arg;
975	} else {	1113	} else {
976	warn "object uses attachment '$name' which is not available, postponing.\n";	1114	info "object uses attachment '$name' which is not available, postponing.\n";
977	}	1115	}
978		1116
979	$obj->{_attachment}{$name} = undef;	1117	$obj->{_attachment}{$name} = undef;
980	}	1118	}
981		1119
…		…
1040		1178
1041	for (@$callbacks) {	1179	for (@$callbacks) {
1042	eval { &{$_->[1]} };	1180	eval { &{$_->[1]} };
1043		1181
1044	if ($@) {	1182	if ($@) {
1045	warn "$@";
1046	warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";	1183	error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1047	override;	1184	override;
1048	}	1185	}
1049		1186
1050	return 1 if $override;	1187	return 1 if $override;
1051	}	1188	}
…		…
1130	for (@$attach) {	1267	for (@$attach) {
1131	my ($klass, @attach) = @$_;	1268	my ($klass, @attach) = @$_;
1132	_attach $registry, $klass, @attach;	1269	_attach $registry, $klass, @attach;
1133	}	1270	}
1134	} else {	1271	} else {
1135	warn "object uses attachment '$name' that is not available, postponing.\n";	1272	info "object uses attachment '$name' that is not available, postponing.\n";
1136	}	1273	}
1137	}	1274	}
1138	}	1275	}
1139		1276
1140	cf::attachable->attach (	1277	cf::attachable->attach (
…		…
1167	my ($filename, $rdata, $objs) = @_;	1304	my ($filename, $rdata, $objs) = @_;
1168		1305
1169	sync_job {	1306	sync_job {
1170	if (length $$rdata) {	1307	if (length $$rdata) {
1171	utf8::decode (my $decname = $filename);	1308	utf8::decode (my $decname = $filename);
1172	warn sprintf "saving %s (%d,%d)\n",	1309	trace sprintf "saving %s (%d,%d)\n",
1173	$decname, length $$rdata, scalar @$objs;	1310	$decname, length $$rdata, scalar @$objs
		1311	if $VERBOSE_IO;
1174		1312
1175	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {	1313	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1176	aio_chmod $fh, SAVE_MODE;	1314	aio_chmod $fh, SAVE_MODE;
1177	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1315	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1178	if ($cf::USE_FSYNC) {	1316	if ($cf::USE_FSYNC) {
…		…
1200	aio_rename "$filename~", $filename;	1338	aio_rename "$filename~", $filename;
1201		1339
1202	$filename =~ s%/[^/]+$%%;	1340	$filename =~ s%/[^/]+$%%;
1203	aio_pathsync $filename if $cf::USE_FSYNC;	1341	aio_pathsync $filename if $cf::USE_FSYNC;
1204	} else {	1342	} else {
1205	warn "unable to save objects: $filename~: $!\n";	1343	error "unable to save objects: $filename~: $!\n";
1206	}	1344	}
1207	} else {	1345	} else {
1208	aio_unlink $filename;	1346	aio_unlink $filename;
1209	aio_unlink "$filename.pst";	1347	aio_unlink "$filename.pst";
1210	}	1348	}
…		…
1234	my $st = eval { Coro::Storable::thaw $av };	1372	my $st = eval { Coro::Storable::thaw $av };
1235	$av = $st->{objs};	1373	$av = $st->{objs};
1236	}	1374	}
1237		1375
1238	utf8::decode (my $decname = $filename);	1376	utf8::decode (my $decname = $filename);
1239	warn sprintf "loading %s (%d,%d)\n",	1377	trace sprintf "loading %s (%d,%d)\n",
1240	$decname, length $data, scalar @{$av || []};	1378	$decname, length $data, scalar @{$av || []}
		1379	if $VERBOSE_IO;
1241		1380
1242	($data, $av)	1381	($data, $av)
1243	}	1382	}
1244		1383
1245	=head2 COMMAND CALLBACKS	1384	=head2 COMMAND CALLBACKS
…		…
1304	}	1443	}
1305		1444
1306	use File::Glob ();	1445	use File::Glob ();
1307		1446
1308	cf::player->attach (	1447	cf::player->attach (
1309	on_command => sub {	1448	on_unknown_command => sub {
1310	my ($pl, $name, $params) = @_;	1449	my ($pl, $name, $params) = @_;
1311		1450
1312	my $cb = $COMMAND{$name}	1451	my $cb = $COMMAND{$name}
1313	or return;	1452	or return;
1314		1453
…		…
1337		1476
1338	$pl->ext_reply ($reply, @reply)	1477	$pl->ext_reply ($reply, @reply)
1339	if $reply;	1478	if $reply;
1340		1479
1341	} else {	1480	} else {
1342	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1481	error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1343	}	1482	}
1344		1483
1345	cf::override;	1484	cf::override;
1346	},	1485	},
1347	);	1486	);
…		…
1358		1497
1359	$grp	1498	$grp
1360	}	1499	}
1361		1500
1362	sub load_extensions {	1501	sub load_extensions {
		1502	info "loading extensions...";
		1503
1363	cf::sync_job {	1504	cf::sync_job {
1364	my %todo;	1505	my %todo;
1365		1506
1366	for my $path (<$LIBDIR/*.ext>) {	1507	for my $path (<$LIBDIR/*.ext>) {
1367	next unless -r $path;	1508	next unless -r $path;
…		…
1385		1526
1386	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }	1527	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1387	if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;	1528	if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1388		1529
1389	$ext{source} =	1530	$ext{source} =
1390	"package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"	1531	"package $pkg; use common::sense;\n"
1391	. "#line 1 \"$path\"\n{\n"	1532	. "#line 1 \"$path\"\n{\n"
1392	. $source	1533	. $source
1393	. "\n};\n1";	1534	. "\n};\n1";
1394		1535
1395	$todo{$base} = \%ext;	1536	$todo{$base} = \%ext;
1396	}	1537	}
1397		1538
		1539	my $pass = 0;
1398	my %done;	1540	my %done;
1399	while (%todo) {	1541	while (%todo) {
1400	my $progress;	1542	my $progress;
1401		1543
		1544	++$pass;
		1545
		1546	ext:
1402	while (my ($k, $v) = each %todo) {	1547	while (my ($k, $v) = each %todo) {
1403	for (split /,\s*/, $v->{meta}{depends}) {	1548	for (split /,\s*/, $v->{meta}{depends}) {
1404	goto skip	1549	next ext
1405	unless exists $done{$_};	1550	unless exists $done{$_};
1406	}	1551	}
1407		1552
1408	warn "... loading '$k' into '$v->{pkg}'\n";	1553	trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1409		1554
1410	unless (eval $v->{source}) {	1555	my $active = eval $v->{source};
		1556
		1557	if (length $@) {
1411	my $msg = $@ ? "$v->{path}: $@\n"	1558	error "$v->{path}: $@\n";
1412	: "$v->{base}: extension inactive.\n";
1413		1559
1414	if (exists $v->{meta}{mandatory}) {
1415	warn $msg;
1416	cf::cleanup "mandatory extension failed to load, exiting.";	1560	cf::cleanup "mandatory extension '$k' failed to load, exiting."
1417	}	1561	if exists $v->{meta}{mandatory};
1418		1562
1419	warn $msg;	1563	warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
		1564	delete $todo{$k};
		1565	} else {
		1566	$done{$k} = delete $todo{$k};
		1567	push @EXTS, $v->{pkg};
		1568	$progress = 1;
		1569
		1570	info "$v->{base}: extension inactive.\n"
		1571	unless $active;
1420	}	1572	}
1421
1422	$done{$k} = delete $todo{$k};
1423	push @EXTS, $v->{pkg};
1424	$progress = 1;
1425	}	1573	}
1426		1574
1427	skip:	1575	unless ($progress) {
1428	die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"	1576	warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1429	unless $progress;	1577
		1578	while (my ($k, $v) = each %todo) {
		1579	cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
		1580	if exists $v->{meta}{mandatory};
		1581	}
		1582
		1583	last;
		1584	}
1430	}	1585	}
1431	};	1586	};
1432	}	1587	}
1433		1588
1434	#############################################################################	1589	#############################################################################
…		…
1518	$cf::PLAYER{$login} = $pl	1673	$cf::PLAYER{$login} = $pl
1519	}	1674	}
1520	}	1675	}
1521	}	1676	}
1522		1677
		1678	cf::player->attach (
		1679	on_load => sub {
		1680	my ($pl, $path) = @_;
		1681
		1682	# restore slots saved in save, below
		1683	my $slots = delete $pl->{_slots};
		1684
		1685	$pl->ob->current_weapon ($slots->[0]);
		1686	$pl->combat_ob ($slots->[1]);
		1687	$pl->ranged_ob ($slots->[2]);
		1688	},
		1689	);
		1690
1523	sub save($) {	1691	sub save($) {
1524	my ($pl) = @_;	1692	my ($pl) = @_;
1525		1693
1526	return if $pl->{deny_save};	1694	return if $pl->{deny_save};
1527		1695
…		…
1532		1700
1533	aio_mkdir playerdir $pl, 0770;	1701	aio_mkdir playerdir $pl, 0770;
1534	$pl->{last_save} = $cf::RUNTIME;	1702	$pl->{last_save} = $cf::RUNTIME;
1535		1703
1536	cf::get_slot 0.01;	1704	cf::get_slot 0.01;
		1705
		1706	# save slots, to be restored later
		1707	local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1537		1708
1538	$pl->save_pl ($path);	1709	$pl->save_pl ($path);
1539	cf::cede_to_tick;	1710	cf::cede_to_tick;
1540	}	1711	}
1541		1712
…		…
1575	my $name = $pl->ob->name;	1746	my $name = $pl->ob->name;
1576		1747
1577	$pl->{deny_save} = 1;	1748	$pl->{deny_save} = 1;
1578	$pl->password ("*"); # this should lock out the player until we have nuked the dir	1749	$pl->password ("*"); # this should lock out the player until we have nuked the dir
1579		1750
1580	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;	1751	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1581	$pl->deactivate;	1752	$pl->deactivate;
		1753
1582	my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;	1754	my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1583	$pl->ob->check_score;
1584	$pl->invoke (cf::EVENT_PLAYER_QUIT);	1755	$pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
		1756	ext::highscore::check ($pl->ob);
		1757
1585	$pl->ns->destroy if $pl->ns;	1758	$pl->ns->destroy if $pl->ns;
1586		1759
1587	my $path = playerdir $pl;	1760	my $path = playerdir $pl;
1588	my $temp = "$path~$cf::RUNTIME~deleting~";	1761	my $temp = "$path~$cf::RUNTIME~deleting~";
1589	aio_rename $path, $temp;	1762	aio_rename $path, $temp;
…		…
1643	\@logins	1816	\@logins
1644	}	1817	}
1645		1818
1646	=item $player->maps	1819	=item $player->maps
1647		1820
		1821	=item cf::player::maps $login
		1822
1648	Returns an arrayref of map paths that are private for this	1823	Returns an arrayref of map paths that are private for this
1649	player. May block.	1824	player. May block.
1650		1825
1651	=cut	1826	=cut
1652		1827
…		…
1714	=cut	1889	=cut
1715		1890
1716	sub find_by_path($) {	1891	sub find_by_path($) {
1717	my ($path) = @_;	1892	my ($path) = @_;
1718		1893
		1894	$path =~ s/^~[^\/]*//; # skip ~login
		1895
1719	my ($match, $specificity);	1896	my ($match, $specificity);
1720		1897
1721	for my $region (list) {	1898	for my $region (list) {
1722	if ($region->{match} && $path =~ $region->{match}) {	1899	if ($region->{match} && $path =~ $region->{match}) {
1723	($match, $specificity) = ($region, $region->specificity)	1900	($match, $specificity) = ($region, $region->specificity)
…		…
1751	sub generate_random_map {	1928	sub generate_random_map {
1752	my ($self, $rmp) = @_;	1929	my ($self, $rmp) = @_;
1753		1930
1754	my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM	1931	my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1755		1932
1756	# mit "rum" bekleckern, nicht
1757	$self->_create_random_map (	1933	$self->_create_random_map ($rmp);
1758	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1759	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1760	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1761	$rmp->{exit_on_final_map},
1762	$rmp->{xsize}, $rmp->{ysize},
1763	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1764	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1765	$rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1766	$rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1767	$rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1768	(cf::region::find $rmp->{region}), $rmp->{custom}
1769	)
1770	}	1934	}
1771		1935
1772	=item cf::map->register ($regex, $prio)	1936	=item cf::map->register ($regex, $prio)
1773		1937
1774	Register a handler for the map path matching the given regex at the	1938	Register a handler for the map path matching the given regex at the
…		…
1779		1943
1780	sub register {	1944	sub register {
1781	my (undef, $regex, $prio) = @_;	1945	my (undef, $regex, $prio) = @_;
1782	my $pkg = caller;	1946	my $pkg = caller;
1783		1947
1784	no strict;
1785	push @{"$pkg\::ISA"}, __PACKAGE__;	1948	push @{"$pkg\::ISA"}, __PACKAGE__;
1786		1949
1787	$EXT_MAP{$pkg} = [$prio, qr<$regex>];	1950	$EXT_MAP{$pkg} = [$prio, qr<$regex>];
1788	}	1951	}
1789		1952
1790	# also paths starting with '/'	1953	# also paths starting with '/'
1791	$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];	1954	$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1792		1955
1793	sub thawer_merge {	1956	sub thawer_merge {
1794	my ($self, $merge) = @_;	1957	my ($self, $merge) = @_;
1795		1958
1796	# we have to keep some variables in memory intact	1959	# we have to keep some variables in memory intact
…		…
1801	}	1964	}
1802		1965
1803	sub normalise {	1966	sub normalise {
1804	my ($path, $base) = @_;	1967	my ($path, $base) = @_;
1805		1968
1806	$path = "$path"; # make sure its a string	1969	$path = "$path"; # make sure it's a string
1807		1970
1808	$path =~ s/\.map$//;	1971	$path =~ s/\.map$//;
1809		1972
1810	# map plan:	1973	# map plan:
1811	#	1974	#
…		…
1826	$base =~ s{[^/]+/?$}{};	1989	$base =~ s{[^/]+/?$}{};
1827	$path = "$base/$path";	1990	$path = "$base/$path";
1828	}	1991	}
1829		1992
1830	for ($path) {	1993	for ($path) {
1831	redo if s{//}{/};
1832	redo if s{/\.?/}{/};	1994	redo if s{/\.?/}{/};
1833	redo if s{/[^/]+/\.\./}{/};	1995	redo if s{/[^/]+/\.\./}{/};
1834	}	1996	}
1835		1997
1836	$path	1998	$path
…		…
1850	$self->init; # pass $1 etc.	2012	$self->init; # pass $1 etc.
1851	return $self;	2013	return $self;
1852	}	2014	}
1853	}	2015	}
1854		2016
1855	Carp::cluck "unable to resolve path '$path' (base '$base').";	2017	Carp::cluck "unable to resolve path '$path' (base '$base')";
1856	()	2018	()
1857	}	2019	}
1858		2020
		2021	# may re-bless or do other evil things
1859	sub init {	2022	sub init {
1860	my ($self) = @_;	2023	my ($self) = @_;
1861		2024
1862	$self	2025	$self
1863	}	2026	}
…		…
1928	$self->{load_path} = $path;	2091	$self->{load_path} = $path;
1929		2092
1930	1	2093	1
1931	}	2094	}
1932		2095
		2096	# used to laod the header of an original map
1933	sub load_header_orig {	2097	sub load_header_orig {
1934	my ($self) = @_;	2098	my ($self) = @_;
1935		2099
1936	$self->load_header_from ($self->load_path)	2100	$self->load_header_from ($self->load_path)
1937	}	2101	}
1938		2102
		2103	# used to laod the header of an instantiated map
1939	sub load_header_temp {	2104	sub load_header_temp {
1940	my ($self) = @_;	2105	my ($self) = @_;
1941		2106
1942	$self->load_header_from ($self->save_path)	2107	$self->load_header_from ($self->save_path)
1943	}	2108	}
1944		2109
		2110	# called after loading the header from an instantiated map
1945	sub prepare_temp {	2111	sub prepare_temp {
1946	my ($self) = @_;	2112	my ($self) = @_;
1947		2113
1948	$self->last_access ((delete $self->{last_access})	2114	$self->last_access ((delete $self->{last_access})
1949	|| $cf::RUNTIME); #d#	2115	|| $cf::RUNTIME); #d#
1950	# safety	2116	# safety
1951	$self->{instantiate_time} = $cf::RUNTIME	2117	$self->{instantiate_time} = $cf::RUNTIME
1952	if $self->{instantiate_time} > $cf::RUNTIME;	2118	if $self->{instantiate_time} > $cf::RUNTIME;
1953	}	2119	}
1954		2120
		2121	# called after loading the header from an original map
1955	sub prepare_orig {	2122	sub prepare_orig {
1956	my ($self) = @_;	2123	my ($self) = @_;
1957		2124
1958	$self->{load_original} = 1;	2125	$self->{load_original} = 1;
1959	$self->{instantiate_time} = $cf::RUNTIME;	2126	$self->{instantiate_time} = $cf::RUNTIME;
…		…
1983		2150
1984	sub find;	2151	sub find;
1985	sub find {	2152	sub find {
1986	my ($path, $origin) = @_;	2153	my ($path, $origin) = @_;
1987		2154
		2155	cf::cede_to_tick;
		2156
1988	$path = normalise $path, $origin && $origin->path;	2157	$path = normalise $path, $origin;
1989		2158
1990	my $guard1 = cf::lock_acquire "map_data:$path";#d#remove	2159	my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1991	my $guard2 = cf::lock_acquire "map_find:$path";	2160	my $guard2 = cf::lock_acquire "map_find:$path";
1992		2161
1993	$cf::MAP{$path} || do {	2162	$cf::MAP{$path} || do {
…		…
2010		2179
2011	$cf::MAP{$path} = $map	2180	$cf::MAP{$path} = $map
2012	}	2181	}
2013	}	2182	}
2014		2183
2015	sub pre_load { }	2184	sub pre_load { }
2016	sub post_load { }	2185	#sub post_load { } # XS
2017		2186
2018	sub load {	2187	sub load {
2019	my ($self) = @_;	2188	my ($self) = @_;
2020		2189
2021	local $self->{deny_reset} = 1; # loading can take a long time	2190	local $self->{deny_reset} = 1; # loading can take a long time
…		…
2024		2193
2025	{	2194	{
2026	my $guard = cf::lock_acquire "map_data:$path";	2195	my $guard = cf::lock_acquire "map_data:$path";
2027		2196
2028	return unless $self->valid;	2197	return unless $self->valid;
2029	return unless $self->in_memory == cf::MAP_SWAPPED;	2198	return unless $self->state == cf::MAP_SWAPPED;
2030
2031	$self->in_memory (cf::MAP_LOADING);
2032		2199
2033	$self->alloc;	2200	$self->alloc;
2034		2201
2035	$self->pre_load;	2202	$self->pre_load;
2036	cf::cede_to_tick;	2203	cf::cede_to_tick;
2037		2204
		2205	if (exists $self->{load_path}) {
2038	my $f = new_from_file cf::object::thawer $self->{load_path};	2206	my $f = new_from_file cf::object::thawer $self->{load_path};
2039	$f->skip_block;	2207	$f->skip_block;
2040	$self->_load_objects ($f)	2208	$self->_load_objects ($f)
2041	or return;	2209	or return;
2042		2210
2043	$self->post_load_original	2211	$self->post_load_original
2044	if delete $self->{load_original};	2212	if delete $self->{load_original};
2045		2213
2046	if (my $uniq = $self->uniq_path) {	2214	if (my $uniq = $self->uniq_path) {
2047	utf8::encode $uniq;	2215	utf8::encode $uniq;
2048	unless (aio_stat $uniq) {	2216	unless (aio_stat $uniq) {
2049	if (my $f = new_from_file cf::object::thawer $uniq) {	2217	if (my $f = new_from_file cf::object::thawer $uniq) {
2050	$self->clear_unique_items;	2218	$self->clear_unique_items;
2051	$self->_load_objects ($f);	2219	$self->_load_objects ($f);
2052	$f->resolve_delayed_derefs;	2220	$f->resolve_delayed_derefs;
		2221	}
2053	}	2222	}
2054	}	2223	}
2055	}
2056		2224
2057	$f->resolve_delayed_derefs;	2225	$f->resolve_delayed_derefs;
		2226	} else {
		2227	$self->post_load_original
		2228	if delete $self->{load_original};
		2229	}
		2230
		2231	$self->state (cf::MAP_INACTIVE);
2058		2232
2059	cf::cede_to_tick;	2233	cf::cede_to_tick;
2060	# now do the right thing for maps	2234	# now do the right thing for maps
2061	$self->link_multipart_objects;	2235	$self->link_multipart_objects;
2062	$self->difficulty ($self->estimate_difficulty)	2236	$self->difficulty ($self->estimate_difficulty)
…		…
2066	unless ($self->{deny_activate}) {	2240	unless ($self->{deny_activate}) {
2067	$self->decay_objects;	2241	$self->decay_objects;
2068	$self->fix_auto_apply;	2242	$self->fix_auto_apply;
2069	$self->update_buttons;	2243	$self->update_buttons;
2070	cf::cede_to_tick;	2244	cf::cede_to_tick;
2071	$self->activate;	2245	#$self->activate; # no longer activate maps automatically
2072	}	2246	}
2073		2247
2074	$self->{last_save} = $cf::RUNTIME;	2248	$self->{last_save} = $cf::RUNTIME;
2075	$self->last_access ($cf::RUNTIME);	2249	$self->last_access ($cf::RUNTIME);
2076
2077	$self->in_memory (cf::MAP_ACTIVE);
2078	}	2250	}
2079		2251
2080	$self->post_load;	2252	$self->post_load;
2081	}
2082		2253
		2254	1
		2255	}
		2256
		2257	# customize the map for a given player, i.e.
		2258	# return the _real_ map. used by e.g. per-player
		2259	# maps to change the path to ~playername/mappath
2083	sub customise_for {	2260	sub customise_for {
2084	my ($self, $ob) = @_;	2261	my ($self, $ob) = @_;
2085		2262
2086	return find "~" . $ob->name . "/" . $self->{path}	2263	return find "~" . $ob->name . "/" . $self->{path}
2087	if $self->per_player;	2264	if $self->per_player;
…		…
2090	# if $self->per_party;	2267	# if $self->per_party;
2091		2268
2092	$self	2269	$self
2093	}	2270	}
2094		2271
2095	# find and load all maps in the 3x3 area around a map
2096	sub load_neighbours {
2097	my ($map) = @_;
2098
2099	my @neigh; # diagonal neighbours
2100
2101	for (0 .. 3) {
2102	my $neigh = $map->tile_path ($_)
2103	or next;
2104	$neigh = find $neigh, $map
2105	or next;
2106	$neigh->load;
2107
2108	push @neigh,
2109	[$neigh->tile_path (($_ + 3) % 4), $neigh],
2110	[$neigh->tile_path (($_ + 1) % 4), $neigh];
2111	}
2112
2113	for (grep defined $_->[0], @neigh) {
2114	my ($path, $origin) = @$_;
2115	my $neigh = find $path, $origin
2116	or next;
2117	$neigh->load;
2118	}
2119	}
2120
2121	sub find_sync {	2272	sub find_sync {
2122	my ($path, $origin) = @_;	2273	my ($path, $origin) = @_;
2123		2274
2124	cf::sync_job { find $path, $origin }	2275	# it's a bug to call this from the main context
		2276	return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
		2277	if $Coro::current == $Coro::main;
		2278
		2279	find $path, $origin
2125	}	2280	}
2126		2281
2127	sub do_load_sync {	2282	sub do_load_sync {
2128	my ($map) = @_;	2283	my ($map) = @_;
2129		2284
		2285	# it's a bug to call this from the main context
2130	cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"	2286	return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2131	if $Coro::current == $Coro::main;	2287	if $Coro::current == $Coro::main;
2132		2288
2133	cf::sync_job { $map->load };	2289	$map->load;
2134	}	2290	}
2135		2291
2136	our %MAP_PREFETCH;	2292	our %MAP_PREFETCH;
2137	our $MAP_PREFETCHER = undef;	2293	our $MAP_PREFETCHER = undef;
2138		2294
2139	sub find_async {	2295	sub find_async {
2140	my ($path, $origin, $load) = @_;	2296	my ($path, $origin, $load) = @_;
2141		2297
2142	$path = normalise $path, $origin && $origin->{path};	2298	$path = normalise $path, $origin;
2143		2299
2144	if (my $map = $cf::MAP{$path}) {	2300	if (my $map = $cf::MAP{$path}) {
2145	return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;	2301	return $map if !$load || $map->linkable;
2146	}	2302	}
2147		2303
2148	$MAP_PREFETCH{$path} |= $load;	2304	$MAP_PREFETCH{$path} |= $load;
2149		2305
2150	$MAP_PREFETCHER ||= cf::async {	2306	$MAP_PREFETCHER ||= cf::async {
…		…
2164	$MAP_PREFETCHER->prio (6);	2320	$MAP_PREFETCHER->prio (6);
2165		2321
2166	()	2322	()
2167	}	2323	}
2168		2324
		2325	# common code, used by both ->save and ->swapout
2169	sub save {	2326	sub _save {
2170	my ($self) = @_;	2327	my ($self) = @_;
2171
2172	my $lock = cf::lock_acquire "map_data:$self->{path}";
2173		2328
2174	$self->{last_save} = $cf::RUNTIME;	2329	$self->{last_save} = $cf::RUNTIME;
2175		2330
2176	return unless $self->dirty;	2331	return unless $self->dirty;
2177		2332
…		…
2197	} else {	2352	} else {
2198	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);	2353	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2199	}	2354	}
2200	}	2355	}
2201		2356
		2357	sub save {
		2358	my ($self) = @_;
		2359
		2360	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2361
		2362	$self->_save;
		2363	}
		2364
2202	sub swap_out {	2365	sub swap_out {
2203	my ($self) = @_;	2366	my ($self) = @_;
2204		2367
2205	# save first because save cedes
2206	$self->save;
2207
2208	my $lock = cf::lock_acquire "map_data:$self->{path}";	2368	my $lock = cf::lock_acquire "map_data:$self->{path}";
2209		2369
		2370	return if !$self->linkable;
		2371	return if $self->{deny_save};
2210	return if $self->players;	2372	return if $self->players;
2211	return if $self->in_memory != cf::MAP_ACTIVE;	2373
		2374	# first deactivate the map and "unlink" it from the core
		2375	$self->deactivate;
		2376	$_->clear_links_to ($self) for values %cf::MAP;
		2377	$self->state (cf::MAP_SWAPPED);
		2378
		2379	# then atomically save
		2380	$self->_save;
		2381
		2382	# then free the map
		2383	$self->clear;
		2384	}
		2385
		2386	sub reset_at {
		2387	my ($self) = @_;
		2388
		2389	# TODO: safety, remove and allow resettable per-player maps
2212	return if $self->{deny_save};	2390	return 1e99 if $self->{deny_reset};
2213		2391
		2392	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
		2393	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
		2394
		2395	$time + $to
		2396	}
		2397
		2398	sub should_reset {
		2399	my ($self) = @_;
		2400
		2401	$self->reset_at <= $cf::RUNTIME
		2402	}
		2403
		2404	sub reset {
		2405	my ($self) = @_;
		2406
		2407	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2408
		2409	return if $self->players;
		2410
		2411	cf::trace "resetting map ", $self->path, "\n";
		2412
2214	$self->in_memory (cf::MAP_SWAPPED);	2413	$self->state (cf::MAP_SWAPPED);
		2414
		2415	# need to save uniques path
		2416	unless ($self->{deny_save}) {
		2417	my $uniq = $self->uniq_path; utf8::encode $uniq;
		2418
		2419	$self->_save_objects ($uniq, cf::IO_UNIQUES)
		2420	if $uniq;
		2421	}
		2422
		2423	delete $cf::MAP{$self->path};
2215		2424
2216	$self->deactivate;	2425	$self->deactivate;
2217	$_->clear_links_to ($self) for values %cf::MAP;	2426	$_->clear_links_to ($self) for values %cf::MAP;
2218	$self->clear;	2427	$self->clear;
2219	}
2220
2221	sub reset_at {
2222	my ($self) = @_;
2223
2224	# TODO: safety, remove and allow resettable per-player maps
2225	return 1e99 if $self->{deny_reset};
2226
2227	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2228	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2229
2230	$time + $to
2231	}
2232
2233	sub should_reset {
2234	my ($self) = @_;
2235
2236	$self->reset_at <= $cf::RUNTIME
2237	}
2238
2239	sub reset {
2240	my ($self) = @_;
2241
2242	my $lock = cf::lock_acquire "map_data:$self->{path}";
2243
2244	return if $self->players;
2245
2246	warn "resetting map ", $self->path, "\n";
2247
2248	$self->in_memory (cf::MAP_SWAPPED);
2249
2250	# need to save uniques path
2251	unless ($self->{deny_save}) {
2252	my $uniq = $self->uniq_path; utf8::encode $uniq;
2253
2254	$self->_save_objects ($uniq, cf::IO_UNIQUES)
2255	if $uniq;
2256	}
2257
2258	delete $cf::MAP{$self->path};
2259
2260	$self->deactivate;
2261	$_->clear_links_to ($self) for values %cf::MAP;
2262	$self->clear;
2263		2428
2264	$self->unlink_save;	2429	$self->unlink_save;
2265	$self->destroy;	2430	$self->destroy;
2266	}	2431	}
2267		2432
…		…
2275		2440
2276	delete $cf::MAP{$self->path};	2441	delete $cf::MAP{$self->path};
2277		2442
2278	$self->unlink_save;	2443	$self->unlink_save;
2279		2444
2280	bless $self, "cf::map";	2445	bless $self, "cf::map::wrap";
2281	delete $self->{deny_reset};	2446	delete $self->{deny_reset};
2282	$self->{deny_save} = 1;	2447	$self->{deny_save} = 1;
2283	$self->reset_timeout (1);	2448	$self->reset_timeout (1);
2284	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2449	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2285		2450
…		…
2515		2680
2516	Freezes the player and moves him/her to a special map (C<{link}>).	2681	Freezes the player and moves him/her to a special map (C<{link}>).
2517		2682
2518	The player should be reasonably safe there for short amounts of time (e.g.	2683	The player should be reasonably safe there for short amounts of time (e.g.
2519	for loading a map). You I<MUST> call C<leave_link> as soon as possible,	2684	for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2520	though, as the palyer cannot control the character while it is on the link	2685	though, as the player cannot control the character while it is on the link
2521	map.	2686	map.
2522		2687
2523	Will never block.	2688	Will never block.
2524		2689
2525	=item $player_object->leave_link ($map, $x, $y)	2690	=item $player_object->leave_link ($map, $x, $y)
…		…
2546	sub cf::object::player::enter_link {	2711	sub cf::object::player::enter_link {
2547	my ($self) = @_;	2712	my ($self) = @_;
2548		2713
2549	$self->deactivate_recursive;	2714	$self->deactivate_recursive;
2550		2715
		2716	++$self->{_link_recursion};
		2717
2551	return if UNIVERSAL::isa $self->map, "ext::map_link";	2718	return if UNIVERSAL::isa $self->map, "ext::map_link";
2552		2719
2553	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]	2720	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2554	if $self->map && $self->map->{path} ne "{link}";	2721	if $self->map && $self->map->{path} ne "{link}";
2555		2722
2556	$self->enter_map ($LINK_MAP || link_map, 10, 10);	2723	$self->enter_map ($LINK_MAP || link_map, 3, 3);
2557	}	2724	}
2558		2725
2559	sub cf::object::player::leave_link {	2726	sub cf::object::player::leave_link {
2560	my ($self, $map, $x, $y) = @_;	2727	my ($self, $map, $x, $y) = @_;
2561		2728
…		…
2581	# use -1 or undef as default coordinates, not 0, 0	2748	# use -1 or undef as default coordinates, not 0, 0
2582	($x, $y) = ($map->enter_x, $map->enter_y)	2749	($x, $y) = ($map->enter_x, $map->enter_y)
2583	if $x <= 0 && $y <= 0;	2750	if $x <= 0 && $y <= 0;
2584		2751
2585	$map->load;	2752	$map->load;
2586	$map->load_neighbours;
2587		2753
2588	return unless $self->contr->active;	2754	return unless $self->contr->active;
2589		2755
2590	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2756	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2591	$self->enter_map ($map, $x, $y);	2757	if ($self->enter_map ($map, $x, $y)) {
2592		2758	# entering was successful
		2759	delete $self->{_link_recursion};
2593	# only activate afterwards, to support waiting in hooks	2760	# only activate afterwards, to support waiting in hooks
2594	$self->activate_recursive;	2761	$self->activate_recursive;
2595	}	2762	}
2596		2763
		2764	}
		2765
2597	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])	2766	=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2598		2767
2599	Moves the player to the given map-path and coordinates by first freezing	2768	Moves the player to the given map-path and coordinates by first freezing
2600	her, loading and preparing them map, calling the provided $check callback	2769	her, loading and preparing them map, calling the provided $check callback
2601	that has to return the map if sucecssful, and then unfreezes the player on	2770	that has to return the map if sucecssful, and then unfreezes the player on
2602	the new (success) or old (failed) map position. In either case, $done will	2771	the new (success) or old (failed) map position. In either case, $done will
…		…
2609		2778
2610	our $GOTOGEN;	2779	our $GOTOGEN;
2611		2780
2612	sub cf::object::player::goto {	2781	sub cf::object::player::goto {
2613	my ($self, $path, $x, $y, $check, $done) = @_;	2782	my ($self, $path, $x, $y, $check, $done) = @_;
		2783
		2784	if ($self->{_link_recursion} >= $MAX_LINKS) {
		2785	error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
		2786	$self->failmsg ("Something went wrong inside the server - please contact an administrator!");
		2787	($path, $x, $y) = @$EMERGENCY_POSITION;
		2788	}
2614		2789
2615	# do generation counting so two concurrent goto's will be executed in-order	2790	# do generation counting so two concurrent goto's will be executed in-order
2616	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2791	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2617		2792
2618	$self->enter_link;	2793	$self->enter_link;
…		…
2638	($path, $x, $y) = (undef, undef, undef);	2813	($path, $x, $y) = (undef, undef, undef);
2639	}	2814	}
2640	}	2815	}
2641		2816
2642	my $map = eval {	2817	my $map = eval {
2643	my $map = defined $path ? cf::map::find $path : undef;	2818	my $map = defined $path ? cf::map::find $path, $self->map : undef;
2644		2819
2645	if ($map) {	2820	if ($map) {
2646	$map = $map->customise_for ($self);	2821	$map = $map->customise_for ($self);
2647	$map = $check->($map) if $check && $map;	2822	$map = $check->($map, $x, $y, $self) if $check && $map;
2648	} else {	2823	} else {
2649	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);	2824	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2650	}	2825	}
2651		2826
2652	$map	2827	$map
…		…
2660	if ($gen == $self->{_goto_generation}) {	2835	if ($gen == $self->{_goto_generation}) {
2661	delete $self->{_goto_generation};	2836	delete $self->{_goto_generation};
2662	$self->leave_link ($map, $x, $y);	2837	$self->leave_link ($map, $x, $y);
2663	}	2838	}
2664		2839
2665	$done->() if $done;	2840	$done->($self) if $done;
2666	})->prio (1);	2841	})->prio (1);
2667	}	2842	}
2668		2843
2669	=item $player_object->enter_exit ($exit_object)	2844	=item $player_object->enter_exit ($exit_object)
2670		2845
…		…
2738	$Coro::current->{desc} = "enter_exit";	2913	$Coro::current->{desc} = "enter_exit";
2739		2914
2740	unless (eval {	2915	unless (eval {
2741	$self->deactivate_recursive; # just to be sure	2916	$self->deactivate_recursive; # just to be sure
2742		2917
2743	# random map handling
2744	{
2745	my $guard = cf::lock_acquire "exit_prepare:$exit";
2746
2747	prepare_random_map $exit
2748	if $exit->slaying eq "/!";
2749	}
2750
2751	my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;	2918	my $map = cf::map::normalise $exit->slaying, $exit->map;
2752	my $x = $exit->stats->hp;	2919	my $x = $exit->stats->hp;
2753	my $y = $exit->stats->sp;	2920	my $y = $exit->stats->sp;
		2921
		2922	# special map handling
		2923	my $slaying = $exit->slaying;
		2924
		2925	# special map handling
		2926	if ($slaying eq "/!") {
		2927	my $guard = cf::lock_acquire "exit_prepare:$exit";
		2928
		2929	prepare_random_map $exit
		2930	if $exit->slaying eq "/!"; # need to re-check after getting the lock
		2931
		2932	$map = $exit->slaying;
		2933
		2934	} elsif ($slaying eq '!up') {
		2935	$map = $exit->map->tile_path (cf::TILE_UP);
		2936	$x = $exit->x;
		2937	$y = $exit->y;
		2938
		2939	} elsif ($slaying eq '!down') {
		2940	$map = $exit->map->tile_path (cf::TILE_DOWN);
		2941	$x = $exit->x;
		2942	$y = $exit->y;
		2943	}
2754		2944
2755	$self->goto ($map, $x, $y);	2945	$self->goto ($map, $x, $y);
2756		2946
2757	# if exit is damned, update players death & WoR home-position	2947	# if exit is damned, update players death & WoR home-position
2758	$self->contr->savebed ($map, $x, $y)	2948	$self->contr->savebed ($map, $x, $y)
…		…
2763	$self->message ("Something went wrong deep within the deliantra server. "	2953	$self->message ("Something went wrong deep within the deliantra server. "
2764	. "I'll try to bring you back to the map you were before. "	2954	. "I'll try to bring you back to the map you were before. "
2765	. "Please report this to the dungeon master!",	2955	. "Please report this to the dungeon master!",
2766	cf::NDI_UNIQUE | cf::NDI_RED);	2956	cf::NDI_UNIQUE | cf::NDI_RED);
2767		2957
2768	warn "ERROR in enter_exit: $@";	2958	error "ERROR in enter_exit: $@";
2769	$self->leave_link;	2959	$self->leave_link;
2770	}	2960	}
2771	})->prio (1);	2961	})->prio (1);
2772	}	2962	}
2773		2963
…		…
2785	sub cf::client::send_drawinfo {	2975	sub cf::client::send_drawinfo {
2786	my ($self, $text, $flags) = @_;	2976	my ($self, $text, $flags) = @_;
2787		2977
2788	utf8::encode $text;	2978	utf8::encode $text;
2789	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);	2979	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
		2980	}
		2981
		2982	=item $client->send_big_packet ($pkt)
		2983
		2984	Like C<send_packet>, but tries to compress large packets, and fragments
		2985	them as required.
		2986
		2987	=cut
		2988
		2989	our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
		2990
		2991	sub cf::client::send_big_packet {
		2992	my ($self, $pkt) = @_;
		2993
		2994	# try lzf for large packets
		2995	$pkt = "lzf " . Compress::LZF::compress $pkt
		2996	if 1024 <= length $pkt and $self->{can_lzf};
		2997
		2998	# split very large packets
		2999	if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
		3000	$self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
		3001	$pkt = "frag";
		3002	}
		3003
		3004	$self->send_packet ($pkt);
2790	}	3005	}
2791		3006
2792	=item $client->send_msg ($channel, $msg, $color, [extra...])	3007	=item $client->send_msg ($channel, $msg, $color, [extra...])
2793		3008
2794	Send a drawinfo or msg packet to the client, formatting the msg for the	3009	Send a drawinfo or msg packet to the client, formatting the msg for the
…		…
2946	my $pkt = "msg "	3161	my $pkt = "msg "
2947	. $self->{json_coder}->encode (	3162	. $self->{json_coder}->encode (
2948	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]	3163	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2949	);	3164	);
2950		3165
2951	# try lzf for large packets
2952	$pkt = "lzf " . Compress::LZF::compress $pkt
2953	if 1024 <= length $pkt and $self->{can_lzf};
2954
2955	# split very large packets
2956	if (8192 < length $pkt and $self->{can_lzf}) {
2957	$self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2958	$pkt = "frag";
2959	}
2960
2961	$self->send_packet ($pkt);	3166	$self->send_big_packet ($pkt);
2962	}	3167	}
2963		3168
2964	=item $client->ext_msg ($type, @msg)	3169	=item $client->ext_msg ($type, @msg)
2965		3170
2966	Sends an ext event to the client.	3171	Sends an ext event to the client.
…		…
2969		3174
2970	sub cf::client::ext_msg($$@) {	3175	sub cf::client::ext_msg($$@) {
2971	my ($self, $type, @msg) = @_;	3176	my ($self, $type, @msg) = @_;
2972		3177
2973	if ($self->extcmd == 2) {	3178	if ($self->extcmd == 2) {
2974	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));	3179	$self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2975	} elsif ($self->extcmd == 1) { # TODO: remove	3180	} elsif ($self->extcmd == 1) { # TODO: remove
2976	push @msg, msgtype => "event_$type";	3181	push @msg, msgtype => "event_$type";
2977	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));	3182	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2978	}	3183	}
2979	}	3184	}
2980		3185
2981	=item $client->ext_reply ($msgid, @msg)	3186	=item $client->ext_reply ($msgid, @msg)
2982		3187
…		…
2986		3191
2987	sub cf::client::ext_reply($$@) {	3192	sub cf::client::ext_reply($$@) {
2988	my ($self, $id, @msg) = @_;	3193	my ($self, $id, @msg) = @_;
2989		3194
2990	if ($self->extcmd == 2) {	3195	if ($self->extcmd == 2) {
2991	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));	3196	$self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2992	} elsif ($self->extcmd == 1) {	3197	} elsif ($self->extcmd == 1) {
2993	#TODO: version 1, remove	3198	#TODO: version 1, remove
2994	unshift @msg, msgtype => "reply", msgid => $id;	3199	unshift @msg, msgtype => "reply", msgid => $id;
2995	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));	3200	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2996	}	3201	}
2997	}	3202	}
2998		3203
2999	=item $success = $client->query ($flags, "text", \&cb)	3204	=item $success = $client->query ($flags, "text", \&cb)
3000		3205
…		…
3071		3276
3072	$ns->ext_reply ($reply, @reply)	3277	$ns->ext_reply ($reply, @reply)
3073	if $reply;	3278	if $reply;
3074		3279
3075	} else {	3280	} else {
3076	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	3281	error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3077	}	3282	}
3078		3283
3079	cf::override;	3284	cf::override;
3080	},	3285	},
3081	);	3286	);
…		…
3101		3306
3102	$coro	3307	$coro
3103	}	3308	}
3104		3309
3105	cf::client->attach (	3310	cf::client->attach (
3106	on_destroy => sub {	3311	on_client_destroy => sub {
3107	my ($ns) = @_;	3312	my ($ns) = @_;
3108		3313
3109	$_->cancel for values %{ (delete $ns->{_coro}) || {} };	3314	$_->cancel for values %{ (delete $ns->{_coro}) || {} };
3110	},	3315	},
3111	);	3316	);
…		…
3127	our $safe_hole = new Safe::Hole;	3332	our $safe_hole = new Safe::Hole;
3128		3333
3129	$SIG{FPE} = 'IGNORE';	3334	$SIG{FPE} = 'IGNORE';
3130		3335
3131	$safe->permit_only (Opcode::opset qw(	3336	$safe->permit_only (Opcode::opset qw(
3132	:base_core :base_mem :base_orig :base_math	3337	:base_core :base_mem :base_orig :base_math :base_loop
3133	grepstart grepwhile mapstart mapwhile	3338	grepstart grepwhile mapstart mapwhile
3134	sort time	3339	sort time
3135	));	3340	));
3136		3341
3137	# here we export the classes and methods available to script code	3342	# here we export the classes and methods available to script code
…		…
3162	decrease split destroy change_exp value msg lore send_msg)],	3367	decrease split destroy change_exp value msg lore send_msg)],
3163	["cf::object::player" => qw(player)],	3368	["cf::object::player" => qw(player)],
3164	["cf::player" => qw(peaceful send_msg)],	3369	["cf::player" => qw(peaceful send_msg)],
3165	["cf::map" => qw(trigger)],	3370	["cf::map" => qw(trigger)],
3166	) {	3371	) {
3167	no strict 'refs';
3168	my ($pkg, @funs) = @$_;	3372	my ($pkg, @funs) = @$_;
3169	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	3373	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3170	for @funs;	3374	for @funs;
3171	}	3375	}
3172		3376
…		…
3189	$qcode =~ s/"/‟/g; # not allowed in #line filenames	3393	$qcode =~ s/"/‟/g; # not allowed in #line filenames
3190	$qcode =~ s/\n/\\n/g;	3394	$qcode =~ s/\n/\\n/g;
3191		3395
3192	%vars = (_dummy => 0) unless %vars;	3396	%vars = (_dummy => 0) unless %vars;
3193		3397
		3398	my @res;
3194	local $_;	3399	local $_;
3195	local @safe::cf::_safe_eval_args = values %vars;
3196		3400
3197	my $eval =	3401	my $eval =
3198	"do {\n"	3402	"do {\n"
3199	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"	3403	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3200	. "#line 0 \"{$qcode}\"\n"	3404	. "#line 0 \"{$qcode}\"\n"
3201	. $code	3405	. $code
3202	. "\n}"	3406	. "\n}"
3203	;	3407	;
3204		3408
		3409	if ($CFG{safe_eval}) {
3205	sub_generation_inc;	3410	sub_generation_inc;
		3411	local @safe::cf::_safe_eval_args = values %vars;
3206	my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);	3412	@res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3207	sub_generation_inc;	3413	sub_generation_inc;
		3414	} else {
		3415	local @cf::_safe_eval_args = values %vars;
		3416	@res = wantarray ? eval eval : scalar eval $eval;
		3417	}
3208		3418
3209	if ($@) {	3419	if ($@) {
3210	warn "$@";	3420	warn "$@",
3211	warn "while executing safe code '$code'\n";	3421	"while executing safe code '$code'\n",
3212	warn "with arguments " . (join " ", %vars) . "\n";	3422	"with arguments " . (join " ", %vars) . "\n";
3213	}	3423	}
3214		3424
3215	wantarray ? @res : $res[0]	3425	wantarray ? @res : $res[0]
3216	}	3426	}
3217		3427
…		…
3231	=cut	3441	=cut
3232		3442
3233	sub register_script_function {	3443	sub register_script_function {
3234	my ($fun, $cb) = @_;	3444	my ($fun, $cb) = @_;
3235		3445
3236	no strict 'refs';	3446	$fun = "safe::$fun" if $CFG{safe_eval};
3237	*{"safe::$fun"} = $safe_hole->wrap ($cb);	3447	*$fun = $safe_hole->wrap ($cb);
3238	}	3448	}
3239		3449
3240	=back	3450	=back
3241		3451
3242	=cut	3452	=cut
…		…
3251	# for this (global event?)	3461	# for this (global event?)
3252	%ext::player_env::MUSIC_FACE_CACHE = ();	3462	%ext::player_env::MUSIC_FACE_CACHE = ();
3253		3463
3254	my $enc = JSON::XS->new->utf8->canonical->relaxed;	3464	my $enc = JSON::XS->new->utf8->canonical->relaxed;
3255		3465
3256	warn "loading facedata from $path\n";	3466	trace "loading facedata from $path\n";
3257		3467
3258	my $facedata;	3468	my $facedata = decode_storable load_file $path;
3259	0 < aio_load $path, $facedata
3260	or die "$path: $!";
3261
3262	$facedata = Coro::Storable::thaw $facedata;
3263		3469
3264	$facedata->{version} == 2	3470	$facedata->{version} == 2
3265	or cf::cleanup "$path: version mismatch, cannot proceed.";	3471	or cf::cleanup "$path: version mismatch, cannot proceed.";
3266		3472
3267	# patch in the exptable	3473	# patch in the exptable
		3474	my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3268	$facedata->{resource}{"res/exp_table"} = {	3475	$facedata->{resource}{"res/exp_table"} = {
3269	type => FT_RSRC,	3476	type => FT_RSRC,
3270	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),	3477	data => $exp_table,
		3478	hash => (Digest::MD5::md5 $exp_table),
3271	};	3479	};
3272	cf::cede_to_tick;	3480	cf::cede_to_tick;
3273		3481
3274	{	3482	{
3275	my $faces = $facedata->{faceinfo};	3483	my $faces = $facedata->{faceinfo};
…		…
3277	while (my ($face, $info) = each %$faces) {	3485	while (my ($face, $info) = each %$faces) {
3278	my $idx = (cf::face::find $face) || cf::face::alloc $face;	3486	my $idx = (cf::face::find $face) || cf::face::alloc $face;
3279		3487
3280	cf::face::set_visibility $idx, $info->{visibility};	3488	cf::face::set_visibility $idx, $info->{visibility};
3281	cf::face::set_magicmap $idx, $info->{magicmap};	3489	cf::face::set_magicmap $idx, $info->{magicmap};
3282	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};	3490	cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3283	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};	3491	cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
		3492	cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3284		3493
3285	cf::cede_to_tick;	3494	cf::cede_to_tick;
3286	}	3495	}
3287		3496
3288	while (my ($face, $info) = each %$faces) {	3497	while (my ($face, $info) = each %$faces) {
…		…
3293		3502
3294	if (my $smooth = cf::face::find $info->{smooth}) {	3503	if (my $smooth = cf::face::find $info->{smooth}) {
3295	cf::face::set_smooth $idx, $smooth;	3504	cf::face::set_smooth $idx, $smooth;
3296	cf::face::set_smoothlevel $idx, $info->{smoothlevel};	3505	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3297	} else {	3506	} else {
3298	warn "smooth face '$info->{smooth}' not found for face '$face'";	3507	error "smooth face '$info->{smooth}' not found for face '$face'";
3299	}	3508	}
3300		3509
3301	cf::cede_to_tick;	3510	cf::cede_to_tick;
3302	}	3511	}
3303	}	3512	}
…		…
3312		3521
3313	cf::anim::invalidate_all; # d'oh	3522	cf::anim::invalidate_all; # d'oh
3314	}	3523	}
3315		3524
3316	{	3525	{
3317	# TODO: for gcfclient pleasure, we should give resources
3318	# that gcfclient doesn't grok a >10000 face index.
3319	my $res = $facedata->{resource};	3526	my $res = $facedata->{resource};
3320		3527
3321	while (my ($name, $info) = each %$res) {	3528	while (my ($name, $info) = each %$res) {
3322	if (defined $info->{type}) {	3529	if (defined $info->{type}) {
3323	my $idx = (cf::face::find $name) || cf::face::alloc $name;	3530	my $idx = (cf::face::find $name) || cf::face::alloc $name;
3324	my $data;
3325		3531
3326	if ($info->{type} & 1) {	3532	cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3327	# prepend meta info
3328
3329	my $meta = $enc->encode ({
3330	name => $name,
3331	%{ $info->{meta} || {} },
3332	});
3333
3334	$data = pack "(w/a*)*", $meta, $info->{data};
3335	} else {
3336	$data = $info->{data};
3337	}
3338
3339	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3340	cf::face::set_type $idx, $info->{type};	3533	cf::face::set_type $idx, $info->{type};
3341	} else {	3534	} else {
3342	$RESOURCE{$name} = $info;	3535	$RESOURCE{$name} = $info; # unused
3343	}	3536	}
3344		3537
3345	cf::cede_to_tick;	3538	cf::cede_to_tick;
3346	}	3539	}
3347	}	3540	}
3348		3541
3349	cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);	3542	cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3350		3543
3351	1	3544	1
3352	}	3545	}
3353
3354	cf::global->attach (on_resource_update => sub {
3355	if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3356	$soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3357
3358	for (0 .. SOUND_CAST_SPELL_0 - 1) {
3359	my $sound = $soundconf->{compat}[$_]
3360	or next;
3361
3362	my $face = cf::face::find "sound/$sound->[1]";
3363	cf::sound::set $sound->[0] => $face;
3364	cf::sound::old_sound_index $_, $face; # gcfclient-compat
3365	}
3366
3367	while (my ($k, $v) = each %{$soundconf->{event}}) {
3368	my $face = cf::face::find "sound/$v";
3369	cf::sound::set $k => $face;
3370	}
3371	}
3372	});
3373		3546
3374	register_exticmd fx_want => sub {	3547	register_exticmd fx_want => sub {
3375	my ($ns, $want) = @_;	3548	my ($ns, $want) = @_;
3376		3549
3377	while (my ($k, $v) = each %$want) {	3550	while (my ($k, $v) = each %$want) {
…		…
3416	sub reload_treasures {	3589	sub reload_treasures {
3417	load_resource_file "$DATADIR/treasures"	3590	load_resource_file "$DATADIR/treasures"
3418	or die "unable to load treasurelists\n";	3591	or die "unable to load treasurelists\n";
3419	}	3592	}
3420		3593
		3594	sub reload_sound {
		3595	trace "loading sound config from $DATADIR/sound\n";
		3596
		3597	my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
		3598
		3599	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3600	my $sound = $soundconf->{compat}[$_]
		3601	or next;
		3602
		3603	my $face = cf::face::find "sound/$sound->[1]";
		3604	cf::sound::set $sound->[0] => $face;
		3605	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3606	}
		3607
		3608	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3609	my $face = cf::face::find "sound/$v";
		3610	cf::sound::set $k => $face;
		3611	}
		3612	}
		3613
3421	sub reload_resources {	3614	sub reload_resources {
3422	warn "reloading resource files...\n";	3615	trace "reloading resource files...\n";
3423		3616
		3617	reload_exp_table;
		3618	reload_materials;
3424	reload_facedata;	3619	reload_facedata;
		3620	reload_sound;
3425	reload_archetypes;	3621	reload_archetypes;
3426	reload_regions;	3622	reload_regions;
3427	reload_treasures;	3623	reload_treasures;
3428		3624
3429	warn "finished reloading resource files\n";	3625	trace "finished reloading resource files\n";
3430	}	3626	}
3431		3627
3432	sub reload_config {	3628	sub reload_config {
3433	warn "reloading config file...\n";	3629	trace "reloading config file...\n";
3434		3630
3435	open my $fh, "<:utf8", "$CONFDIR/config"	3631	my $config = load_file "$CONFDIR/config";
3436	or return;	3632	utf8::decode $config;
		3633	*CFG = decode_yaml $config;
3437		3634
3438	local $/;
3439	*CFG = YAML::XS::Load scalar <$fh>;
3440
3441	$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];	3635	$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3442		3636
3443	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};	3637	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3444	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};	3638	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3445		3639
3446	if (exists $CFG{mlockall}) {	3640	if (exists $CFG{mlockall}) {
…		…
3448	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"	3642	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3449	and die "WARNING: m(un)lockall failed: $!\n";	3643	and die "WARNING: m(un)lockall failed: $!\n";
3450	};	3644	};
3451	warn $@ if $@;	3645	warn $@ if $@;
3452	}	3646	}
3453
3454	warn "finished reloading resource files\n";
3455	}	3647	}
3456		3648
3457	sub pidfile() {	3649	sub pidfile() {
3458	sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT	3650	sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3459	or die "$PIDFILE: $!";	3651	or die "$PIDFILE: $!";
…		…
3472	seek $fh, 0, 0;	3664	seek $fh, 0, 0;
3473	print $fh $$;	3665	print $fh $$;
3474	}	3666	}
3475		3667
3476	sub main_loop {	3668	sub main_loop {
3477	warn "EV::loop starting\n";	3669	trace "EV::loop starting\n";
3478	if (1) {	3670	if (1) {
3479	EV::loop;	3671	EV::loop;
3480	}	3672	}
3481	warn "EV::loop returned\n";	3673	trace "EV::loop returned\n";
3482	goto &main_loop unless $REALLY_UNLOOP;	3674	goto &main_loop unless $REALLY_UNLOOP;
3483	}	3675	}
3484		3676
3485	sub main {	3677	sub main {
3486	cf::init_globals; # initialise logging	3678	cf::init_globals; # initialise logging
3487		3679
3488	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;	3680	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3489	LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";	3681	LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3490	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";	3682	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3491	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";	3683	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3492
3493	cf::init_experience;
3494	cf::init_anim;
3495	cf::init_attackmess;
3496	cf::init_dynamic;
3497		3684
3498	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority	3685	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3499		3686
3500	# we must not ever block the main coroutine	3687	# we must not ever block the main coroutine
3501	local $Coro::idle = sub {	3688	local $Coro::idle = sub {
…		…
3507	};	3694	};
3508		3695
3509	evthread_start IO::AIO::poll_fileno;	3696	evthread_start IO::AIO::poll_fileno;
3510		3697
3511	cf::sync_job {	3698	cf::sync_job {
		3699	cf::incloader::init ();
		3700
		3701	cf::init_anim;
		3702	cf::init_attackmess;
		3703	cf::init_dynamic;
		3704
		3705	cf::load_settings;
		3706
3512	reload_resources;	3707	reload_resources;
3513	reload_config;	3708	reload_config;
3514	db_init;	3709	db_init;
3515		3710
3516	cf::load_settings;
3517	cf::load_materials;
3518	cf::init_uuid;	3711	cf::init_uuid;
3519	cf::init_signals;	3712	cf::init_signals;
3520	cf::init_commands;
3521	cf::init_skills;	3713	cf::init_skills;
3522		3714
3523	cf::init_beforeplay;	3715	cf::init_beforeplay;
3524		3716
3525	atomic;	3717	atomic;
…		…
3530		3722
3531	# no (long-running) fork's whatsoever before this point(!)	3723	# no (long-running) fork's whatsoever before this point(!)
3532	use POSIX ();	3724	use POSIX ();
3533	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};	3725	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3534		3726
3535	(pop @POST_INIT)->(0) while @POST_INIT;	3727	cf::_post_init 0;
3536	};	3728	};
3537		3729
		3730	cf::object::thawer::errors_are_fatal 0;
		3731	info "parse errors in files are no longer fatal from this point on.\n";
		3732
		3733	my $free_main; $free_main = EV::idle sub {
		3734	undef $free_main;
		3735	undef &main; # free gobs of memory :)
		3736	};
		3737
3538	main_loop;	3738	goto &main_loop;
3539	}	3739	}
3540		3740
3541	#############################################################################	3741	#############################################################################
3542	# initialisation and cleanup	3742	# initialisation and cleanup
3543		3743
3544	# install some emergency cleanup handlers	3744	# install some emergency cleanup handlers
3545	BEGIN {	3745	BEGIN {
3546	our %SIGWATCHER = ();	3746	our %SIGWATCHER = ();
3547	for my $signal (qw(INT HUP TERM)) {	3747	for my $signal (qw(INT HUP TERM)) {
3548	$SIGWATCHER{$signal} = EV::signal $signal, sub {	3748	$SIGWATCHER{$signal} = AE::signal $signal, sub {
3549	cf::cleanup "SIG$signal";	3749	cf::cleanup "SIG$signal";
3550	};	3750	};
3551	}	3751	}
3552	}	3752	}
3553		3753
3554	sub write_runtime_sync {	3754	sub write_runtime_sync {
		3755	my $t0 = AE::time;
		3756
3555	# first touch the runtime file to show we are still running:	3757	# first touch the runtime file to show we are still running:
3556	# the fsync below can take a very very long time.	3758	# the fsync below can take a very very long time.
3557		3759
3558	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;	3760	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3559		3761
3560	my $guard = cf::lock_acquire "write_runtime";	3762	my $guard = cf::lock_acquire "write_runtime";
3561		3763
3562	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644	3764	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3563	or return;	3765	or return;
3564		3766
3565	my $value = $cf::RUNTIME + 90 + 10;	3767	my $value = $cf::RUNTIME + 90 + 10;
3566	# 10 is the runtime save interval, for a monotonic clock	3768	# 10 is the runtime save interval, for a monotonic clock
3567	# 60 allows for the watchdog to kill the server.	3769	# 60 allows for the watchdog to kill the server.
…		…
3580	or return;	3782	or return;
3581		3783
3582	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE	3784	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3583	and return;	3785	and return;
3584		3786
3585	warn "runtime file written.\n";	3787	trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3586		3788
3587	1	3789	1
3588	}	3790	}
3589		3791
3590	our $uuid_lock;	3792	our $uuid_lock;
…		…
3602	or return;	3804	or return;
3603		3805
3604	my $value = uuid_seq uuid_cur;	3806	my $value = uuid_seq uuid_cur;
3605		3807
3606	unless ($value) {	3808	unless ($value) {
3607	warn "cowardly refusing to write zero uuid value!\n";	3809	info "cowardly refusing to write zero uuid value!\n";
3608	return;	3810	return;
3609	}	3811	}
3610		3812
3611	my $value = uuid_str $value + $uuid_skip;	3813	my $value = uuid_str $value + $uuid_skip;
3612	$uuid_skip = 0;	3814	$uuid_skip = 0;
…		…
3622	or return;	3824	or return;
3623		3825
3624	aio_rename "$uuid~", $uuid	3826	aio_rename "$uuid~", $uuid
3625	and return;	3827	and return;
3626		3828
3627	warn "uuid file written ($value).\n";	3829	trace "uuid file written ($value).\n";
3628		3830
3629	1	3831	1
3630		3832
3631	}	3833	}
3632		3834
…		…
3638	}	3840	}
3639		3841
3640	sub emergency_save() {	3842	sub emergency_save() {
3641	my $freeze_guard = cf::freeze_mainloop;	3843	my $freeze_guard = cf::freeze_mainloop;
3642		3844
3643	warn "emergency_perl_save: enter\n";	3845	info "emergency_perl_save: enter\n";
		3846
		3847	# this is a trade-off: we want to be very quick here, so
		3848	# save all maps without fsync, and later call a global sync
		3849	# (which in turn might be very very slow)
		3850	local $USE_FSYNC = 0;
3644		3851
3645	cf::sync_job {	3852	cf::sync_job {
3646	# this is a trade-off: we want to be very quick here, so	3853	cf::write_runtime_sync; # external watchdog should not bark
3647	# save all maps without fsync, and later call a global sync
3648	# (which in turn might be very very slow)
3649	local $USE_FSYNC = 0;
3650		3854
3651	# use a peculiar iteration method to avoid tripping on perl	3855	# use a peculiar iteration method to avoid tripping on perl
3652	# refcount bugs in for. also avoids problems with players	3856	# refcount bugs in for. also avoids problems with players
3653	# and maps saved/destroyed asynchronously.	3857	# and maps saved/destroyed asynchronously.
3654	warn "emergency_perl_save: begin player save\n";	3858	info "emergency_perl_save: begin player save\n";
3655	for my $login (keys %cf::PLAYER) {	3859	for my $login (keys %cf::PLAYER) {
3656	my $pl = $cf::PLAYER{$login} or next;	3860	my $pl = $cf::PLAYER{$login} or next;
3657	$pl->valid or next;	3861	$pl->valid or next;
3658	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt	3862	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3659	$pl->save;	3863	$pl->save;
3660	}	3864	}
3661	warn "emergency_perl_save: end player save\n";	3865	info "emergency_perl_save: end player save\n";
3662		3866
		3867	cf::write_runtime_sync; # external watchdog should not bark
		3868
3663	warn "emergency_perl_save: begin map save\n";	3869	info "emergency_perl_save: begin map save\n";
3664	for my $path (keys %cf::MAP) {	3870	for my $path (keys %cf::MAP) {
3665	my $map = $cf::MAP{$path} or next;	3871	my $map = $cf::MAP{$path} or next;
3666	$map->valid or next;	3872	$map->valid or next;
3667	$map->save;	3873	$map->save;
3668	}	3874	}
3669	warn "emergency_perl_save: end map save\n";	3875	info "emergency_perl_save: end map save\n";
3670		3876
		3877	cf::write_runtime_sync; # external watchdog should not bark
		3878
3671	warn "emergency_perl_save: begin database checkpoint\n";	3879	info "emergency_perl_save: begin database checkpoint\n";
3672	BDB::db_env_txn_checkpoint $DB_ENV;	3880	BDB::db_env_txn_checkpoint $DB_ENV;
3673	warn "emergency_perl_save: end database checkpoint\n";	3881	info "emergency_perl_save: end database checkpoint\n";
3674		3882
3675	warn "emergency_perl_save: begin write uuid\n";	3883	info "emergency_perl_save: begin write uuid\n";
3676	write_uuid_sync 1;	3884	write_uuid_sync 1;
3677	warn "emergency_perl_save: end write uuid\n";	3885	info "emergency_perl_save: end write uuid\n";
		3886
		3887	cf::write_runtime_sync; # external watchdog should not bark
		3888
		3889	trace "emergency_perl_save: syncing database to disk";
		3890	BDB::db_env_txn_checkpoint $DB_ENV;
		3891
		3892	info "emergency_perl_save: starting sync\n";
		3893	IO::AIO::aio_sync sub {
		3894	info "emergency_perl_save: finished sync\n";
		3895	};
		3896
		3897	cf::write_runtime_sync; # external watchdog should not bark
		3898
		3899	trace "emergency_perl_save: flushing outstanding aio requests";
		3900	while (IO::AIO::nreqs || BDB::nreqs) {
		3901	Coro::EV::timer_once 0.01; # let the sync_job do it's thing
		3902	}
		3903
		3904	cf::write_runtime_sync; # external watchdog should not bark
3678	};	3905	};
3679		3906
3680	warn "emergency_perl_save: starting sync()\n";
3681	IO::AIO::aio_sync sub {
3682	warn "emergency_perl_save: finished sync()\n";
3683	};
3684
3685	warn "emergency_perl_save: leave\n";	3907	info "emergency_perl_save: leave\n";
3686	}	3908	}
3687		3909
3688	sub post_cleanup {	3910	sub post_cleanup {
3689	my ($make_core) = @_;	3911	my ($make_core) = @_;
3690		3912
		3913	IO::AIO::flush;
		3914
3691	warn Carp::longmess "post_cleanup backtrace"	3915	error Carp::longmess "post_cleanup backtrace"
3692	if $make_core;	3916	if $make_core;
3693		3917
3694	my $fh = pidfile;	3918	my $fh = pidfile;
3695	unlink $PIDFILE if <$fh> == $$;	3919	unlink $PIDFILE if <$fh> == $$;
3696	}	3920	}
…		…
3716	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};	3940	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3717	for my $name (keys %$leaf_symtab) {	3941	for my $name (keys %$leaf_symtab) {
3718	_gv_clear *{"$pkg$name"};	3942	_gv_clear *{"$pkg$name"};
3719	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};	3943	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3720	}	3944	}
3721	warn "cleared package $pkg\n";#d#
3722	}	3945	}
3723		3946
3724	sub do_reload_perl() {	3947	sub do_reload_perl() {
3725	# can/must only be called in main	3948	# can/must only be called in main
3726	if ($Coro::current != $Coro::main) {	3949	unless (in_main) {
3727	warn "can only reload from main coroutine";	3950	error "can only reload from main coroutine";
3728	return;	3951	return;
3729	}	3952	}
3730		3953
3731	return if $RELOAD++;	3954	return if $RELOAD++;
3732		3955
3733	my $t1 = EV::time;	3956	my $t1 = AE::time;
3734		3957
3735	while ($RELOAD) {	3958	while ($RELOAD) {
3736	warn "reloading...";	3959	cf::get_slot 0.1, -1, "reload_perl";
		3960	info "perl_reload: reloading...";
3737		3961
3738	warn "entering sync_job";	3962	trace "perl_reload: entering sync_job";
3739		3963
3740	cf::sync_job {	3964	cf::sync_job {
3741	cf::write_runtime_sync; # external watchdog should not bark
3742	cf::emergency_save;	3965	#cf::emergency_save;
3743	cf::write_runtime_sync; # external watchdog should not bark
3744		3966
3745	warn "syncing database to disk";
3746	BDB::db_env_txn_checkpoint $DB_ENV;
3747
3748	# if anything goes wrong in here, we should simply crash as we already saved
3749
3750	warn "flushing outstanding aio requests";
3751	while (IO::AIO::nreqs || BDB::nreqs) {
3752	Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3753	}
3754
3755	warn "cancelling all extension coros";	3967	trace "perl_reload: cancelling all extension coros";
3756	$_->cancel for values %EXT_CORO;	3968	$_->cancel for values %EXT_CORO;
3757	%EXT_CORO = ();	3969	%EXT_CORO = ();
3758		3970
3759	warn "removing commands";	3971	trace "perl_reload: removing commands";
3760	%COMMAND = ();	3972	%COMMAND = ();
3761		3973
3762	warn "removing ext/exti commands";	3974	trace "perl_reload: removing ext/exti commands";
3763	%EXTCMD = ();	3975	%EXTCMD = ();
3764	%EXTICMD = ();	3976	%EXTICMD = ();
3765		3977
3766	warn "unloading/nuking all extensions";	3978	trace "perl_reload: unloading/nuking all extensions";
3767	for my $pkg (@EXTS) {	3979	for my $pkg (@EXTS) {
3768	warn "... unloading $pkg";	3980	trace "... unloading $pkg";
3769		3981
3770	if (my $cb = $pkg->can ("unload")) {	3982	if (my $cb = $pkg->can ("unload")) {
3771	eval {	3983	eval {
3772	$cb->($pkg);	3984	$cb->($pkg);
3773	1	3985	1
3774	} or warn "$pkg unloaded, but with errors: $@";	3986	} or error "$pkg unloaded, but with errors: $@";
3775	}	3987	}
3776		3988
3777	warn "... clearing $pkg";	3989	trace "... clearing $pkg";
3778	clear_package $pkg;	3990	clear_package $pkg;
3779	}	3991	}
3780		3992
3781	warn "unloading all perl modules loaded from $LIBDIR";	3993	trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3782	while (my ($k, $v) = each %INC) {	3994	while (my ($k, $v) = each %INC) {
3783	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;	3995	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3784		3996
3785	warn "... unloading $k";	3997	trace "... unloading $k";
3786	delete $INC{$k};	3998	delete $INC{$k};
3787		3999
3788	$k =~ s/\.pm$//;	4000	$k =~ s/\.pm$//;
3789	$k =~ s/\//::/g;	4001	$k =~ s/\//::/g;
3790		4002
…		…
3793	}	4005	}
3794		4006
3795	clear_package $k;	4007	clear_package $k;
3796	}	4008	}
3797		4009
3798	warn "getting rid of safe::, as good as possible";	4010	trace "perl_reload: getting rid of safe::, as good as possible";
3799	clear_package "safe::$_"	4011	clear_package "safe::$_"
3800	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	4012	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3801		4013
3802	warn "unloading cf.pm \"a bit\"";	4014	trace "perl_reload: unloading cf.pm \"a bit\"";
3803	delete $INC{"cf.pm"};	4015	delete $INC{"cf.pm"};
3804	delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;	4016	delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3805		4017
3806	# don't, removes xs symbols, too,	4018	# don't, removes xs symbols, too,
3807	# and global variables created in xs	4019	# and global variables created in xs
3808	#clear_package __PACKAGE__;	4020	#clear_package __PACKAGE__;
3809		4021
3810	warn "unload completed, starting to reload now";	4022	info "perl_reload: unload completed, starting to reload now";
3811		4023
3812	warn "reloading cf.pm";	4024	trace "perl_reload: reloading cf.pm";
3813	require cf;	4025	require cf;
3814	cf::_connect_to_perl_1;	4026	cf::_connect_to_perl_1;
3815		4027
3816	warn "loading config and database again";	4028	trace "perl_reload: loading config and database again";
3817	cf::reload_config;	4029	cf::reload_config;
3818		4030
3819	warn "loading extensions";	4031	trace "perl_reload: loading extensions";
3820	cf::load_extensions;	4032	cf::load_extensions;
3821		4033
3822	if ($REATTACH_ON_RELOAD) {	4034	if ($REATTACH_ON_RELOAD) {
3823	warn "reattaching attachments to objects/players";	4035	trace "perl_reload: reattaching attachments to objects/players";
3824	_global_reattach; # objects, sockets	4036	_global_reattach; # objects, sockets
3825	warn "reattaching attachments to maps";	4037	trace "perl_reload: reattaching attachments to maps";
3826	reattach $_ for values %MAP;	4038	reattach $_ for values %MAP;
3827	warn "reattaching attachments to players";	4039	trace "perl_reload: reattaching attachments to players";
3828	reattach $_ for values %PLAYER;	4040	reattach $_ for values %PLAYER;
3829	}	4041	}
3830		4042
3831	warn "running post_init jobs";	4043	cf::_post_init 1;
3832	(pop @POST_INIT)->(1) while @POST_INIT;
3833		4044
3834	warn "leaving sync_job";	4045	trace "perl_reload: leaving sync_job";
3835		4046
3836	1	4047	1
3837	} or do {	4048	} or do {
3838	warn $@;	4049	error $@;
3839	cf::cleanup "error while reloading, exiting.";	4050	cf::cleanup "perl_reload: error, exiting.";
3840	};	4051	};
3841		4052
3842	warn "reloaded";
3843	--$RELOAD;	4053	--$RELOAD;
3844	}	4054	}
3845		4055
3846	$t1 = EV::time - $t1;	4056	$t1 = AE::time - $t1;
3847	warn "reload completed in ${t1}s\n";	4057	info "perl_reload: completed in ${t1}s\n";
3848	};	4058	};
3849		4059
3850	our $RELOAD_WATCHER; # used only during reload	4060	our $RELOAD_WATCHER; # used only during reload
3851		4061
3852	sub reload_perl() {	4062	sub reload_perl() {
…		…
3854	# coro crashes during coro_state_free->destroy here.	4064	# coro crashes during coro_state_free->destroy here.
3855		4065
3856	$RELOAD_WATCHER ||= cf::async {	4066	$RELOAD_WATCHER ||= cf::async {
3857	Coro::AIO::aio_wait cache_extensions;	4067	Coro::AIO::aio_wait cache_extensions;
3858		4068
3859	$RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {	4069	$RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3860	do_reload_perl;	4070	do_reload_perl;
3861	undef $RELOAD_WATCHER;	4071	undef $RELOAD_WATCHER;
3862	};	4072	};
3863	};	4073	};
3864	}	4074	}
…		…
3873	reload_perl;	4083	reload_perl;
3874	};	4084	};
3875	}	4085	}
3876	};	4086	};
3877		4087
3878	unshift @INC, $LIBDIR;	4088	#############################################################################
3879		4089
3880	my $bug_warning = 0;	4090	my $bug_warning = 0;
3881		4091
3882	our @WAIT_FOR_TICK;
3883	our @WAIT_FOR_TICK_BEGIN;
3884
3885	sub wait_for_tick {	4092	sub wait_for_tick() {
3886	return if tick_inhibit || $Coro::current == $Coro::main;	4093	return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3887		4094
3888	my $signal = new Coro::Signal;	4095	$WAIT_FOR_TICK->wait;
3889	push @WAIT_FOR_TICK, $signal;
3890	$signal->wait;
3891	}	4096	}
3892		4097
3893	sub wait_for_tick_begin {	4098	sub wait_for_tick_begin() {
3894	return if tick_inhibit || $Coro::current == $Coro::main;	4099	return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
3895		4100
3896	my $signal = new Coro::Signal;	4101	my $signal = new Coro::Signal;
3897	push @WAIT_FOR_TICK_BEGIN, $signal;	4102	push @WAIT_FOR_TICK_BEGIN, $signal;
3898	$signal->wait;	4103	$signal->wait;
3899	}	4104	}
…		…
3903	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"	4108	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3904	unless ++$bug_warning > 10;	4109	unless ++$bug_warning > 10;
3905	return;	4110	return;
3906	}	4111	}
3907		4112
3908	cf::server_tick; # one server iteration	4113	cf::one_tick; # one server iteration
		4114
		4115	#for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3909		4116
3910	if ($NOW >= $NEXT_RUNTIME_WRITE) {	4117	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3911	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;	4118	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3912	Coro::async_pool {	4119	Coro::async_pool {
3913	$Coro::current->{desc} = "runtime saver";	4120	$Coro::current->{desc} = "runtime saver";
3914	write_runtime_sync	4121	write_runtime_sync
3915	or warn "ERROR: unable to write runtime file: $!";	4122	or error "ERROR: unable to write runtime file: $!";
3916	};	4123	};
3917	}	4124	}
3918		4125
3919	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	4126	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3920	$sig->send;	4127	$sig->send;
3921	}	4128	}
3922	while (my $sig = shift @WAIT_FOR_TICK) {	4129	$WAIT_FOR_TICK->broadcast;
3923	$sig->send;
3924	}
3925		4130
3926	$LOAD = ($NOW - $TICK_START) / $TICK;	4131	$LOAD = ($NOW - $TICK_START) / $TICK;
3927	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	4132	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3928		4133
3929	if (0) {	4134	if (0) {
3930	if ($NEXT_TICK) {	4135	if ($NEXT_TICK) {
3931	my $jitter = $TICK_START - $NEXT_TICK;	4136	my $jitter = $TICK_START - $NEXT_TICK;
3932	$JITTER = $JITTER * 0.75 + $jitter * 0.25;	4137	$JITTER = $JITTER * 0.75 + $jitter * 0.25;
3933	warn "jitter $JITTER\n";#d#	4138	debug "jitter $JITTER\n";#d#
3934	}	4139	}
3935	}	4140	}
3936	}	4141	}
3937		4142
3938	{	4143	{
3939	# configure BDB	4144	# configure BDB
3940		4145
3941	BDB::min_parallel 8;	4146	BDB::min_parallel 16;
3942	BDB::max_poll_reqs $TICK * 0.1;	4147	BDB::max_poll_reqs $TICK * 0.1;
3943	$AnyEvent::BDB::WATCHER->priority (1);	4148	$AnyEvent::BDB::WATCHER->priority (1);
3944		4149
3945	unless ($DB_ENV) {	4150	unless ($DB_ENV) {
3946	$DB_ENV = BDB::db_env_create;	4151	$DB_ENV = BDB::db_env_create;
…		…
3983	IO::AIO::min_parallel 8;	4188	IO::AIO::min_parallel 8;
3984	IO::AIO::max_poll_time $TICK * 0.1;	4189	IO::AIO::max_poll_time $TICK * 0.1;
3985	undef $AnyEvent::AIO::WATCHER;	4190	undef $AnyEvent::AIO::WATCHER;
3986	}	4191	}
3987		4192
3988	my $_log_backtrace;	4193	our $_log_backtrace;
		4194	our $_log_backtrace_last;
3989		4195
3990	sub _log_backtrace {	4196	sub _log_backtrace {
3991	my ($msg, @addr) = @_;	4197	my ($msg, @addr) = @_;
3992		4198
3993	$msg =~ s/\n//;	4199	$msg =~ s/\n$//;
3994		4200
		4201	if ($_log_backtrace_last eq $msg) {
		4202	LOG llevInfo, "[ABT] $msg\n";
		4203	LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
3995	# limit the # of concurrent backtraces	4204	# limit the # of concurrent backtraces
3996	if ($_log_backtrace < 2) {	4205	} elsif ($_log_backtrace < 2) {
		4206	$_log_backtrace_last = $msg;
3997	++$_log_backtrace;	4207	++$_log_backtrace;
3998	my $perl_bt = Carp::longmess $msg;	4208	my $perl_bt = Carp::longmess $msg;
3999	async {	4209	async {
4000	$Coro::current->{desc} = "abt $msg";	4210	$Coro::current->{desc} = "abt $msg";
4001		4211
…		…
4021	LOG llevInfo, "[ABT] $_\n" for @bt;	4231	LOG llevInfo, "[ABT] $_\n" for @bt;
4022	--$_log_backtrace;	4232	--$_log_backtrace;
4023	};	4233	};
4024	} else {	4234	} else {
4025	LOG llevInfo, "[ABT] $msg\n";	4235	LOG llevInfo, "[ABT] $msg\n";
4026	LOG llevInfo, "[ABT] [suppressed]\n";	4236	LOG llevInfo, "[ABT] [overload, suppressed]\n";
4027	}	4237	}
4028	}	4238	}
4029		4239
4030	# load additional modules	4240	# load additional modules
4031	require "cf/$_.pm" for @EXTRA_MODULES;	4241	require "cf/$_.pm" for @EXTRA_MODULES;

Diff Legend

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