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.502 by root, Sat Jan 23 20:24:50 2010 UTC vs.
Revision 1.550 by root, Fri May 14 22:56:47 2010 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 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;
…		…
78	# strictly for debugging	76	# strictly for debugging
79	$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };	77	$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
80		78
81	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	79	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
82		80
		81	our @ORIG_INC;
		82
83	our %COMMAND = ();	83	our %COMMAND = ();
84	our %COMMAND_TIME = ();	84	our %COMMAND_TIME = ();
85		85
86	our @EXTS = (); # list of extension package names	86	our @EXTS = (); # list of extension package names
87	our %EXTCMD = ();	87	our %EXTCMD = ();
…		…
106	our $RANDOMDIR = "$LOCALDIR/random";	106	our $RANDOMDIR = "$LOCALDIR/random";
107	our $BDBDIR = "$LOCALDIR/db";	107	our $BDBDIR = "$LOCALDIR/db";
108	our $PIDFILE = "$LOCALDIR/pid";	108	our $PIDFILE = "$LOCALDIR/pid";
109	our $RUNTIMEFILE = "$LOCALDIR/runtime";	109	our $RUNTIMEFILE = "$LOCALDIR/runtime";
110		110
111	our %RESOURCE;	111	our %RESOURCE; # unused
		112
		113	our $OUTPUT_RATE_MIN = 3000;
		114	our $OUTPUT_RATE_MAX = 1000000;
		115
		116	our $MAX_LINKS = 32; # how many chained exits to follow
		117	our $VERBOSE_IO = 1;
112		118
113	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	119	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
114	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	120	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
115	our $NEXT_TICK;	121	our $NEXT_TICK;
116	our $USE_FSYNC = 1; # use fsync to write maps - default on	122	our $USE_FSYNC = 1; # use fsync to write maps - default on
…		…
118	our $BDB_DEADLOCK_WATCHER;	124	our $BDB_DEADLOCK_WATCHER;
119	our $BDB_CHECKPOINT_WATCHER;	125	our $BDB_CHECKPOINT_WATCHER;
120	our $BDB_TRICKLE_WATCHER;	126	our $BDB_TRICKLE_WATCHER;
121	our $DB_ENV;	127	our $DB_ENV;
122		128
123	our @EXTRA_MODULES = qw(pod match mapscript);	129	our @EXTRA_MODULES = qw(pod match mapscript incloader);
124		130
125	our %CFG;	131	our %CFG;
126		132
127	our $UPTIME; $UPTIME ||= time;	133	our $UPTIME; $UPTIME ||= time;
128	our $RUNTIME;	134	our $RUNTIME;
…		…
162		168
163	our $EMERGENCY_POSITION;	169	our $EMERGENCY_POSITION;
164		170
165	sub cf::map::normalise;	171	sub cf::map::normalise;
166		172
		173	sub in_main() {
		174	$Coro::current == $Coro::main
		175	}
		176
167	#############################################################################	177	#############################################################################
168		178
169	%REFLECT = ();	179	%REFLECT = ();
170	for (@REFLECT) {	180	for (@REFLECT) {
171	my $reflect = JSON::XS::decode_json $_;	181	my $reflect = JSON::XS::decode_json $_;
…		…
223	from wherever your confdir points to.	233	from wherever your confdir points to.
224		234
225	=item cf::wait_for_tick, cf::wait_for_tick_begin	235	=item cf::wait_for_tick, cf::wait_for_tick_begin
226		236
227	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	237	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
228	returns directly I<after> the tick processing (and consequently, can only wake one process	238	returns directly I<after> the tick processing (and consequently, can only wake one thread
229	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	239	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
		240
		241	=cut
		242
		243	sub wait_for_tick();
		244	sub wait_for_tick_begin();
230		245
231	=item @cf::INVOKE_RESULTS	246	=item @cf::INVOKE_RESULTS
232		247
233	This array contains the results of the last C<invoke ()> call. When	248	This array contains the results of the last C<invoke ()> call. When
234	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of	249	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
…		…
242		257
243	=back	258	=back
244		259
245	=cut	260	=cut
246		261
		262	sub error(@) { LOG llevError, join "", @_ }
		263	sub warn (@) { LOG llevWarn , join "", @_ }
		264	sub info (@) { LOG llevInfo , join "", @_ }
		265	sub debug(@) { LOG llevDebug, join "", @_ }
		266	sub trace(@) { LOG llevTrace, join "", @_ }
		267
247	$Coro::State::WARNHOOK = sub {	268	$Coro::State::WARNHOOK = sub {
248	my $msg = join "", @_;	269	my $msg = join "", @_;
249		270
250	$msg .= "\n"	271	$msg .= "\n"
251	unless $msg =~ /\n$/;	272	unless $msg =~ /\n$/;
252		273
253	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;	274	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
254		275
255	LOG llevError, $msg;	276	LOG llevWarn, $msg;
256	};	277	};
257		278
258	$Coro::State::DIEHOOK = sub {	279	$Coro::State::DIEHOOK = sub {
259	return unless $^S eq 0; # "eq", not "=="	280	return unless $^S eq 0; # "eq", not "=="
260		281
261	warn Carp::longmess $_[0];	282	error Carp::longmess $_[0];
262		283
263	if ($Coro::current == $Coro::main) {#d#	284	if (in_main) {#d#
264	warn "DIEHOOK called in main context, Coro bug?\n";#d#	285	error "DIEHOOK called in main context, Coro bug?\n";#d#
265	return;#d#	286	return;#d#
266	}#d#	287	}#d#
267		288
268	# kill coroutine otherwise	289	# kill coroutine otherwise
269	Coro::terminate	290	Coro::terminate
…		…
336	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max	357	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
337		358
338	sub encode_json($) { $json_coder->encode ($_[0]) }	359	sub encode_json($) { $json_coder->encode ($_[0]) }
339	sub decode_json($) { $json_coder->decode ($_[0]) }	360	sub decode_json($) { $json_coder->decode ($_[0]) }
340		361
		362	=item $ref = cf::yaml_load $scalar
		363
		364	Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
		365
		366	=cut
		367
		368	sub fork_call(&@);
		369
		370	sub yaml_load($) {
		371	fork_call { YAML::XS::Load $_[0] } @_
		372	}
		373
341	=item cf::post_init { BLOCK }	374	=item cf::post_init { BLOCK }
342		375
343	Execute the given codeblock, I<after> all extensions have been (re-)loaded,	376	Execute the given codeblock, I<after> all extensions have been (re-)loaded,
344	but I<before> the server starts ticking again.	377	but I<before> the server starts ticking again.
345		378
346	The cdoeblock will have a single boolean argument to indicate whether this	379	The codeblock will have a single boolean argument to indicate whether this
347	is a reload or not.	380	is a reload or not.
348		381
349	=cut	382	=cut
350		383
351	sub post_init(&) {	384	sub post_init(&) {
352	push @POST_INIT, shift;	385	push @POST_INIT, shift;
		386	}
		387
		388	sub _post_init {
		389	trace "running post_init jobs";
		390
		391	# run them in parallel...
		392
		393	my @join;
		394
		395	while () {
		396	push @join, map &Coro::async ($_, 0), @POST_INIT;
		397	@POST_INIT = ();
		398
		399	@join or last;
		400
		401	(pop @join)->join;
		402	}
353	}	403	}
354		404
355	=item cf::lock_wait $string	405	=item cf::lock_wait $string
356		406
357	Wait until the given lock is available. See cf::lock_acquire.	407	Wait until the given lock is available. See cf::lock_acquire.
…		…
396	}	446	}
397		447
398	=item cf::periodic $interval, $cb	448	=item cf::periodic $interval, $cb
399		449
400	Like EV::periodic, but randomly selects a starting point so that the actions	450	Like EV::periodic, but randomly selects a starting point so that the actions
401	get spread over timer.	451	get spread over time.
402		452
403	=cut	453	=cut
404		454
405	sub periodic($$) {	455	sub periodic($$) {
406	my ($interval, $cb) = @_;	456	my ($interval, $cb) = @_;
…		…
502	=cut	552	=cut
503		553
504	sub sync_job(&) {	554	sub sync_job(&) {
505	my ($job) = @_;	555	my ($job) = @_;
506		556
507	if ($Coro::current == $Coro::main) {	557	if (in_main) {
508	my $time = EV::time;	558	my $time = AE::time;
509		559
510	# this is the main coro, too bad, we have to block	560	# this is the main coro, too bad, we have to block
511	# till the operation succeeds, freezing the server :/	561	# till the operation succeeds, freezing the server :/
512		562
513	LOG llevError, Carp::longmess "sync job";#d#	563	#LOG llevError, Carp::longmess "sync job";#d#
514		564
515	my $freeze_guard = freeze_mainloop;	565	my $freeze_guard = freeze_mainloop;
516		566
517	my $busy = 1;	567	my $busy = 1;
518	my @res;	568	my @res;
519		569
520	(async {	570	(async {
521	$Coro::current->desc ("sync job coro");	571	$Coro::current->desc ("sync job coro");
522	@res = eval { $job->() };	572	@res = eval { $job->() };
523	warn $@ if $@;	573	error $@ if $@;
524	undef $busy;	574	undef $busy;
525	})->prio (Coro::PRIO_MAX);	575	})->prio (Coro::PRIO_MAX);
526		576
527	while ($busy) {	577	while ($busy) {
528	if (Coro::nready) {	578	if (Coro::nready) {
…		…
530	} else {	580	} else {
531	EV::loop EV::LOOP_ONESHOT;	581	EV::loop EV::LOOP_ONESHOT;
532	}	582	}
533	}	583	}
534		584
535	my $time = EV::time - $time;	585	my $time = AE::time - $time;
536		586
537	$TICK_START += $time; # do not account sync jobs to server load	587	$TICK_START += $time; # do not account sync jobs to server load
538		588
539	wantarray ? @res : $res[0]	589	wantarray ? @res : $res[0]
540	} else {	590	} else {
…		…
562	$EXT_CORO{$coro+0} = $coro;	612	$EXT_CORO{$coro+0} = $coro;
563		613
564	$coro	614	$coro
565	}	615	}
566		616
567	=item fork_call { }, $args	617	=item fork_call { }, @args
568		618
569	Executes the given code block with the given arguments in a seperate	619	Executes the given code block with the given arguments in a seperate
570	process, returning the results. Everything must be serialisable with	620	process, returning the results. Everything must be serialisable with
571	Coro::Storable. May, of course, block. Note that the executed sub may	621	Coro::Storable. May, of course, block. Note that the executed sub may
572	never block itself or use any form of event handling.	622	never block itself or use any form of event handling.
573		623
574	=cut	624	=cut
575		625
		626	sub post_fork {
		627	reset_signals;
		628	}
		629
576	sub fork_call(&@) {	630	sub fork_call(&@) {
577	my ($cb, @args) = @_;	631	my ($cb, @args) = @_;
578		632
579	# we seemingly have to make a local copy of the whole thing,	633	# we seemingly have to make a local copy of the whole thing,
580	# otherwise perl prematurely frees the stuff :/	634	# otherwise perl prematurely frees the stuff :/
581	# TODO: investigate and fix (likely this will be rather laborious)	635	# TODO: investigate and fix (likely this will be rather laborious)
582		636
583	my @res = Coro::Util::fork_eval {	637	my @res = Coro::Util::fork_eval {
584	reset_signals;	638	cf::post_fork;
585	&$cb	639	&$cb
586	}, @args;	640	} @args;
587		641
588	wantarray ? @res : $res[-1]	642	wantarray ? @res : $res[-1]
		643	}
		644
		645	sub objinfo {
		646	(
		647	"counter value" => cf::object::object_count,
		648	"objects created" => cf::object::create_count,
		649	"objects destroyed" => cf::object::destroy_count,
		650	"freelist size" => cf::object::free_count,
		651	"allocated objects" => cf::object::objects_size,
		652	"active objects" => cf::object::actives_size,
		653	)
589	}	654	}
590		655
591	=item $coin = coin_from_name $name	656	=item $coin = coin_from_name $name
592		657
593	=cut	658	=cut
…		…
630	within each server.	695	within each server.
631		696
632	=cut	697	=cut
633		698
634	sub db_table($) {	699	sub db_table($) {
		700	cf::error "db_get called from main context"
		701	if $Coro::current == $Coro::main;
		702
635	my ($name) = @_;	703	my ($name) = @_;
636	my $db = BDB::db_create $DB_ENV;	704	my $db = BDB::db_create $DB_ENV;
637		705
638	eval {	706	eval {
639	$db->set_flags (BDB::CHKSUM);	707	$db->set_flags (BDB::CHKSUM);
…		…
649	}	717	}
650		718
651	our $DB;	719	our $DB;
652		720
653	sub db_init {	721	sub db_init {
654	cf::sync_job {
655	$DB ||= db_table "db";	722	$DB ||= db_table "db";
656	};
657	}	723	}
658		724
659	sub db_get($$) {	725	sub db_get($$) {
660	my $key = "$_[0]/$_[1]";	726	my $key = "$_[0]/$_[1]";
661		727
662	cf::sync_job {	728	cf::error "db_get called from main context"
		729	if $Coro::current == $Coro::main;
		730
663	BDB::db_get $DB, undef, $key, my $data;	731	BDB::db_get $DB, undef, $key, my $data;
664		732
665	$! ? ()	733	$! ? ()
666	: $data	734	: $data
667	}
668	}	735	}
669		736
670	sub db_put($$$) {	737	sub db_put($$$) {
671	BDB::dbreq_pri 4;	738	BDB::dbreq_pri 4;
672	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };	739	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
…		…
728		795
729	my $t1 = Time::HiRes::time;	796	my $t1 = Time::HiRes::time;
730	my $data = $process->(\@data);	797	my $data = $process->(\@data);
731	my $t2 = Time::HiRes::time;	798	my $t2 = Time::HiRes::time;
732		799
733	warn "cache: '$id' processed in ", $t2 - $t1, "s\n";	800	info "cache: '$id' processed in ", $t2 - $t1, "s\n";
734		801
735	db_put cache => "$id/data", $data;	802	db_put cache => "$id/data", $data;
736	db_put cache => "$id/md5" , $md5;	803	db_put cache => "$id/md5" , $md5;
737	db_put cache => "$id/meta", $meta;	804	db_put cache => "$id/meta", $meta;
738		805
…		…
748		815
749	=cut	816	=cut
750		817
751	sub datalog($@) {	818	sub datalog($@) {
752	my ($type, %kv) = @_;	819	my ($type, %kv) = @_;
753	warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });	820	info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
754	}	821	}
755		822
756	=back	823	=back
757		824
758	=cut	825	=cut
…		…
953		1020
954	} elsif (exists $cb_id{$type}) {	1021	} elsif (exists $cb_id{$type}) {
955	_attach_cb $registry, $cb_id{$type}, $prio, shift @arg;	1022	_attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
956		1023
957	} elsif (ref $type) {	1024	} elsif (ref $type) {
958	warn "attaching objects not supported, ignoring.\n";	1025	error "attaching objects not supported, ignoring.\n";
959		1026
960	} else {	1027	} else {
961	shift @arg;	1028	shift @arg;
962	warn "attach argument '$type' not supported, ignoring.\n";	1029	error "attach argument '$type' not supported, ignoring.\n";
963	}	1030	}
964	}	1031	}
965	}	1032	}
966		1033
967	sub _object_attach {	1034	sub _object_attach {
…		…
977	_attach $registry, $klass, @attach;	1044	_attach $registry, $klass, @attach;
978	}	1045	}
979		1046
980	$obj->{$name} = \%arg;	1047	$obj->{$name} = \%arg;
981	} else {	1048	} else {
982	warn "object uses attachment '$name' which is not available, postponing.\n";	1049	info "object uses attachment '$name' which is not available, postponing.\n";
983	}	1050	}
984		1051
985	$obj->{_attachment}{$name} = undef;	1052	$obj->{_attachment}{$name} = undef;
986	}	1053	}
987		1054
…		…
1046		1113
1047	for (@$callbacks) {	1114	for (@$callbacks) {
1048	eval { &{$_->[1]} };	1115	eval { &{$_->[1]} };
1049		1116
1050	if ($@) {	1117	if ($@) {
1051	warn "$@";
1052	warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";	1118	error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1053	override;	1119	override;
1054	}	1120	}
1055		1121
1056	return 1 if $override;	1122	return 1 if $override;
1057	}	1123	}
…		…
1136	for (@$attach) {	1202	for (@$attach) {
1137	my ($klass, @attach) = @$_;	1203	my ($klass, @attach) = @$_;
1138	_attach $registry, $klass, @attach;	1204	_attach $registry, $klass, @attach;
1139	}	1205	}
1140	} else {	1206	} else {
1141	warn "object uses attachment '$name' that is not available, postponing.\n";	1207	info "object uses attachment '$name' that is not available, postponing.\n";
1142	}	1208	}
1143	}	1209	}
1144	}	1210	}
1145		1211
1146	cf::attachable->attach (	1212	cf::attachable->attach (
…		…
1173	my ($filename, $rdata, $objs) = @_;	1239	my ($filename, $rdata, $objs) = @_;
1174		1240
1175	sync_job {	1241	sync_job {
1176	if (length $$rdata) {	1242	if (length $$rdata) {
1177	utf8::decode (my $decname = $filename);	1243	utf8::decode (my $decname = $filename);
1178	warn sprintf "saving %s (%d,%d)\n",	1244	trace sprintf "saving %s (%d,%d)\n",
1179	$decname, length $$rdata, scalar @$objs;	1245	$decname, length $$rdata, scalar @$objs
		1246	if $VERBOSE_IO;
1180		1247
1181	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {	1248	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1182	aio_chmod $fh, SAVE_MODE;	1249	aio_chmod $fh, SAVE_MODE;
1183	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1250	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1184	if ($cf::USE_FSYNC) {	1251	if ($cf::USE_FSYNC) {
…		…
1206	aio_rename "$filename~", $filename;	1273	aio_rename "$filename~", $filename;
1207		1274
1208	$filename =~ s%/[^/]+$%%;	1275	$filename =~ s%/[^/]+$%%;
1209	aio_pathsync $filename if $cf::USE_FSYNC;	1276	aio_pathsync $filename if $cf::USE_FSYNC;
1210	} else {	1277	} else {
1211	warn "unable to save objects: $filename~: $!\n";	1278	error "unable to save objects: $filename~: $!\n";
1212	}	1279	}
1213	} else {	1280	} else {
1214	aio_unlink $filename;	1281	aio_unlink $filename;
1215	aio_unlink "$filename.pst";	1282	aio_unlink "$filename.pst";
1216	}	1283	}
…		…
1240	my $st = eval { Coro::Storable::thaw $av };	1307	my $st = eval { Coro::Storable::thaw $av };
1241	$av = $st->{objs};	1308	$av = $st->{objs};
1242	}	1309	}
1243		1310
1244	utf8::decode (my $decname = $filename);	1311	utf8::decode (my $decname = $filename);
1245	warn sprintf "loading %s (%d,%d)\n",	1312	trace sprintf "loading %s (%d,%d)\n",
1246	$decname, length $data, scalar @{$av || []};	1313	$decname, length $data, scalar @{$av || []}
		1314	if $VERBOSE_IO;
1247		1315
1248	($data, $av)	1316	($data, $av)
1249	}	1317	}
1250		1318
1251	=head2 COMMAND CALLBACKS	1319	=head2 COMMAND CALLBACKS
…		…
1310	}	1378	}
1311		1379
1312	use File::Glob ();	1380	use File::Glob ();
1313		1381
1314	cf::player->attach (	1382	cf::player->attach (
1315	on_command => sub {	1383	on_unknown_command => sub {
1316	my ($pl, $name, $params) = @_;	1384	my ($pl, $name, $params) = @_;
1317		1385
1318	my $cb = $COMMAND{$name}	1386	my $cb = $COMMAND{$name}
1319	or return;	1387	or return;
1320		1388
…		…
1343		1411
1344	$pl->ext_reply ($reply, @reply)	1412	$pl->ext_reply ($reply, @reply)
1345	if $reply;	1413	if $reply;
1346		1414
1347	} else {	1415	} else {
1348	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1416	error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1349	}	1417	}
1350		1418
1351	cf::override;	1419	cf::override;
1352	},	1420	},
1353	);	1421	);
…		…
1364		1432
1365	$grp	1433	$grp
1366	}	1434	}
1367		1435
1368	sub load_extensions {	1436	sub load_extensions {
		1437	info "loading extensions...";
		1438
1369	cf::sync_job {	1439	cf::sync_job {
1370	my %todo;	1440	my %todo;
1371		1441
1372	for my $path (<$LIBDIR/*.ext>) {	1442	for my $path (<$LIBDIR/*.ext>) {
1373	next unless -r $path;	1443	next unless -r $path;
…		…
1391		1461
1392	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }	1462	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1393	if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;	1463	if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1394		1464
1395	$ext{source} =	1465	$ext{source} =
1396	"package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"	1466	"package $pkg; use common::sense;\n"
1397	. "#line 1 \"$path\"\n{\n"	1467	. "#line 1 \"$path\"\n{\n"
1398	. $source	1468	. $source
1399	. "\n};\n1";	1469	. "\n};\n1";
1400		1470
1401	$todo{$base} = \%ext;	1471	$todo{$base} = \%ext;
1402	}	1472	}
1403		1473
		1474	my $pass = 0;
1404	my %done;	1475	my %done;
1405	while (%todo) {	1476	while (%todo) {
1406	my $progress;	1477	my $progress;
1407		1478
		1479	++$pass;
		1480
		1481	ext:
1408	while (my ($k, $v) = each %todo) {	1482	while (my ($k, $v) = each %todo) {
1409	for (split /,\s*/, $v->{meta}{depends}) {	1483	for (split /,\s*/, $v->{meta}{depends}) {
1410	goto skip	1484	next ext
1411	unless exists $done{$_};	1485	unless exists $done{$_};
1412	}	1486	}
1413		1487
1414	warn "... loading '$k' into '$v->{pkg}'\n";	1488	trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1415		1489
1416	unless (eval $v->{source}) {	1490	my $active = eval $v->{source};
		1491
		1492	if (length $@) {
1417	my $msg = $@ ? "$v->{path}: $@\n"	1493	error "$v->{path}: $@\n";
1418	: "$v->{base}: extension inactive.\n";
1419		1494
1420	if (exists $v->{meta}{mandatory}) {
1421	warn $msg;
1422	cf::cleanup "mandatory extension failed to load, exiting.";	1495	cf::cleanup "mandatory extension '$k' failed to load, exiting."
1423	}	1496	if exists $v->{meta}{mandatory};
1424		1497
1425	warn $msg;	1498	warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
		1499	delete $todo{$k};
		1500	} else {
		1501	$done{$k} = delete $todo{$k};
		1502	push @EXTS, $v->{pkg};
		1503	$progress = 1;
		1504
		1505	info "$v->{base}: extension inactive.\n"
		1506	unless $active;
1426	}	1507	}
1427
1428	$done{$k} = delete $todo{$k};
1429	push @EXTS, $v->{pkg};
1430	$progress = 1;
1431	}	1508	}
1432		1509
1433	skip:	1510	unless ($progress) {
1434	die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"	1511	warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1435	unless $progress;	1512
		1513	while (my ($k, $v) = each %todo) {
		1514	cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
		1515	if exists $v->{meta}{mandatory};
		1516	}
		1517	}
1436	}	1518	}
1437	};	1519	};
1438	}	1520	}
1439		1521
1440	#############################################################################	1522	#############################################################################
…		…
1524	$cf::PLAYER{$login} = $pl	1606	$cf::PLAYER{$login} = $pl
1525	}	1607	}
1526	}	1608	}
1527	}	1609	}
1528		1610
		1611	cf::player->attach (
		1612	on_load => sub {
		1613	my ($pl, $path) = @_;
		1614
		1615	# restore slots saved in save, below
		1616	my $slots = delete $pl->{_slots};
		1617
		1618	$pl->ob->current_weapon ($slots->[0]);
		1619	$pl->combat_ob ($slots->[1]);
		1620	$pl->ranged_ob ($slots->[2]);
		1621	},
		1622	);
		1623
1529	sub save($) {	1624	sub save($) {
1530	my ($pl) = @_;	1625	my ($pl) = @_;
1531		1626
1532	return if $pl->{deny_save};	1627	return if $pl->{deny_save};
1533		1628
…		…
1538		1633
1539	aio_mkdir playerdir $pl, 0770;	1634	aio_mkdir playerdir $pl, 0770;
1540	$pl->{last_save} = $cf::RUNTIME;	1635	$pl->{last_save} = $cf::RUNTIME;
1541		1636
1542	cf::get_slot 0.01;	1637	cf::get_slot 0.01;
		1638
		1639	# save slots, to be restored later
		1640	local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1543		1641
1544	$pl->save_pl ($path);	1642	$pl->save_pl ($path);
1545	cf::cede_to_tick;	1643	cf::cede_to_tick;
1546	}	1644	}
1547		1645
…		…
1581	my $name = $pl->ob->name;	1679	my $name = $pl->ob->name;
1582		1680
1583	$pl->{deny_save} = 1;	1681	$pl->{deny_save} = 1;
1584	$pl->password ("*"); # this should lock out the player until we have nuked the dir	1682	$pl->password ("*"); # this should lock out the player until we have nuked the dir
1585		1683
1586	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;	1684	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1587	$pl->deactivate;	1685	$pl->deactivate;
		1686
1588	my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;	1687	my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1589	$pl->ob->check_score;
1590	$pl->invoke (cf::EVENT_PLAYER_QUIT);	1688	$pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
		1689	ext::highscore::check ($pl->ob);
		1690
1591	$pl->ns->destroy if $pl->ns;	1691	$pl->ns->destroy if $pl->ns;
1592		1692
1593	my $path = playerdir $pl;	1693	my $path = playerdir $pl;
1594	my $temp = "$path~$cf::RUNTIME~deleting~";	1694	my $temp = "$path~$cf::RUNTIME~deleting~";
1595	aio_rename $path, $temp;	1695	aio_rename $path, $temp;
…		…
1649	\@logins	1749	\@logins
1650	}	1750	}
1651		1751
1652	=item $player->maps	1752	=item $player->maps
1653		1753
		1754	=item cf::player::maps $login
		1755
1654	Returns an arrayref of map paths that are private for this	1756	Returns an arrayref of map paths that are private for this
1655	player. May block.	1757	player. May block.
1656		1758
1657	=cut	1759	=cut
1658		1760
…		…
1720	=cut	1822	=cut
1721		1823
1722	sub find_by_path($) {	1824	sub find_by_path($) {
1723	my ($path) = @_;	1825	my ($path) = @_;
1724		1826
		1827	$path =~ s/^~[^\/]*//; # skip ~login
		1828
1725	my ($match, $specificity);	1829	my ($match, $specificity);
1726		1830
1727	for my $region (list) {	1831	for my $region (list) {
1728	if ($region->{match} && $path =~ $region->{match}) {	1832	if ($region->{match} && $path =~ $region->{match}) {
1729	($match, $specificity) = ($region, $region->specificity)	1833	($match, $specificity) = ($region, $region->specificity)
…		…
1760	my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM	1864	my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1761		1865
1762	# mit "rum" bekleckern, nicht	1866	# mit "rum" bekleckern, nicht
1763	$self->_create_random_map (	1867	$self->_create_random_map (
1764	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},	1868	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1765	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},	1869	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1766	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},	1870	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1767	$rmp->{exit_on_final_map},	1871	$rmp->{exit_on_final_map},
1768	$rmp->{xsize}, $rmp->{ysize},	1872	$rmp->{xsize}, $rmp->{ysize},
1769	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},	1873	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1770	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},	1874	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
…		…
1785		1889
1786	sub register {	1890	sub register {
1787	my (undef, $regex, $prio) = @_;	1891	my (undef, $regex, $prio) = @_;
1788	my $pkg = caller;	1892	my $pkg = caller;
1789		1893
1790	no strict;
1791	push @{"$pkg\::ISA"}, __PACKAGE__;	1894	push @{"$pkg\::ISA"}, __PACKAGE__;
1792		1895
1793	$EXT_MAP{$pkg} = [$prio, qr<$regex>];	1896	$EXT_MAP{$pkg} = [$prio, qr<$regex>];
1794	}	1897	}
1795		1898
1796	# also paths starting with '/'	1899	# also paths starting with '/'
1797	$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];	1900	$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1798		1901
1799	sub thawer_merge {	1902	sub thawer_merge {
1800	my ($self, $merge) = @_;	1903	my ($self, $merge) = @_;
1801		1904
1802	# we have to keep some variables in memory intact	1905	# we have to keep some variables in memory intact
…		…
1807	}	1910	}
1808		1911
1809	sub normalise {	1912	sub normalise {
1810	my ($path, $base) = @_;	1913	my ($path, $base) = @_;
1811		1914
1812	$path = "$path"; # make sure its a string	1915	$path = "$path"; # make sure it's a string
1813		1916
1814	$path =~ s/\.map$//;	1917	$path =~ s/\.map$//;
1815		1918
1816	# map plan:	1919	# map plan:
1817	#	1920	#
…		…
1856	$self->init; # pass $1 etc.	1959	$self->init; # pass $1 etc.
1857	return $self;	1960	return $self;
1858	}	1961	}
1859	}	1962	}
1860		1963
1861	Carp::cluck "unable to resolve path '$path' (base '$base').";	1964	Carp::cluck "unable to resolve path '$path' (base '$base')";
1862	()	1965	()
1863	}	1966	}
1864		1967
1865	sub init {	1968	sub init {
1866	my ($self) = @_;	1969	my ($self) = @_;
…		…
1988	}	2091	}
1989		2092
1990	sub find;	2093	sub find;
1991	sub find {	2094	sub find {
1992	my ($path, $origin) = @_;	2095	my ($path, $origin) = @_;
		2096
		2097	cf::cede_to_tick;
1993		2098
1994	$path = normalise $path, $origin && $origin->path;	2099	$path = normalise $path, $origin && $origin->path;
1995		2100
1996	my $guard1 = cf::lock_acquire "map_data:$path";#d#remove	2101	my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1997	my $guard2 = cf::lock_acquire "map_find:$path";	2102	my $guard2 = cf::lock_acquire "map_find:$path";
…		…
2084	}	2189	}
2085		2190
2086	$self->post_load;	2191	$self->post_load;
2087	}	2192	}
2088		2193
		2194	# customize the map for a given player, i.e.
		2195	# return the _real_ map. used by e.g. per-player
		2196	# maps to change the path to ~playername/mappath
2089	sub customise_for {	2197	sub customise_for {
2090	my ($self, $ob) = @_;	2198	my ($self, $ob) = @_;
2091		2199
2092	return find "~" . $ob->name . "/" . $self->{path}	2200	return find "~" . $ob->name . "/" . $self->{path}
2093	if $self->per_player;	2201	if $self->per_player;
…		…
2109	or next;	2217	or next;
2110	$neigh = find $neigh, $map	2218	$neigh = find $neigh, $map
2111	or next;	2219	or next;
2112	$neigh->load;	2220	$neigh->load;
2113		2221
		2222	# now find the diagonal neighbours
2114	push @neigh,	2223	push @neigh,
2115	[$neigh->tile_path (($_ + 3) % 4), $neigh],	2224	[$neigh->tile_path (($_ + 3) % 4), $neigh],
2116	[$neigh->tile_path (($_ + 1) % 4), $neigh];	2225	[$neigh->tile_path (($_ + 1) % 4), $neigh];
2117	}	2226	}
2118		2227
…		…
2125	}	2234	}
2126		2235
2127	sub find_sync {	2236	sub find_sync {
2128	my ($path, $origin) = @_;	2237	my ($path, $origin) = @_;
2129		2238
2130	cf::sync_job { find $path, $origin }	2239	return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
		2240	if $Coro::current == $Coro::main;
		2241
		2242	find $path, $origin
2131	}	2243	}
2132		2244
2133	sub do_load_sync {	2245	sub do_load_sync {
2134	my ($map) = @_;	2246	my ($map) = @_;
2135		2247
2136	cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"	2248	return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2137	if $Coro::current == $Coro::main;	2249	if $Coro::current == $Coro::main;
2138		2250
2139	cf::sync_job { $map->load };	2251	$map->load;
2140	}	2252	}
2141		2253
2142	our %MAP_PREFETCH;	2254	our %MAP_PREFETCH;
2143	our $MAP_PREFETCHER = undef;	2255	our $MAP_PREFETCHER = undef;
2144		2256
…		…
2170	$MAP_PREFETCHER->prio (6);	2282	$MAP_PREFETCHER->prio (6);
2171		2283
2172	()	2284	()
2173	}	2285	}
2174		2286
		2287	# common code, used by both ->save and ->swapout
2175	sub save {	2288	sub _save {
2176	my ($self) = @_;	2289	my ($self) = @_;
2177
2178	my $lock = cf::lock_acquire "map_data:$self->{path}";
2179		2290
2180	$self->{last_save} = $cf::RUNTIME;	2291	$self->{last_save} = $cf::RUNTIME;
2181		2292
2182	return unless $self->dirty;	2293	return unless $self->dirty;
2183		2294
…		…
2203	} else {	2314	} else {
2204	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);	2315	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2205	}	2316	}
2206	}	2317	}
2207		2318
		2319	sub save {
		2320	my ($self) = @_;
		2321
		2322	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2323
		2324	$self->_save;
		2325	}
		2326
2208	sub swap_out {	2327	sub swap_out {
2209	my ($self) = @_;	2328	my ($self) = @_;
2210		2329
2211	# save first because save cedes
2212	$self->save;
2213
2214	my $lock = cf::lock_acquire "map_data:$self->{path}";	2330	my $lock = cf::lock_acquire "map_data:$self->{path}";
2215		2331
2216	return if $self->players;
2217	return if $self->in_memory != cf::MAP_ACTIVE;	2332	return if $self->in_memory != cf::MAP_ACTIVE;
2218	return if $self->{deny_save};	2333	return if $self->{deny_save};
		2334	return if $self->players;
2219		2335
		2336	# first deactivate the map and "unlink" it from the core
		2337	$self->deactivate;
		2338	$_->clear_links_to ($self) for values %cf::MAP;
2220	$self->in_memory (cf::MAP_SWAPPED);	2339	$self->in_memory (cf::MAP_SWAPPED);
		2340
		2341	# then atomically save
		2342	$self->_save;
		2343
		2344	# then free the map
		2345	$self->clear;
		2346	}
		2347
		2348	sub reset_at {
		2349	my ($self) = @_;
		2350
		2351	# TODO: safety, remove and allow resettable per-player maps
		2352	return 1e99 if $self->{deny_reset};
		2353
		2354	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
		2355	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
		2356
		2357	$time + $to
		2358	}
		2359
		2360	sub should_reset {
		2361	my ($self) = @_;
		2362
		2363	$self->reset_at <= $cf::RUNTIME
		2364	}
		2365
		2366	sub reset {
		2367	my ($self) = @_;
		2368
		2369	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2370
		2371	return if $self->players;
		2372
		2373	cf::trace "resetting map ", $self->path, "\n";
		2374
		2375	$self->in_memory (cf::MAP_SWAPPED);
		2376
		2377	# need to save uniques path
		2378	unless ($self->{deny_save}) {
		2379	my $uniq = $self->uniq_path; utf8::encode $uniq;
		2380
		2381	$self->_save_objects ($uniq, cf::IO_UNIQUES)
		2382	if $uniq;
		2383	}
		2384
		2385	delete $cf::MAP{$self->path};
2221		2386
2222	$self->deactivate;	2387	$self->deactivate;
2223	$_->clear_links_to ($self) for values %cf::MAP;	2388	$_->clear_links_to ($self) for values %cf::MAP;
2224	$self->clear;	2389	$self->clear;
2225	}
2226
2227	sub reset_at {
2228	my ($self) = @_;
2229
2230	# TODO: safety, remove and allow resettable per-player maps
2231	return 1e99 if $self->{deny_reset};
2232
2233	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2234	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2235
2236	$time + $to
2237	}
2238
2239	sub should_reset {
2240	my ($self) = @_;
2241
2242	$self->reset_at <= $cf::RUNTIME
2243	}
2244
2245	sub reset {
2246	my ($self) = @_;
2247
2248	my $lock = cf::lock_acquire "map_data:$self->{path}";
2249
2250	return if $self->players;
2251
2252	warn "resetting map ", $self->path, "\n";
2253
2254	$self->in_memory (cf::MAP_SWAPPED);
2255
2256	# need to save uniques path
2257	unless ($self->{deny_save}) {
2258	my $uniq = $self->uniq_path; utf8::encode $uniq;
2259
2260	$self->_save_objects ($uniq, cf::IO_UNIQUES)
2261	if $uniq;
2262	}
2263
2264	delete $cf::MAP{$self->path};
2265
2266	$self->deactivate;
2267	$_->clear_links_to ($self) for values %cf::MAP;
2268	$self->clear;
2269		2390
2270	$self->unlink_save;	2391	$self->unlink_save;
2271	$self->destroy;	2392	$self->destroy;
2272	}	2393	}
2273		2394
…		…
2281		2402
2282	delete $cf::MAP{$self->path};	2403	delete $cf::MAP{$self->path};
2283		2404
2284	$self->unlink_save;	2405	$self->unlink_save;
2285		2406
2286	bless $self, "cf::map";	2407	bless $self, "cf::map::wrap";
2287	delete $self->{deny_reset};	2408	delete $self->{deny_reset};
2288	$self->{deny_save} = 1;	2409	$self->{deny_save} = 1;
2289	$self->reset_timeout (1);	2410	$self->reset_timeout (1);
2290	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2411	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2291		2412
…		…
2521		2642
2522	Freezes the player and moves him/her to a special map (C<{link}>).	2643	Freezes the player and moves him/her to a special map (C<{link}>).
2523		2644
2524	The player should be reasonably safe there for short amounts of time (e.g.	2645	The player should be reasonably safe there for short amounts of time (e.g.
2525	for loading a map). You I<MUST> call C<leave_link> as soon as possible,	2646	for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2526	though, as the palyer cannot control the character while it is on the link	2647	though, as the player cannot control the character while it is on the link
2527	map.	2648	map.
2528		2649
2529	Will never block.	2650	Will never block.
2530		2651
2531	=item $player_object->leave_link ($map, $x, $y)	2652	=item $player_object->leave_link ($map, $x, $y)
…		…
2552	sub cf::object::player::enter_link {	2673	sub cf::object::player::enter_link {
2553	my ($self) = @_;	2674	my ($self) = @_;
2554		2675
2555	$self->deactivate_recursive;	2676	$self->deactivate_recursive;
2556		2677
		2678	++$self->{_link_recursion};
		2679
2557	return if UNIVERSAL::isa $self->map, "ext::map_link";	2680	return if UNIVERSAL::isa $self->map, "ext::map_link";
2558		2681
2559	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]	2682	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2560	if $self->map && $self->map->{path} ne "{link}";	2683	if $self->map && $self->map->{path} ne "{link}";
2561		2684
2562	$self->enter_map ($LINK_MAP || link_map, 10, 10);	2685	$self->enter_map ($LINK_MAP || link_map, 3, 3);
2563	}	2686	}
2564		2687
2565	sub cf::object::player::leave_link {	2688	sub cf::object::player::leave_link {
2566	my ($self, $map, $x, $y) = @_;	2689	my ($self, $map, $x, $y) = @_;
2567		2690
…		…
2592	$map->load_neighbours;	2715	$map->load_neighbours;
2593		2716
2594	return unless $self->contr->active;	2717	return unless $self->contr->active;
2595		2718
2596	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2719	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2597	$self->enter_map ($map, $x, $y);	2720	if ($self->enter_map ($map, $x, $y)) {
2598		2721	# entering was successful
		2722	delete $self->{_link_recursion};
2599	# only activate afterwards, to support waiting in hooks	2723	# only activate afterwards, to support waiting in hooks
2600	$self->activate_recursive;	2724	$self->activate_recursive;
2601	}	2725	}
2602		2726
		2727	}
		2728
2603	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])	2729	=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2604		2730
2605	Moves the player to the given map-path and coordinates by first freezing	2731	Moves the player to the given map-path and coordinates by first freezing
2606	her, loading and preparing them map, calling the provided $check callback	2732	her, loading and preparing them map, calling the provided $check callback
2607	that has to return the map if sucecssful, and then unfreezes the player on	2733	that has to return the map if sucecssful, and then unfreezes the player on
2608	the new (success) or old (failed) map position. In either case, $done will	2734	the new (success) or old (failed) map position. In either case, $done will
…		…
2615		2741
2616	our $GOTOGEN;	2742	our $GOTOGEN;
2617		2743
2618	sub cf::object::player::goto {	2744	sub cf::object::player::goto {
2619	my ($self, $path, $x, $y, $check, $done) = @_;	2745	my ($self, $path, $x, $y, $check, $done) = @_;
		2746
		2747	if ($self->{_link_recursion} >= $MAX_LINKS) {
		2748	error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
		2749	$self->failmsg ("Something went wrong inside the server - please contact an administrator!");
		2750	($path, $x, $y) = @$EMERGENCY_POSITION;
		2751	}
2620		2752
2621	# do generation counting so two concurrent goto's will be executed in-order	2753	# do generation counting so two concurrent goto's will be executed in-order
2622	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2754	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2623		2755
2624	$self->enter_link;	2756	$self->enter_link;
…		…
2648	my $map = eval {	2780	my $map = eval {
2649	my $map = defined $path ? cf::map::find $path : undef;	2781	my $map = defined $path ? cf::map::find $path : undef;
2650		2782
2651	if ($map) {	2783	if ($map) {
2652	$map = $map->customise_for ($self);	2784	$map = $map->customise_for ($self);
2653	$map = $check->($map) if $check && $map;	2785	$map = $check->($map, $x, $y, $self) if $check && $map;
2654	} else {	2786	} else {
2655	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);	2787	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2656	}	2788	}
2657		2789
2658	$map	2790	$map
…		…
2666	if ($gen == $self->{_goto_generation}) {	2798	if ($gen == $self->{_goto_generation}) {
2667	delete $self->{_goto_generation};	2799	delete $self->{_goto_generation};
2668	$self->leave_link ($map, $x, $y);	2800	$self->leave_link ($map, $x, $y);
2669	}	2801	}
2670		2802
2671	$done->() if $done;	2803	$done->($self) if $done;
2672	})->prio (1);	2804	})->prio (1);
2673	}	2805	}
2674		2806
2675	=item $player_object->enter_exit ($exit_object)	2807	=item $player_object->enter_exit ($exit_object)
2676		2808
…		…
2769	$self->message ("Something went wrong deep within the deliantra server. "	2901	$self->message ("Something went wrong deep within the deliantra server. "
2770	. "I'll try to bring you back to the map you were before. "	2902	. "I'll try to bring you back to the map you were before. "
2771	. "Please report this to the dungeon master!",	2903	. "Please report this to the dungeon master!",
2772	cf::NDI_UNIQUE | cf::NDI_RED);	2904	cf::NDI_UNIQUE | cf::NDI_RED);
2773		2905
2774	warn "ERROR in enter_exit: $@";	2906	error "ERROR in enter_exit: $@";
2775	$self->leave_link;	2907	$self->leave_link;
2776	}	2908	}
2777	})->prio (1);	2909	})->prio (1);
2778	}	2910	}
2779		2911
…		…
3092		3224
3093	$ns->ext_reply ($reply, @reply)	3225	$ns->ext_reply ($reply, @reply)
3094	if $reply;	3226	if $reply;
3095		3227
3096	} else {	3228	} else {
3097	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	3229	error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3098	}	3230	}
3099		3231
3100	cf::override;	3232	cf::override;
3101	},	3233	},
3102	);	3234	);
…		…
3122		3254
3123	$coro	3255	$coro
3124	}	3256	}
3125		3257
3126	cf::client->attach (	3258	cf::client->attach (
3127	on_destroy => sub {	3259	on_client_destroy => sub {
3128	my ($ns) = @_;	3260	my ($ns) = @_;
3129		3261
3130	$_->cancel for values %{ (delete $ns->{_coro}) || {} };	3262	$_->cancel for values %{ (delete $ns->{_coro}) || {} };
3131	},	3263	},
3132	);	3264	);
…		…
3183	decrease split destroy change_exp value msg lore send_msg)],	3315	decrease split destroy change_exp value msg lore send_msg)],
3184	["cf::object::player" => qw(player)],	3316	["cf::object::player" => qw(player)],
3185	["cf::player" => qw(peaceful send_msg)],	3317	["cf::player" => qw(peaceful send_msg)],
3186	["cf::map" => qw(trigger)],	3318	["cf::map" => qw(trigger)],
3187	) {	3319	) {
3188	no strict 'refs';
3189	my ($pkg, @funs) = @$_;	3320	my ($pkg, @funs) = @$_;
3190	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	3321	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3191	for @funs;	3322	for @funs;
3192	}	3323	}
3193		3324
…		…
3232	local @cf::_safe_eval_args = values %vars;	3363	local @cf::_safe_eval_args = values %vars;
3233	@res = wantarray ? eval eval : scalar eval $eval;	3364	@res = wantarray ? eval eval : scalar eval $eval;
3234	}	3365	}
3235		3366
3236	if ($@) {	3367	if ($@) {
3237	warn "$@";	3368	warn "$@",
3238	warn "while executing safe code '$code'\n";	3369	"while executing safe code '$code'\n",
3239	warn "with arguments " . (join " ", %vars) . "\n";	3370	"with arguments " . (join " ", %vars) . "\n";
3240	}	3371	}
3241		3372
3242	wantarray ? @res : $res[0]	3373	wantarray ? @res : $res[0]
3243	}	3374	}
3244		3375
…		…
3278	# for this (global event?)	3409	# for this (global event?)
3279	%ext::player_env::MUSIC_FACE_CACHE = ();	3410	%ext::player_env::MUSIC_FACE_CACHE = ();
3280		3411
3281	my $enc = JSON::XS->new->utf8->canonical->relaxed;	3412	my $enc = JSON::XS->new->utf8->canonical->relaxed;
3282		3413
3283	warn "loading facedata from $path\n";	3414	trace "loading facedata from $path\n";
3284		3415
3285	my $facedata;
3286	0 < aio_load $path, $facedata	3416	0 < aio_load $path, my $facedata
3287	or die "$path: $!";	3417	or die "$path: $!";
3288		3418
3289	$facedata = Coro::Storable::thaw $facedata;	3419	$facedata = Coro::Storable::thaw $facedata;
3290		3420
3291	$facedata->{version} == 2	3421	$facedata->{version} == 2
…		…
3322		3452
3323	if (my $smooth = cf::face::find $info->{smooth}) {	3453	if (my $smooth = cf::face::find $info->{smooth}) {
3324	cf::face::set_smooth $idx, $smooth;	3454	cf::face::set_smooth $idx, $smooth;
3325	cf::face::set_smoothlevel $idx, $info->{smoothlevel};	3455	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3326	} else {	3456	} else {
3327	warn "smooth face '$info->{smooth}' not found for face '$face'";	3457	error "smooth face '$info->{smooth}' not found for face '$face'";
3328	}	3458	}
3329		3459
3330	cf::cede_to_tick;	3460	cf::cede_to_tick;
3331	}	3461	}
3332	}	3462	}
…		…
3350	my $idx = (cf::face::find $name) || cf::face::alloc $name;	3480	my $idx = (cf::face::find $name) || cf::face::alloc $name;
3351		3481
3352	cf::face::set_data $idx, 0, $info->{data}, $info->{hash};	3482	cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3353	cf::face::set_type $idx, $info->{type};	3483	cf::face::set_type $idx, $info->{type};
3354	} else {	3484	} else {
3355	$RESOURCE{$name} = $info;	3485	$RESOURCE{$name} = $info; # unused
3356	}	3486	}
3357		3487
3358	cf::cede_to_tick;	3488	cf::cede_to_tick;
3359	}	3489	}
3360	}	3490	}
3361		3491
3362	cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);	3492	cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3363		3493
3364	1	3494	1
3365	}	3495	}
3366
3367	cf::global->attach (on_resource_update => sub {
3368	if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3369	$soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3370
3371	for (0 .. SOUND_CAST_SPELL_0 - 1) {
3372	my $sound = $soundconf->{compat}[$_]
3373	or next;
3374
3375	my $face = cf::face::find "sound/$sound->[1]";
3376	cf::sound::set $sound->[0] => $face;
3377	cf::sound::old_sound_index $_, $face; # gcfclient-compat
3378	}
3379
3380	while (my ($k, $v) = each %{$soundconf->{event}}) {
3381	my $face = cf::face::find "sound/$v";
3382	cf::sound::set $k => $face;
3383	}
3384	}
3385	});
3386		3496
3387	register_exticmd fx_want => sub {	3497	register_exticmd fx_want => sub {
3388	my ($ns, $want) = @_;	3498	my ($ns, $want) = @_;
3389		3499
3390	while (my ($k, $v) = each %$want) {	3500	while (my ($k, $v) = each %$want) {
…		…
3429	sub reload_treasures {	3539	sub reload_treasures {
3430	load_resource_file "$DATADIR/treasures"	3540	load_resource_file "$DATADIR/treasures"
3431	or die "unable to load treasurelists\n";	3541	or die "unable to load treasurelists\n";
3432	}	3542	}
3433		3543
		3544	sub reload_sound {
		3545	trace "loading sound config from $DATADIR/sound\n";
		3546
		3547	0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
		3548	or die "$DATADIR/sound $!";
		3549
		3550	my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
		3551
		3552	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3553	my $sound = $soundconf->{compat}[$_]
		3554	or next;
		3555
		3556	my $face = cf::face::find "sound/$sound->[1]";
		3557	cf::sound::set $sound->[0] => $face;
		3558	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3559	}
		3560
		3561	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3562	my $face = cf::face::find "sound/$v";
		3563	cf::sound::set $k => $face;
		3564	}
		3565	}
		3566
3434	sub reload_resources {	3567	sub reload_resources {
3435	warn "reloading resource files...\n";	3568	trace "reloading resource files...\n";
3436		3569
		3570	reload_exp_table;
		3571	reload_materials;
3437	reload_facedata;	3572	reload_facedata;
		3573	reload_sound;
3438	reload_archetypes;	3574	reload_archetypes;
3439	reload_regions;	3575	reload_regions;
3440	reload_treasures;	3576	reload_treasures;
3441		3577
3442	warn "finished reloading resource files\n";	3578	trace "finished reloading resource files\n";
3443	}	3579	}
3444		3580
3445	sub reload_config {	3581	sub reload_config {
3446	warn "reloading config file...\n";	3582	trace "reloading config file...\n";
3447		3583
3448	open my $fh, "<:utf8", "$CONFDIR/config"	3584	0 < aio_load "$CONFDIR/config", my $config
3449	or return;	3585	or die "$CONFDIR/config: $!";
3450		3586
3451	local $/;	3587	utf8::decode $config;
3452	*CFG = YAML::XS::Load scalar <$fh>;	3588	*CFG = yaml_load $config;
3453		3589
3454	$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];	3590	$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3455		3591
3456	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};	3592	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3457	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};	3593	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3458		3594
3459	if (exists $CFG{mlockall}) {	3595	if (exists $CFG{mlockall}) {
…		…
3461	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"	3597	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3462	and die "WARNING: m(un)lockall failed: $!\n";	3598	and die "WARNING: m(un)lockall failed: $!\n";
3463	};	3599	};
3464	warn $@ if $@;	3600	warn $@ if $@;
3465	}	3601	}
3466
3467	warn "finished reloading resource files\n";
3468	}	3602	}
3469		3603
3470	sub pidfile() {	3604	sub pidfile() {
3471	sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT	3605	sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3472	or die "$PIDFILE: $!";	3606	or die "$PIDFILE: $!";
…		…
3485	seek $fh, 0, 0;	3619	seek $fh, 0, 0;
3486	print $fh $$;	3620	print $fh $$;
3487	}	3621	}
3488		3622
3489	sub main_loop {	3623	sub main_loop {
3490	warn "EV::loop starting\n";	3624	trace "EV::loop starting\n";
3491	if (1) {	3625	if (1) {
3492	EV::loop;	3626	EV::loop;
3493	}	3627	}
3494	warn "EV::loop returned\n";	3628	trace "EV::loop returned\n";
3495	goto &main_loop unless $REALLY_UNLOOP;	3629	goto &main_loop unless $REALLY_UNLOOP;
3496	}	3630	}
3497		3631
3498	sub main {	3632	sub main {
3499	cf::init_globals; # initialise logging	3633	cf::init_globals; # initialise logging
3500		3634
3501	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;	3635	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3502	LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";	3636	LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3503	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";	3637	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3504	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";	3638	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3505
3506	cf::init_experience;
3507	cf::init_anim;
3508	cf::init_attackmess;
3509	cf::init_dynamic;
3510		3639
3511	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority	3640	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3512		3641
3513	# we must not ever block the main coroutine	3642	# we must not ever block the main coroutine
3514	local $Coro::idle = sub {	3643	local $Coro::idle = sub {
…		…
3520	};	3649	};
3521		3650
3522	evthread_start IO::AIO::poll_fileno;	3651	evthread_start IO::AIO::poll_fileno;
3523		3652
3524	cf::sync_job {	3653	cf::sync_job {
		3654	cf::incloader::init ();
		3655
		3656	cf::init_anim;
		3657	cf::init_attackmess;
		3658	cf::init_dynamic;
		3659
3525	cf::load_settings;	3660	cf::load_settings;
3526	cf::load_materials;
3527		3661
3528	reload_resources;	3662	reload_resources;
3529	reload_config;	3663	reload_config;
3530	db_init;	3664	db_init;
3531		3665
3532	cf::init_uuid;	3666	cf::init_uuid;
3533	cf::init_signals;	3667	cf::init_signals;
3534	cf::init_commands;
3535	cf::init_skills;	3668	cf::init_skills;
3536		3669
3537	cf::init_beforeplay;	3670	cf::init_beforeplay;
3538		3671
3539	atomic;	3672	atomic;
…		…
3544		3677
3545	# no (long-running) fork's whatsoever before this point(!)	3678	# no (long-running) fork's whatsoever before this point(!)
3546	use POSIX ();	3679	use POSIX ();
3547	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};	3680	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3548		3681
3549	(pop @POST_INIT)->(0) while @POST_INIT;	3682	cf::_post_init 0;
3550	};	3683	};
3551		3684
		3685	cf::object::thawer::errors_are_fatal 0;
		3686	info "parse errors in files are no longer fatal from this point on.\n";
		3687
		3688	my $free_main; $free_main = EV::idle sub {
		3689	undef $free_main;
		3690	undef &main; # free gobs of memory :)
		3691	};
		3692
3552	main_loop;	3693	goto &main_loop;
3553	}	3694	}
3554		3695
3555	#############################################################################	3696	#############################################################################
3556	# initialisation and cleanup	3697	# initialisation and cleanup
3557		3698
3558	# install some emergency cleanup handlers	3699	# install some emergency cleanup handlers
3559	BEGIN {	3700	BEGIN {
3560	our %SIGWATCHER = ();	3701	our %SIGWATCHER = ();
3561	for my $signal (qw(INT HUP TERM)) {	3702	for my $signal (qw(INT HUP TERM)) {
3562	$SIGWATCHER{$signal} = EV::signal $signal, sub {	3703	$SIGWATCHER{$signal} = AE::signal $signal, sub {
3563	cf::cleanup "SIG$signal";	3704	cf::cleanup "SIG$signal";
3564	};	3705	};
3565	}	3706	}
3566	}	3707	}
3567		3708
3568	sub write_runtime_sync {	3709	sub write_runtime_sync {
		3710	my $t0 = AE::time;
		3711
3569	# first touch the runtime file to show we are still running:	3712	# first touch the runtime file to show we are still running:
3570	# the fsync below can take a very very long time.	3713	# the fsync below can take a very very long time.
3571		3714
3572	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;	3715	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3573		3716
3574	my $guard = cf::lock_acquire "write_runtime";	3717	my $guard = cf::lock_acquire "write_runtime";
3575		3718
3576	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644	3719	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3577	or return;	3720	or return;
3578		3721
3579	my $value = $cf::RUNTIME + 90 + 10;	3722	my $value = $cf::RUNTIME + 90 + 10;
3580	# 10 is the runtime save interval, for a monotonic clock	3723	# 10 is the runtime save interval, for a monotonic clock
3581	# 60 allows for the watchdog to kill the server.	3724	# 60 allows for the watchdog to kill the server.
…		…
3594	or return;	3737	or return;
3595		3738
3596	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE	3739	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3597	and return;	3740	and return;
3598		3741
3599	warn "runtime file written.\n";	3742	trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3600		3743
3601	1	3744	1
3602	}	3745	}
3603		3746
3604	our $uuid_lock;	3747	our $uuid_lock;
…		…
3616	or return;	3759	or return;
3617		3760
3618	my $value = uuid_seq uuid_cur;	3761	my $value = uuid_seq uuid_cur;
3619		3762
3620	unless ($value) {	3763	unless ($value) {
3621	warn "cowardly refusing to write zero uuid value!\n";	3764	info "cowardly refusing to write zero uuid value!\n";
3622	return;	3765	return;
3623	}	3766	}
3624		3767
3625	my $value = uuid_str $value + $uuid_skip;	3768	my $value = uuid_str $value + $uuid_skip;
3626	$uuid_skip = 0;	3769	$uuid_skip = 0;
…		…
3636	or return;	3779	or return;
3637		3780
3638	aio_rename "$uuid~", $uuid	3781	aio_rename "$uuid~", $uuid
3639	and return;	3782	and return;
3640		3783
3641	warn "uuid file written ($value).\n";	3784	trace "uuid file written ($value).\n";
3642		3785
3643	1	3786	1
3644		3787
3645	}	3788	}
3646		3789
…		…
3652	}	3795	}
3653		3796
3654	sub emergency_save() {	3797	sub emergency_save() {
3655	my $freeze_guard = cf::freeze_mainloop;	3798	my $freeze_guard = cf::freeze_mainloop;
3656		3799
3657	warn "emergency_perl_save: enter\n";	3800	info "emergency_perl_save: enter\n";
		3801
		3802	# this is a trade-off: we want to be very quick here, so
		3803	# save all maps without fsync, and later call a global sync
		3804	# (which in turn might be very very slow)
		3805	local $USE_FSYNC = 0;
3658		3806
3659	cf::sync_job {	3807	cf::sync_job {
3660	# this is a trade-off: we want to be very quick here, so	3808	cf::write_runtime_sync; # external watchdog should not bark
3661	# save all maps without fsync, and later call a global sync
3662	# (which in turn might be very very slow)
3663	local $USE_FSYNC = 0;
3664		3809
3665	# use a peculiar iteration method to avoid tripping on perl	3810	# use a peculiar iteration method to avoid tripping on perl
3666	# refcount bugs in for. also avoids problems with players	3811	# refcount bugs in for. also avoids problems with players
3667	# and maps saved/destroyed asynchronously.	3812	# and maps saved/destroyed asynchronously.
3668	warn "emergency_perl_save: begin player save\n";	3813	info "emergency_perl_save: begin player save\n";
3669	for my $login (keys %cf::PLAYER) {	3814	for my $login (keys %cf::PLAYER) {
3670	my $pl = $cf::PLAYER{$login} or next;	3815	my $pl = $cf::PLAYER{$login} or next;
3671	$pl->valid or next;	3816	$pl->valid or next;
3672	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt	3817	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3673	$pl->save;	3818	$pl->save;
3674	}	3819	}
3675	warn "emergency_perl_save: end player save\n";	3820	info "emergency_perl_save: end player save\n";
3676		3821
		3822	cf::write_runtime_sync; # external watchdog should not bark
		3823
3677	warn "emergency_perl_save: begin map save\n";	3824	info "emergency_perl_save: begin map save\n";
3678	for my $path (keys %cf::MAP) {	3825	for my $path (keys %cf::MAP) {
3679	my $map = $cf::MAP{$path} or next;	3826	my $map = $cf::MAP{$path} or next;
3680	$map->valid or next;	3827	$map->valid or next;
3681	$map->save;	3828	$map->save;
3682	}	3829	}
3683	warn "emergency_perl_save: end map save\n";	3830	info "emergency_perl_save: end map save\n";
3684		3831
		3832	cf::write_runtime_sync; # external watchdog should not bark
		3833
3685	warn "emergency_perl_save: begin database checkpoint\n";	3834	info "emergency_perl_save: begin database checkpoint\n";
3686	BDB::db_env_txn_checkpoint $DB_ENV;	3835	BDB::db_env_txn_checkpoint $DB_ENV;
3687	warn "emergency_perl_save: end database checkpoint\n";	3836	info "emergency_perl_save: end database checkpoint\n";
3688		3837
3689	warn "emergency_perl_save: begin write uuid\n";	3838	info "emergency_perl_save: begin write uuid\n";
3690	write_uuid_sync 1;	3839	write_uuid_sync 1;
3691	warn "emergency_perl_save: end write uuid\n";	3840	info "emergency_perl_save: end write uuid\n";
		3841
		3842	cf::write_runtime_sync; # external watchdog should not bark
		3843
		3844	trace "emergency_perl_save: syncing database to disk";
		3845	BDB::db_env_txn_checkpoint $DB_ENV;
		3846
		3847	info "emergency_perl_save: starting sync\n";
		3848	IO::AIO::aio_sync sub {
		3849	info "emergency_perl_save: finished sync\n";
		3850	};
		3851
		3852	cf::write_runtime_sync; # external watchdog should not bark
		3853
		3854	trace "emergency_perl_save: flushing outstanding aio requests";
		3855	while (IO::AIO::nreqs || BDB::nreqs) {
		3856	Coro::EV::timer_once 0.01; # let the sync_job do it's thing
		3857	}
		3858
		3859	cf::write_runtime_sync; # external watchdog should not bark
3692	};	3860	};
3693		3861
3694	warn "emergency_perl_save: starting sync()\n";
3695	IO::AIO::aio_sync sub {
3696	warn "emergency_perl_save: finished sync()\n";
3697	};
3698
3699	warn "emergency_perl_save: leave\n";	3862	info "emergency_perl_save: leave\n";
3700	}	3863	}
3701		3864
3702	sub post_cleanup {	3865	sub post_cleanup {
3703	my ($make_core) = @_;	3866	my ($make_core) = @_;
3704		3867
		3868	IO::AIO::flush;
		3869
3705	warn Carp::longmess "post_cleanup backtrace"	3870	error Carp::longmess "post_cleanup backtrace"
3706	if $make_core;	3871	if $make_core;
3707		3872
3708	my $fh = pidfile;	3873	my $fh = pidfile;
3709	unlink $PIDFILE if <$fh> == $$;	3874	unlink $PIDFILE if <$fh> == $$;
3710	}	3875	}
…		…
3730	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};	3895	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3731	for my $name (keys %$leaf_symtab) {	3896	for my $name (keys %$leaf_symtab) {
3732	_gv_clear *{"$pkg$name"};	3897	_gv_clear *{"$pkg$name"};
3733	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};	3898	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3734	}	3899	}
3735	warn "cleared package $pkg\n";#d#
3736	}	3900	}
3737		3901
3738	sub do_reload_perl() {	3902	sub do_reload_perl() {
3739	# can/must only be called in main	3903	# can/must only be called in main
3740	if ($Coro::current != $Coro::main) {	3904	unless (in_main) {
3741	warn "can only reload from main coroutine";	3905	error "can only reload from main coroutine";
3742	return;	3906	return;
3743	}	3907	}
3744		3908
3745	return if $RELOAD++;	3909	return if $RELOAD++;
3746		3910
3747	my $t1 = EV::time;	3911	my $t1 = AE::time;
3748		3912
3749	while ($RELOAD) {	3913	while ($RELOAD) {
3750	warn "reloading...";	3914	cf::get_slot 0.1, -1, "reload_perl";
		3915	info "perl_reload: reloading...";
3751		3916
3752	warn "entering sync_job";	3917	trace "perl_reload: entering sync_job";
3753		3918
3754	cf::sync_job {	3919	cf::sync_job {
3755	cf::write_runtime_sync; # external watchdog should not bark
3756	cf::emergency_save;	3920	#cf::emergency_save;
3757	cf::write_runtime_sync; # external watchdog should not bark
3758		3921
3759	warn "syncing database to disk";
3760	BDB::db_env_txn_checkpoint $DB_ENV;
3761
3762	# if anything goes wrong in here, we should simply crash as we already saved
3763
3764	warn "flushing outstanding aio requests";
3765	while (IO::AIO::nreqs || BDB::nreqs) {
3766	Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3767	}
3768
3769	warn "cancelling all extension coros";	3922	trace "perl_reload: cancelling all extension coros";
3770	$_->cancel for values %EXT_CORO;	3923	$_->cancel for values %EXT_CORO;
3771	%EXT_CORO = ();	3924	%EXT_CORO = ();
3772		3925
3773	warn "removing commands";	3926	trace "perl_reload: removing commands";
3774	%COMMAND = ();	3927	%COMMAND = ();
3775		3928
3776	warn "removing ext/exti commands";	3929	trace "perl_reload: removing ext/exti commands";
3777	%EXTCMD = ();	3930	%EXTCMD = ();
3778	%EXTICMD = ();	3931	%EXTICMD = ();
3779		3932
3780	warn "unloading/nuking all extensions";	3933	trace "perl_reload: unloading/nuking all extensions";
3781	for my $pkg (@EXTS) {	3934	for my $pkg (@EXTS) {
3782	warn "... unloading $pkg";	3935	trace "... unloading $pkg";
3783		3936
3784	if (my $cb = $pkg->can ("unload")) {	3937	if (my $cb = $pkg->can ("unload")) {
3785	eval {	3938	eval {
3786	$cb->($pkg);	3939	$cb->($pkg);
3787	1	3940	1
3788	} or warn "$pkg unloaded, but with errors: $@";	3941	} or error "$pkg unloaded, but with errors: $@";
3789	}	3942	}
3790		3943
3791	warn "... clearing $pkg";	3944	trace "... clearing $pkg";
3792	clear_package $pkg;	3945	clear_package $pkg;
3793	}	3946	}
3794		3947
3795	warn "unloading all perl modules loaded from $LIBDIR";	3948	trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3796	while (my ($k, $v) = each %INC) {	3949	while (my ($k, $v) = each %INC) {
3797	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;	3950	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3798		3951
3799	warn "... unloading $k";	3952	trace "... unloading $k";
3800	delete $INC{$k};	3953	delete $INC{$k};
3801		3954
3802	$k =~ s/\.pm$//;	3955	$k =~ s/\.pm$//;
3803	$k =~ s/\//::/g;	3956	$k =~ s/\//::/g;
3804		3957
…		…
3807	}	3960	}
3808		3961
3809	clear_package $k;	3962	clear_package $k;
3810	}	3963	}
3811		3964
3812	warn "getting rid of safe::, as good as possible";	3965	trace "perl_reload: getting rid of safe::, as good as possible";
3813	clear_package "safe::$_"	3966	clear_package "safe::$_"
3814	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	3967	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3815		3968
3816	warn "unloading cf.pm \"a bit\"";	3969	trace "perl_reload: unloading cf.pm \"a bit\"";
3817	delete $INC{"cf.pm"};	3970	delete $INC{"cf.pm"};
3818	delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;	3971	delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3819		3972
3820	# don't, removes xs symbols, too,	3973	# don't, removes xs symbols, too,
3821	# and global variables created in xs	3974	# and global variables created in xs
3822	#clear_package __PACKAGE__;	3975	#clear_package __PACKAGE__;
3823		3976
3824	warn "unload completed, starting to reload now";	3977	info "perl_reload: unload completed, starting to reload now";
3825		3978
3826	warn "reloading cf.pm";	3979	trace "perl_reload: reloading cf.pm";
3827	require cf;	3980	require cf;
3828	cf::_connect_to_perl_1;	3981	cf::_connect_to_perl_1;
3829		3982
3830	warn "loading config and database again";	3983	trace "perl_reload: loading config and database again";
3831	cf::reload_config;	3984	cf::reload_config;
3832		3985
3833	warn "loading extensions";	3986	trace "perl_reload: loading extensions";
3834	cf::load_extensions;	3987	cf::load_extensions;
3835		3988
3836	if ($REATTACH_ON_RELOAD) {	3989	if ($REATTACH_ON_RELOAD) {
3837	warn "reattaching attachments to objects/players";	3990	trace "perl_reload: reattaching attachments to objects/players";
3838	_global_reattach; # objects, sockets	3991	_global_reattach; # objects, sockets
3839	warn "reattaching attachments to maps";	3992	trace "perl_reload: reattaching attachments to maps";
3840	reattach $_ for values %MAP;	3993	reattach $_ for values %MAP;
3841	warn "reattaching attachments to players";	3994	trace "perl_reload: reattaching attachments to players";
3842	reattach $_ for values %PLAYER;	3995	reattach $_ for values %PLAYER;
3843	}	3996	}
3844		3997
3845	warn "running post_init jobs";	3998	cf::_post_init 1;
3846	(pop @POST_INIT)->(1) while @POST_INIT;
3847		3999
3848	warn "leaving sync_job";	4000	trace "perl_reload: leaving sync_job";
3849		4001
3850	1	4002	1
3851	} or do {	4003	} or do {
3852	warn $@;	4004	error $@;
3853	cf::cleanup "error while reloading, exiting.";	4005	cf::cleanup "perl_reload: error, exiting.";
3854	};	4006	};
3855		4007
3856	warn "reloaded";
3857	--$RELOAD;	4008	--$RELOAD;
3858	}	4009	}
3859		4010
3860	$t1 = EV::time - $t1;	4011	$t1 = AE::time - $t1;
3861	warn "reload completed in ${t1}s\n";	4012	info "perl_reload: completed in ${t1}s\n";
3862	};	4013	};
3863		4014
3864	our $RELOAD_WATCHER; # used only during reload	4015	our $RELOAD_WATCHER; # used only during reload
3865		4016
3866	sub reload_perl() {	4017	sub reload_perl() {
…		…
3868	# coro crashes during coro_state_free->destroy here.	4019	# coro crashes during coro_state_free->destroy here.
3869		4020
3870	$RELOAD_WATCHER ||= cf::async {	4021	$RELOAD_WATCHER ||= cf::async {
3871	Coro::AIO::aio_wait cache_extensions;	4022	Coro::AIO::aio_wait cache_extensions;
3872		4023
3873	$RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {	4024	$RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3874	do_reload_perl;	4025	do_reload_perl;
3875	undef $RELOAD_WATCHER;	4026	undef $RELOAD_WATCHER;
3876	};	4027	};
3877	};	4028	};
3878	}	4029	}
…		…
3887	reload_perl;	4038	reload_perl;
3888	};	4039	};
3889	}	4040	}
3890	};	4041	};
3891		4042
3892	unshift @INC, $LIBDIR;	4043	#############################################################################
3893		4044
3894	my $bug_warning = 0;	4045	my $bug_warning = 0;
3895		4046
3896	our @WAIT_FOR_TICK;	4047	our @WAIT_FOR_TICK;
3897	our @WAIT_FOR_TICK_BEGIN;	4048	our @WAIT_FOR_TICK_BEGIN;
3898		4049
3899	sub wait_for_tick {	4050	sub wait_for_tick() {
3900	return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;	4051	return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3901		4052
3902	my $signal = new Coro::Signal;	4053	my $signal = new Coro::Signal;
3903	push @WAIT_FOR_TICK, $signal;	4054	push @WAIT_FOR_TICK, $signal;
3904	$signal->wait;	4055	$signal->wait;
3905	}	4056	}
3906		4057
3907	sub wait_for_tick_begin {	4058	sub wait_for_tick_begin() {
3908	return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;	4059	return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3909		4060
3910	my $signal = new Coro::Signal;	4061	my $signal = new Coro::Signal;
3911	push @WAIT_FOR_TICK_BEGIN, $signal;	4062	push @WAIT_FOR_TICK_BEGIN, $signal;
3912	$signal->wait;	4063	$signal->wait;
…		…
3919	return;	4070	return;
3920	}	4071	}
3921		4072
3922	cf::server_tick; # one server iteration	4073	cf::server_tick; # one server iteration
3923		4074
3924	#for(1..3e6){} EV::now_update; $NOW=EV::now; # generate load #d#	4075	#for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3925		4076
3926	if ($NOW >= $NEXT_RUNTIME_WRITE) {	4077	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3927	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;	4078	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3928	Coro::async_pool {	4079	Coro::async_pool {
3929	$Coro::current->{desc} = "runtime saver";	4080	$Coro::current->{desc} = "runtime saver";
3930	write_runtime_sync	4081	write_runtime_sync
3931	or warn "ERROR: unable to write runtime file: $!";	4082	or error "ERROR: unable to write runtime file: $!";
3932	};	4083	};
3933	}	4084	}
3934		4085
3935	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	4086	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3936	$sig->send;	4087	$sig->send;
…		…
3944		4095
3945	if (0) {	4096	if (0) {
3946	if ($NEXT_TICK) {	4097	if ($NEXT_TICK) {
3947	my $jitter = $TICK_START - $NEXT_TICK;	4098	my $jitter = $TICK_START - $NEXT_TICK;
3948	$JITTER = $JITTER * 0.75 + $jitter * 0.25;	4099	$JITTER = $JITTER * 0.75 + $jitter * 0.25;
3949	warn "jitter $JITTER\n";#d#	4100	debug "jitter $JITTER\n";#d#
3950	}	4101	}
3951	}	4102	}
3952	}	4103	}
3953		4104
3954	{	4105	{
3955	# configure BDB	4106	# configure BDB
3956		4107
3957	BDB::min_parallel 8;	4108	BDB::min_parallel 16;
3958	BDB::max_poll_reqs $TICK * 0.1;	4109	BDB::max_poll_reqs $TICK * 0.1;
3959	$AnyEvent::BDB::WATCHER->priority (1);	4110	$AnyEvent::BDB::WATCHER->priority (1);
3960		4111
3961	unless ($DB_ENV) {	4112	unless ($DB_ENV) {
3962	$DB_ENV = BDB::db_env_create;	4113	$DB_ENV = BDB::db_env_create;

Diff Legend

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