[ViewVC] Diff of: cvs/deliantra/server/lib/cf.pm

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.466 by root, Thu Jan 8 03:03:24 2009 UTC vs.
Revision 1.529 by root, Wed Apr 28 11:28:22 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	6	# Deliantra is free software: you can redistribute it and/or modify it under
7	# it under the terms of the GNU General Public License as published by	7	# the terms of the Affero GNU General Public License as published by the
8	# the Free Software Foundation, either version 3 of the License, or	8	# Free Software Foundation, either version 3 of the License, or (at your
9	# (at your option) any later version.	9	# option) any later version.
10	#	10	#
11	# This program is distributed in the hope that it will be useful,	11	# This program is distributed in the hope that it will be useful,
12	# but WITHOUT ANY WARRANTY; without even the implied warranty of	12	# but WITHOUT ANY WARRANTY; without even the implied warranty of
13	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the	13	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14	# GNU General Public License for more details.	14	# GNU General Public License for more details.
15	#	15	#
16	# You should have received a copy of the GNU General Public License	16	# You should have received a copy of the Affero GNU General Public License
17	# along with this program. If not, see <http://www.gnu.org/licenses/>.	17	# and the GNU General Public License along with this program. If not, see
		18	# <http://www.gnu.org/licenses/>.
18	#	19	#
19	# The authors can be reached via e-mail to <support@deliantra.net>	20	# The authors can be reached via e-mail to <support@deliantra.net>
20	#	21	#
21		22
22	package cf;	23	package cf;
23		24
24	use 5.10.0;	25	use 5.10.0;
25	use utf8;	26	use utf8;
31	use EV;	32	use EV;
32	use Opcode;	33	use Opcode;
33	use Safe;	34	use Safe;
34	use Safe::Hole;	35	use Safe::Hole;
35	use Storable ();	36	use Storable ();
		37	use Carp ();
36		38
37	use Guard ();	39	use Guard ();
38	use Coro ();	40	use Coro ();
39	use Coro::State;	41	use Coro::State;
40	use Coro::Handle;	42	use Coro::Handle;
…		…
51	use Coro::Util ();	53	use Coro::Util ();
52		54
53	use JSON::XS 2.01 ();	55	use JSON::XS 2.01 ();
54	use BDB ();	56	use BDB ();
55	use Data::Dumper;	57	use Data::Dumper;
56	use Digest::MD5;
57	use Fcntl;	58	use Fcntl;
58	use YAML ();	59	use YAML::XS ();
59	use IO::AIO ();	60	use IO::AIO ();
60	use Time::HiRes;	61	use Time::HiRes;
61	use Compress::LZF;	62	use Compress::LZF;
62	use Digest::MD5 ();	63	use Digest::MD5 ();
63		64
…		…
71	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority	72	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
72		73
73	# make sure c-lzf reinitialises itself	74	# make sure c-lzf reinitialises itself
74	Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";	75	Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
75	Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later	76	Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
		77
		78	# strictly for debugging
		79	$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
76		80
77	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	81	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
78		82
79	our %COMMAND = ();	83	our %COMMAND = ();
80	our %COMMAND_TIME = ();	84	our %COMMAND_TIME = ();
…		…
85	our %EXT_CORO = (); # coroutines bound to extensions	89	our %EXT_CORO = (); # coroutines bound to extensions
86	our %EXT_MAP = (); # pluggable maps	90	our %EXT_MAP = (); # pluggable maps
87		91
88	our $RELOAD; # number of reloads so far, non-zero while in reload	92	our $RELOAD; # number of reloads so far, non-zero while in reload
89	our @EVENT;	93	our @EVENT;
		94	our @REFLECT; # set by XS
		95	our %REFLECT; # set by us
90		96
91	our $CONFDIR = confdir;	97	our $CONFDIR = confdir;
92	our $DATADIR = datadir;	98	our $DATADIR = datadir;
93	our $LIBDIR = "$DATADIR/ext";	99	our $LIBDIR = "$DATADIR/ext";
94	our $PODDIR = "$DATADIR/pod";	100	our $PODDIR = "$DATADIR/pod";
…		…
102	our $PIDFILE = "$LOCALDIR/pid";	108	our $PIDFILE = "$LOCALDIR/pid";
103	our $RUNTIMEFILE = "$LOCALDIR/runtime";	109	our $RUNTIMEFILE = "$LOCALDIR/runtime";
104		110
105	our %RESOURCE;	111	our %RESOURCE;
106		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;
		118
107	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	119	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
108	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	120	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
109	our $NEXT_TICK;	121	our $NEXT_TICK;
110	our $USE_FSYNC = 1; # use fsync to write maps - default off	122	our $USE_FSYNC = 1; # use fsync to write maps - default on
111		123
112	our $BDB_DEADLOCK_WATCHER;	124	our $BDB_DEADLOCK_WATCHER;
113	our $BDB_CHECKPOINT_WATCHER;	125	our $BDB_CHECKPOINT_WATCHER;
114	our $BDB_TRICKLE_WATCHER;	126	our $BDB_TRICKLE_WATCHER;
115	our $DB_ENV;	127	our $DB_ENV;
116		128
117	our @EXTRA_MODULES = qw(pod mapscript);	129	our @EXTRA_MODULES = qw(pod match mapscript);
118		130
119	our %CFG;	131	our %CFG;
120		132
121	our $UPTIME; $UPTIME \|\|= time;	133	our $UPTIME; $UPTIME \|\|= time;
122	our $RUNTIME;	134	our $RUNTIME;
…		…
134	our $JITTER; # average jitter	146	our $JITTER; # average jitter
135	our $TICK_START; # for load detecting purposes	147	our $TICK_START; # for load detecting purposes
136		148
137	our @POST_INIT;	149	our @POST_INIT;
138		150
139	our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow)	151	our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
		152	our $REALLY_UNLOOP; # never set to true, please :)
140		153
141	binmode STDOUT;	154	binmode STDOUT;
142	binmode STDERR;	155	binmode STDERR;
143		156
144	# read virtual server time, if available	157	# read virtual server time, if available
…		…
146	open my $fh, "<", $RUNTIMEFILE	159	open my $fh, "<", $RUNTIMEFILE
147	or die "unable to read $RUNTIMEFILE file: $!";	160	or die "unable to read $RUNTIMEFILE file: $!";
148	$RUNTIME = <$fh> + 0.;	161	$RUNTIME = <$fh> + 0.;
149	}	162	}
150		163
		164	eval "sub TICK() { $TICK } 1" or die;
		165
151	mkdir $_	166	mkdir $_
152	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;	167	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
153		168
154	our $EMERGENCY_POSITION;	169	our $EMERGENCY_POSITION;
155		170
156	sub cf::map::normalise;	171	sub cf::map::normalise;
		172
		173	sub in_main() {
		174	$Coro::current == $Coro::main
		175	}
		176
		177	#############################################################################
		178
		179	%REFLECT = ();
		180	for (@REFLECT) {
		181	my $reflect = JSON::XS::decode_json $_;
		182	$REFLECT{$reflect->{class}} = $reflect;
		183	}
		184
		185	# this is decidedly evil
		186	$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
157		187
158	#############################################################################	188	#############################################################################
159		189
160	=head2 GLOBAL VARIABLES	190	=head2 GLOBAL VARIABLES
161		191
…		…
208	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 process
209	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.
210		240
211	=item @cf::INVOKE_RESULTS	241	=item @cf::INVOKE_RESULTS
212		242
213	This array contains the results of the last C<invoke ()> call. When	243	This array contains the results of the last C<invoke ()> call. When
214	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of	244	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
215	that call.	245	that call.
216		246
		247	=item %cf::REFLECT
		248
		249	Contains, for each (C++) class name, a hash reference with information
		250	about object members (methods, scalars, arrays and flags) and other
		251	metadata, which is useful for introspection.
		252
217	=back	253	=back
218		254
219	=cut	255	=cut
220		256
221	BEGIN {	257	$Coro::State::WARNHOOK = sub {
222	*CORE::GLOBAL::warn = sub {
223	my $msg = join "", @_;	258	my $msg = join "", @_;
224		259
225	$msg .= "\n"	260	$msg .= "\n"
226	unless $msg =~ /\n$/;	261	unless $msg =~ /\n$/;
227		262
228	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;	263	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
229		264
230	LOG llevError, $msg;	265	LOG llevError, $msg;
231	};	266	};
232	}
233		267
234	$Coro::State::DIEHOOK = sub {	268	$Coro::State::DIEHOOK = sub {
235	return unless $^S eq 0; # "eq", not "=="	269	return unless $^S eq 0; # "eq", not "=="
236		270
237	if ($Coro::current == $Coro::main) {#d#	271	warn Carp::longmess $_[0];
		272
		273	if (in_main) {#d#
238	warn "DIEHOOK called in main context, Coro bug?\n";#d#	274	warn "DIEHOOK called in main context, Coro bug?\n";#d#
239	return;#d#	275	return;#d#
240	}#d#	276	}#d#
241		277
242	# kill coroutine otherwise	278	# kill coroutine otherwise
243	warn Carp::longmess $_[0];
244	Coro::terminate	279	Coro::terminate
245	};	280	};
246
247	$SIG{__DIE__} = sub { }; #d#?
248		281
249	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	282	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
250	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';	283	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
251	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';	284	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
252	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';	285	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
…		…
266	)) {	299	)) {
267	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	300	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
268	}	301	}
269		302
270	$EV::DIED = sub {	303	$EV::DIED = sub {
271	warn "error in event callback: @_";	304	Carp::cluck "error in event callback: @_";
272	};	305	};
273		306
274	#############################################################################	307	#############################################################################
275		308
276	=head2 UTILITY FUNCTIONS	309	=head2 UTILITY FUNCTIONS
…		…
373	}	406	}
374		407
375	=item cf::periodic $interval, $cb	408	=item cf::periodic $interval, $cb
376		409
377	Like EV::periodic, but randomly selects a starting point so that the actions	410	Like EV::periodic, but randomly selects a starting point so that the actions
378	get spread over timer.	411	get spread over time.
379		412
380	=cut	413	=cut
381		414
382	sub periodic($$) {	415	sub periodic($$) {
383	my ($interval, $cb) = @_;	416	my ($interval, $cb) = @_;
…		…
400		433
401	=cut	434	=cut
402		435
403	our @SLOT_QUEUE;	436	our @SLOT_QUEUE;
404	our $SLOT_QUEUE;	437	our $SLOT_QUEUE;
		438	our $SLOT_DECAY = 0.9;
405		439
406	$SLOT_QUEUE->cancel if $SLOT_QUEUE;	440	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
407	$SLOT_QUEUE = Coro::async {	441	$SLOT_QUEUE = Coro::async {
408	$Coro::current->desc ("timeslot manager");	442	$Coro::current->desc ("timeslot manager");
409		443
410	my $signal = new Coro::Signal;	444	my $signal = new Coro::Signal;
		445	my $busy;
411		446
412	while () {	447	while () {
413	next_job:	448	next_job:
		449
414	my $avail = cf::till_tick;	450	my $avail = cf::till_tick;
415	if ($avail > 0.01) {	451
416	for (0 .. $#SLOT_QUEUE) {	452	for (0 .. $#SLOT_QUEUE) {
417	if ($SLOT_QUEUE[$_][0] < $avail) {	453	if ($SLOT_QUEUE[$_][0] <= $avail) {
		454	$busy = 0;
418	my $job = splice @SLOT_QUEUE, $_, 1, ();	455	my $job = splice @SLOT_QUEUE, $_, 1, ();
419	$job->[2]->send;	456	$job->[2]->send;
420	Coro::cede;	457	Coro::cede;
421	goto next_job;	458	goto next_job;
422	}	459	} else {
		460	$SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
423	}	461	}
424	}	462	}
425		463
426	if (@SLOT_QUEUE) {	464	if (@SLOT_QUEUE) {
427	# we do not use wait_for_tick() as it returns immediately when tick is inactive	465	# we do not use wait_for_tick() as it returns immediately when tick is inactive
428	push @cf::WAIT_FOR_TICK, $signal;	466	push @cf::WAIT_FOR_TICK, $signal;
429	$signal->wait;	467	$signal->wait;
430	} else {	468	} else {
		469	$busy = 0;
431	Coro::schedule;	470	Coro::schedule;
432	}	471	}
433	}	472	}
434	};	473	};
435		474
436	sub get_slot($;$$) {	475	sub get_slot($;$$) {
437	return if tick_inhibit \|\| $Coro::current == $Coro::main;	476	return if tick_inhibit \|\| $Coro::current == $Coro::main;
438		477
439	my ($time, $pri, $name) = @_;	478	my ($time, $pri, $name) = @_;
440		479
441	$time = $TICK * .6 if $time > $TICK * .6;	480	$time = clamp $time, 0.01, $TICK * .6;
		481
442	my $sig = new Coro::Signal;	482	my $sig = new Coro::Signal;
443		483
444	push @SLOT_QUEUE, [$time, $pri, $sig, $name];	484	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
445	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;	485	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
446	$SLOT_QUEUE->ready;	486	$SLOT_QUEUE->ready;
…		…
473		513
474	sub sync_job(&) {	514	sub sync_job(&) {
475	my ($job) = @_;	515	my ($job) = @_;
476		516
477	if ($Coro::current == $Coro::main) {	517	if ($Coro::current == $Coro::main) {
478	my $time = EV::time;	518	my $time = AE::time;
479		519
480	# this is the main coro, too bad, we have to block	520	# this is the main coro, too bad, we have to block
481	# till the operation succeeds, freezing the server :/	521	# till the operation succeeds, freezing the server :/
482		522
483	LOG llevError, Carp::longmess "sync job";#d#	523	LOG llevError, Carp::longmess "sync job";#d#
…		…
500	} else {	540	} else {
501	EV::loop EV::LOOP_ONESHOT;	541	EV::loop EV::LOOP_ONESHOT;
502	}	542	}
503	}	543	}
504		544
505	my $time = EV::time - $time;	545	my $time = AE::time - $time;
506		546
507	$TICK_START += $time; # do not account sync jobs to server load	547	$TICK_START += $time; # do not account sync jobs to server load
508		548
509	wantarray ? @res : $res[0]	549	wantarray ? @res : $res[0]
510	} else {	550	} else {
…		…
554	reset_signals;	594	reset_signals;
555	&$cb	595	&$cb
556	}, @args;	596	}, @args;
557		597
558	wantarray ? @res : $res[-1]	598	wantarray ? @res : $res[-1]
		599	}
		600
		601	sub objinfo {
		602	(
		603	"counter value" => cf::object::object_count,
		604	"objects created" => cf::object::create_count,
		605	"objects destroyed" => cf::object::destroy_count,
		606	"freelist size" => cf::object::free_count,
		607	"allocated objects" => cf::object::objects_size,
		608	"active objects" => cf::object::actives_size,
		609	)
559	}	610	}
560		611
561	=item $coin = coin_from_name $name	612	=item $coin = coin_from_name $name
562		613
563	=cut	614	=cut
…		…
1144		1195
1145	sync_job {	1196	sync_job {
1146	if (length $$rdata) {	1197	if (length $$rdata) {
1147	utf8::decode (my $decname = $filename);	1198	utf8::decode (my $decname = $filename);
1148	warn sprintf "saving %s (%d,%d)\n",	1199	warn sprintf "saving %s (%d,%d)\n",
1149	$decname, length $$rdata, scalar @$objs;	1200	$decname, length $$rdata, scalar @$objs
		1201	if $VERBOSE_IO;
1150		1202
1151	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {	1203	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {
1152	aio_chmod $fh, SAVE_MODE;	1204	aio_chmod $fh, SAVE_MODE;
1153	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1205	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1154	aio_fsync $fh if $cf::USE_FSYNC;	1206	if ($cf::USE_FSYNC) {
		1207	aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE \| IO::AIO::SYNC_FILE_RANGE_WRITE \| IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
		1208	aio_fsync $fh;
		1209	}
1155	aio_close $fh;	1210	aio_close $fh;
1156		1211
1157	if (@$objs) {	1212	if (@$objs) {
1158	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {	1213	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {
1159	aio_chmod $fh, SAVE_MODE;	1214	aio_chmod $fh, SAVE_MODE;
1160	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };	1215	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1161	aio_write $fh, 0, (length $data), $data, 0;	1216	aio_write $fh, 0, (length $data), $data, 0;
1162	aio_fsync $fh if $cf::USE_FSYNC;	1217	if ($cf::USE_FSYNC) {
		1218	aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE \| IO::AIO::SYNC_FILE_RANGE_WRITE \| IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
		1219	aio_fsync $fh;
		1220	}
1163	aio_close $fh;	1221	aio_close $fh;
1164	aio_rename "$filename.pst~", "$filename.pst";	1222	aio_rename "$filename.pst~", "$filename.pst";
1165	}	1223	}
1166	} else {	1224	} else {
1167	aio_unlink "$filename.pst";	1225	aio_unlink "$filename.pst";
…		…
1205	$av = $st->{objs};	1263	$av = $st->{objs};
1206	}	1264	}
1207		1265
1208	utf8::decode (my $decname = $filename);	1266	utf8::decode (my $decname = $filename);
1209	warn sprintf "loading %s (%d,%d)\n",	1267	warn sprintf "loading %s (%d,%d)\n",
1210	$decname, length $data, scalar @{$av \|\| []};	1268	$decname, length $data, scalar @{$av \|\| []}
		1269	if $VERBOSE_IO;
1211		1270
1212	($data, $av)	1271	($data, $av)
1213	}	1272	}
1214		1273
1215	=head2 COMMAND CALLBACKS	1274	=head2 COMMAND CALLBACKS
…		…
1274	}	1333	}
1275		1334
1276	use File::Glob ();	1335	use File::Glob ();
1277		1336
1278	cf::player->attach (	1337	cf::player->attach (
1279	on_command => sub {	1338	on_unknown_command => sub {
1280	my ($pl, $name, $params) = @_;	1339	my ($pl, $name, $params) = @_;
1281		1340
1282	my $cb = $COMMAND{$name}	1341	my $cb = $COMMAND{$name}
1283	or return;	1342	or return;
1284		1343
…		…
1318		1377
1319	# "readahead" all extensions	1378	# "readahead" all extensions
1320	sub cache_extensions {	1379	sub cache_extensions {
1321	my $grp = IO::AIO::aio_group;	1380	my $grp = IO::AIO::aio_group;
1322		1381
1323	add $grp IO::AIO::aio_readdir $LIBDIR, sub {	1382	add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1324	for (grep /\.ext$/, @{$_[0]}) {	1383	for (grep /\.ext$/, @{$_[0]}) {
1325	add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;	1384	add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1326	}	1385	}
1327	};	1386	};
1328		1387
…		…
1363	. "\n};\n1";	1422	. "\n};\n1";
1364		1423
1365	$todo{$base} = \%ext;	1424	$todo{$base} = \%ext;
1366	}	1425	}
1367		1426
		1427	my $pass = 0;
1368	my %done;	1428	my %done;
1369	while (%todo) {	1429	while (%todo) {
1370	my $progress;	1430	my $progress;
1371		1431
		1432	++$pass;
		1433
		1434	ext:
1372	while (my ($k, $v) = each %todo) {	1435	while (my ($k, $v) = each %todo) {
1373	for (split /,\s*/, $v->{meta}{depends}) {	1436	for (split /,\s*/, $v->{meta}{depends}) {
1374	goto skip	1437	next ext
1375	unless exists $done{$_};	1438	unless exists $done{$_};
1376	}	1439	}
1377		1440
1378	warn "... loading '$k' into '$v->{pkg}'\n";	1441	warn "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1379		1442
1380	unless (eval $v->{source}) {	1443	my $active = eval $v->{source};
		1444
		1445	if (length $@) {
1381	my $msg = $@ ? "$v->{path}: $@\n"	1446	warn "$v->{path}: $@\n";
1382	: "$v->{base}: extension inactive.\n";
1383		1447
1384	if (exists $v->{meta}{mandatory}) {
1385	warn $msg;
1386	cf::cleanup "mandatory extension failed to load, exiting.";	1448	cf::cleanup "mandatory extension '$k' failed to load, exiting."
1387	}	1449	if exists $v->{meta}{mandatory};
1388		1450
1389	warn $msg;	1451	warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
		1452	delete $todo{$k};
		1453	} else {
		1454	$done{$k} = delete $todo{$k};
		1455	push @EXTS, $v->{pkg};
		1456	$progress = 1;
		1457
		1458	warn "$v->{base}: extension inactive.\n"
		1459	unless $active;
1390	}	1460	}
1391
1392	$done{$k} = delete $todo{$k};
1393	push @EXTS, $v->{pkg};
1394	$progress = 1;
1395	}	1461	}
1396		1462
1397	skip:	1463	unless ($progress) {
1398	die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"	1464	warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1399	unless $progress;	1465
		1466	while (my ($k, $v) = each %todo) {
		1467	cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
		1468	if exists $v->{meta}{mandatory};
		1469	}
		1470	}
1400	}	1471	}
1401	};	1472	};
1402	}	1473	}
1403		1474
1404	#############################################################################	1475	#############################################################################
…		…
1488	$cf::PLAYER{$login} = $pl	1559	$cf::PLAYER{$login} = $pl
1489	}	1560	}
1490	}	1561	}
1491	}	1562	}
1492		1563
		1564	cf::player->attach (
		1565	on_load => sub {
		1566	my ($pl, $path) = @_;
		1567
		1568	# restore slots saved in save, below
		1569	my $slots = delete $pl->{_slots};
		1570
		1571	$pl->ob->current_weapon ($slots->[0]);
		1572	$pl->combat_ob ($slots->[1]);
		1573	$pl->ranged_ob ($slots->[2]);
		1574	},
		1575	);
		1576
1493	sub save($) {	1577	sub save($) {
1494	my ($pl) = @_;	1578	my ($pl) = @_;
1495		1579
1496	return if $pl->{deny_save};	1580	return if $pl->{deny_save};
1497		1581
…		…
1502		1586
1503	aio_mkdir playerdir $pl, 0770;	1587	aio_mkdir playerdir $pl, 0770;
1504	$pl->{last_save} = $cf::RUNTIME;	1588	$pl->{last_save} = $cf::RUNTIME;
1505		1589
1506	cf::get_slot 0.01;	1590	cf::get_slot 0.01;
		1591
		1592	# save slots, to be restored later
		1593	local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1507		1594
1508	$pl->save_pl ($path);	1595	$pl->save_pl ($path);
1509	cf::cede_to_tick;	1596	cf::cede_to_tick;
1510	}	1597	}
1511		1598
…		…
1548	$pl->password ("*"); # this should lock out the player until we have nuked the dir	1635	$pl->password ("*"); # this should lock out the player until we have nuked the dir
1549		1636
1550	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;	1637	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1551	$pl->deactivate;	1638	$pl->deactivate;
1552	my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;	1639	my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1553	$pl->ob->check_score;
1554	$pl->invoke (cf::EVENT_PLAYER_QUIT);	1640	$pl->invoke (cf::EVENT_PLAYER_QUIT);
1555	$pl->ns->destroy if $pl->ns;	1641	$pl->ns->destroy if $pl->ns;
1556		1642
1557	my $path = playerdir $pl;	1643	my $path = playerdir $pl;
1558	my $temp = "$path~$cf::RUNTIME~deleting~";	1644	my $temp = "$path~$cf::RUNTIME~deleting~";
…		…
1613	\@logins	1699	\@logins
1614	}	1700	}
1615		1701
1616	=item $player->maps	1702	=item $player->maps
1617		1703
		1704	=item cf::player::maps $login
		1705
1618	Returns an arrayref of map paths that are private for this	1706	Returns an arrayref of map paths that are private for this
1619	player. May block.	1707	player. May block.
1620		1708
1621	=cut	1709	=cut
1622		1710
…		…
1684	=cut	1772	=cut
1685		1773
1686	sub find_by_path($) {	1774	sub find_by_path($) {
1687	my ($path) = @_;	1775	my ($path) = @_;
1688		1776
		1777	$path =~ s/^~[^\/]*//; # skip ~login
		1778
1689	my ($match, $specificity);	1779	my ($match, $specificity);
1690		1780
1691	for my $region (list) {	1781	for my $region (list) {
1692	if ($region->{match} && $path =~ $region->{match}) {	1782	if ($region->{match} && $path =~ $region->{match}) {
1693	($match, $specificity) = ($region, $region->specificity)	1783	($match, $specificity) = ($region, $region->specificity)
…		…
1724	my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM	1814	my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1725		1815
1726	# mit "rum" bekleckern, nicht	1816	# mit "rum" bekleckern, nicht
1727	$self->_create_random_map (	1817	$self->_create_random_map (
1728	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},	1818	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1729	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},	1819	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1730	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},	1820	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1731	$rmp->{exit_on_final_map},	1821	$rmp->{exit_on_final_map},
1732	$rmp->{xsize}, $rmp->{ysize},	1822	$rmp->{xsize}, $rmp->{ysize},
1733	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},	1823	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1734	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},	1824	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
…		…
1756		1846
1757	$EXT_MAP{$pkg} = [$prio, qr<$regex>];	1847	$EXT_MAP{$pkg} = [$prio, qr<$regex>];
1758	}	1848	}
1759		1849
1760	# also paths starting with '/'	1850	# also paths starting with '/'
1761	$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];	1851	$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1762		1852
1763	sub thawer_merge {	1853	sub thawer_merge {
1764	my ($self, $merge) = @_;	1854	my ($self, $merge) = @_;
1765		1855
1766	# we have to keep some variables in memory intact	1856	# we have to keep some variables in memory intact
…		…
1980		2070
1981	$cf::MAP{$path} = $map	2071	$cf::MAP{$path} = $map
1982	}	2072	}
1983	}	2073	}
1984		2074
1985	sub pre_load { }	2075	sub pre_load { }
1986	sub post_load { }	2076	#sub post_load { } # XS
1987		2077
1988	sub load {	2078	sub load {
1989	my ($self) = @_;	2079	my ($self) = @_;
1990		2080
1991	local $self->{deny_reset} = 1; # loading can take a long time	2081	local $self->{deny_reset} = 1; # loading can take a long time
…		…
2048	}	2138	}
2049		2139
2050	$self->post_load;	2140	$self->post_load;
2051	}	2141	}
2052		2142
		2143	# customize the map for a given player, i.e.
		2144	# return the _real_ map. used by e.g. per-player
		2145	# maps to change the path to ~playername/mappath
2053	sub customise_for {	2146	sub customise_for {
2054	my ($self, $ob) = @_;	2147	my ($self, $ob) = @_;
2055		2148
2056	return find "~" . $ob->name . "/" . $self->{path}	2149	return find "~" . $ob->name . "/" . $self->{path}
2057	if $self->per_player;	2150	if $self->per_player;
…		…
2073	or next;	2166	or next;
2074	$neigh = find $neigh, $map	2167	$neigh = find $neigh, $map
2075	or next;	2168	or next;
2076	$neigh->load;	2169	$neigh->load;
2077		2170
		2171	# now find the diagonal neighbours
2078	push @neigh,	2172	push @neigh,
2079	[$neigh->tile_path (($_ + 3) % 4), $neigh],	2173	[$neigh->tile_path (($_ + 3) % 4), $neigh],
2080	[$neigh->tile_path (($_ + 1) % 4), $neigh];	2174	[$neigh->tile_path (($_ + 1) % 4), $neigh];
2081	}	2175	}
2082		2176
…		…
2134	$MAP_PREFETCHER->prio (6);	2228	$MAP_PREFETCHER->prio (6);
2135		2229
2136	()	2230	()
2137	}	2231	}
2138		2232
		2233	# common code, used by both ->save and ->swapout
2139	sub save {	2234	sub _save {
2140	my ($self) = @_;	2235	my ($self) = @_;
2141
2142	my $lock = cf::lock_acquire "map_data:$self->{path}";
2143		2236
2144	$self->{last_save} = $cf::RUNTIME;	2237	$self->{last_save} = $cf::RUNTIME;
2145		2238
2146	return unless $self->dirty;	2239	return unless $self->dirty;
2147		2240
…		…
2167	} else {	2260	} else {
2168	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS \| cf::IO_UNIQUES);	2261	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS \| cf::IO_UNIQUES);
2169	}	2262	}
2170	}	2263	}
2171		2264
		2265	sub save {
		2266	my ($self) = @_;
		2267
		2268	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2269
		2270	$self->_save;
		2271	}
		2272
2172	sub swap_out {	2273	sub swap_out {
2173	my ($self) = @_;	2274	my ($self) = @_;
2174		2275
2175	# save first because save cedes
2176	$self->save;
2177
2178	my $lock = cf::lock_acquire "map_data:$self->{path}";	2276	my $lock = cf::lock_acquire "map_data:$self->{path}";
2179		2277
2180	return if $self->players;
2181	return if $self->in_memory != cf::MAP_ACTIVE;	2278	return if $self->in_memory != cf::MAP_ACTIVE;
2182	return if $self->{deny_save};	2279	return if $self->{deny_save};
		2280	return if $self->players;
2183		2281
		2282	# first deactivate the map and "unlink" it from the core
		2283	$self->deactivate;
		2284	$_->clear_links_to ($self) for values %cf::MAP;
2184	$self->in_memory (cf::MAP_SWAPPED);	2285	$self->in_memory (cf::MAP_SWAPPED);
		2286
		2287	# then atomically save
		2288	$self->_save;
		2289
		2290	# then free the map
		2291	$self->clear;
		2292	}
		2293
		2294	sub reset_at {
		2295	my ($self) = @_;
		2296
		2297	# TODO: safety, remove and allow resettable per-player maps
		2298	return 1e99 if $self->{deny_reset};
		2299
		2300	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
		2301	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;
		2302
		2303	$time + $to
		2304	}
		2305
		2306	sub should_reset {
		2307	my ($self) = @_;
		2308
		2309	$self->reset_at <= $cf::RUNTIME
		2310	}
		2311
		2312	sub reset {
		2313	my ($self) = @_;
		2314
		2315	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2316
		2317	return if $self->players;
		2318
		2319	warn "resetting map ", $self->path, "\n";
		2320
		2321	$self->in_memory (cf::MAP_SWAPPED);
		2322
		2323	# need to save uniques path
		2324	unless ($self->{deny_save}) {
		2325	my $uniq = $self->uniq_path; utf8::encode $uniq;
		2326
		2327	$self->_save_objects ($uniq, cf::IO_UNIQUES)
		2328	if $uniq;
		2329	}
		2330
		2331	delete $cf::MAP{$self->path};
2185		2332
2186	$self->deactivate;	2333	$self->deactivate;
2187	$_->clear_links_to ($self) for values %cf::MAP;	2334	$_->clear_links_to ($self) for values %cf::MAP;
2188	$self->clear;	2335	$self->clear;
2189	}
2190
2191	sub reset_at {
2192	my ($self) = @_;
2193
2194	# TODO: safety, remove and allow resettable per-player maps
2195	return 1e99 if $self->{deny_reset};
2196
2197	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2198	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;
2199
2200	$time + $to
2201	}
2202
2203	sub should_reset {
2204	my ($self) = @_;
2205
2206	$self->reset_at <= $cf::RUNTIME
2207	}
2208
2209	sub reset {
2210	my ($self) = @_;
2211
2212	my $lock = cf::lock_acquire "map_data:$self->{path}";
2213
2214	return if $self->players;
2215
2216	warn "resetting map ", $self->path;
2217
2218	$self->in_memory (cf::MAP_SWAPPED);
2219
2220	# need to save uniques path
2221	unless ($self->{deny_save}) {
2222	my $uniq = $self->uniq_path; utf8::encode $uniq;
2223
2224	$self->_save_objects ($uniq, cf::IO_UNIQUES)
2225	if $uniq;
2226	}
2227
2228	delete $cf::MAP{$self->path};
2229
2230	$self->deactivate;
2231	$_->clear_links_to ($self) for values %cf::MAP;
2232	$self->clear;
2233		2336
2234	$self->unlink_save;	2337	$self->unlink_save;
2235	$self->destroy;	2338	$self->destroy;
2236	}	2339	}
2237		2340
…		…
2245		2348
2246	delete $cf::MAP{$self->path};	2349	delete $cf::MAP{$self->path};
2247		2350
2248	$self->unlink_save;	2351	$self->unlink_save;
2249		2352
2250	bless $self, "cf::map";	2353	bless $self, "cf::map::wrap";
2251	delete $self->{deny_reset};	2354	delete $self->{deny_reset};
2252	$self->{deny_save} = 1;	2355	$self->{deny_save} = 1;
2253	$self->reset_timeout (1);	2356	$self->reset_timeout (1);
2254	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2357	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2255		2358
…		…
2312	: normalise $_	2415	: normalise $_
2313	} @{ aio_readdir $UNIQUEDIR or [] }	2416	} @{ aio_readdir $UNIQUEDIR or [] }
2314	]	2417	]
2315	}	2418	}
2316		2419
		2420	=item cf::map::static_maps
		2421
		2422	Returns an arrayref if paths of all static maps (all preinstalled F<.map>
		2423	file in the shared directory excluding F</styles> and F</editor>). May
		2424	block.
		2425
		2426	=cut
		2427
		2428	sub static_maps() {
		2429	my @dirs = "";
		2430	my @maps;
		2431
		2432	while (@dirs) {
		2433	my $dir = shift @dirs;
		2434
		2435	next if $dir eq "/styles" \|\| $dir eq "/editor";
		2436
		2437	my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
		2438	or return;
		2439
		2440	for (@$files) {
		2441	s/\.map$// or next;
		2442	utf8::decode $_;
		2443	push @maps, "$dir/$_";
		2444	}
		2445
		2446	push @dirs, map "$dir/$_", @$dirs;
		2447	}
		2448
		2449	\@maps
		2450	}
		2451
2317	=back	2452	=back
2318		2453
2319	=head3 cf::object	2454	=head3 cf::object
2320		2455
2321	=cut	2456	=cut
…		…
2386		2521
2387	our $SAY_CHANNEL = {	2522	our $SAY_CHANNEL = {
2388	id => "say",	2523	id => "say",
2389	title => "Map",	2524	title => "Map",
2390	reply => "say ",	2525	reply => "say ",
2391	tooltip => "Things said to and replied from npcs near you and other players on the same map only.",	2526	tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2392	};	2527	};
2393		2528
2394	our $CHAT_CHANNEL = {	2529	our $CHAT_CHANNEL = {
2395	id => "chat",	2530	id => "chat",
2396	title => "Chat",	2531	title => "Chat",
…		…
2453		2588
2454	Freezes the player and moves him/her to a special map (C<{link}>).	2589	Freezes the player and moves him/her to a special map (C<{link}>).
2455		2590
2456	The player should be reasonably safe there for short amounts of time (e.g.	2591	The player should be reasonably safe there for short amounts of time (e.g.
2457	for loading a map). You I<MUST> call C<leave_link> as soon as possible,	2592	for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2458	though, as the palyer cannot control the character while it is on the link	2593	though, as the player cannot control the character while it is on the link
2459	map.	2594	map.
2460		2595
2461	Will never block.	2596	Will never block.
2462		2597
2463	=item $player_object->leave_link ($map, $x, $y)	2598	=item $player_object->leave_link ($map, $x, $y)
…		…
2484	sub cf::object::player::enter_link {	2619	sub cf::object::player::enter_link {
2485	my ($self) = @_;	2620	my ($self) = @_;
2486		2621
2487	$self->deactivate_recursive;	2622	$self->deactivate_recursive;
2488		2623
		2624	++$self->{_link_recursion};
		2625
2489	return if UNIVERSAL::isa $self->map, "ext::map_link";	2626	return if UNIVERSAL::isa $self->map, "ext::map_link";
2490		2627
2491	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]	2628	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]
2492	if $self->map && $self->map->{path} ne "{link}";	2629	if $self->map && $self->map->{path} ne "{link}";
2493		2630
2494	$self->enter_map ($LINK_MAP \|\| link_map, 10, 10);	2631	$self->enter_map ($LINK_MAP \|\| link_map, 3, 3);
2495	}	2632	}
2496		2633
2497	sub cf::object::player::leave_link {	2634	sub cf::object::player::leave_link {
2498	my ($self, $map, $x, $y) = @_;	2635	my ($self, $map, $x, $y) = @_;
2499		2636
…		…
2516	($x, $y) = (-1, -1)	2653	($x, $y) = (-1, -1)
2517	unless (defined $x) && (defined $y);	2654	unless (defined $x) && (defined $y);
2518		2655
2519	# use -1 or undef as default coordinates, not 0, 0	2656	# use -1 or undef as default coordinates, not 0, 0
2520	($x, $y) = ($map->enter_x, $map->enter_y)	2657	($x, $y) = ($map->enter_x, $map->enter_y)
2521	if $x <=0 && $y <= 0;	2658	if $x <= 0 && $y <= 0;
2522		2659
2523	$map->load;	2660	$map->load;
2524	$map->load_neighbours;	2661	$map->load_neighbours;
2525		2662
2526	return unless $self->contr->active;	2663	return unless $self->contr->active;
2527	$self->flag (cf::FLAG_DEBUG, 0);#d# temp
2528	$self->activate_recursive;
2529		2664
2530	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2665	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2531	$self->enter_map ($map, $x, $y);	2666	if ($self->enter_map ($map, $x, $y)) {
2532	}	2667	# entering was successful
		2668	delete $self->{_link_recursion};
		2669	# only activate afterwards, to support waiting in hooks
		2670	$self->activate_recursive;
		2671	}
2533		2672
		2673	}
		2674
2534	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])	2675	=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2535		2676
2536	Moves the player to the given map-path and coordinates by first freezing	2677	Moves the player to the given map-path and coordinates by first freezing
2537	her, loading and preparing them map, calling the provided $check callback	2678	her, loading and preparing them map, calling the provided $check callback
2538	that has to return the map if sucecssful, and then unfreezes the player on	2679	that has to return the map if sucecssful, and then unfreezes the player on
2539	the new (success) or old (failed) map position. In either case, $done will	2680	the new (success) or old (failed) map position. In either case, $done will
…		…
2546		2687
2547	our $GOTOGEN;	2688	our $GOTOGEN;
2548		2689
2549	sub cf::object::player::goto {	2690	sub cf::object::player::goto {
2550	my ($self, $path, $x, $y, $check, $done) = @_;	2691	my ($self, $path, $x, $y, $check, $done) = @_;
		2692
		2693	if ($self->{_link_recursion} >= $MAX_LINKS) {
		2694	warn "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
		2695	$self->failmsg ("Something went wrong inside the server - please contact an administrator!");
		2696	($path, $x, $y) = @$EMERGENCY_POSITION;
		2697	}
2551		2698
2552	# do generation counting so two concurrent goto's will be executed in-order	2699	# do generation counting so two concurrent goto's will be executed in-order
2553	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2700	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2554		2701
2555	$self->enter_link;	2702	$self->enter_link;
…		…
2579	my $map = eval {	2726	my $map = eval {
2580	my $map = defined $path ? cf::map::find $path : undef;	2727	my $map = defined $path ? cf::map::find $path : undef;
2581		2728
2582	if ($map) {	2729	if ($map) {
2583	$map = $map->customise_for ($self);	2730	$map = $map->customise_for ($self);
2584	$map = $check->($map) if $check && $map;	2731	$map = $check->($map, $x, $y, $self) if $check && $map;
2585	} else {	2732	} else {
2586	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE \| cf::NDI_RED);	2733	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE \| cf::NDI_RED);
2587	}	2734	}
2588		2735
2589	$map	2736	$map
…		…
2597	if ($gen == $self->{_goto_generation}) {	2744	if ($gen == $self->{_goto_generation}) {
2598	delete $self->{_goto_generation};	2745	delete $self->{_goto_generation};
2599	$self->leave_link ($map, $x, $y);	2746	$self->leave_link ($map, $x, $y);
2600	}	2747	}
2601		2748
2602	$done->() if $done;	2749	$done->($self) if $done;
2603	})->prio (1);	2750	})->prio (1);
2604	}	2751	}
2605		2752
2606	=item $player_object->enter_exit ($exit_object)	2753	=item $player_object->enter_exit ($exit_object)
2607		2754
…		…
2724		2871
2725	utf8::encode $text;	2872	utf8::encode $text;
2726	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2873	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2727	}	2874	}
2728		2875
		2876	=item $client->send_big_packet ($pkt)
		2877
		2878	Like C<send_packet>, but tries to compress large packets, and fragments
		2879	them as required.
		2880
		2881	=cut
		2882
		2883	our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
		2884
		2885	sub cf::client::send_big_packet {
		2886	my ($self, $pkt) = @_;
		2887
		2888	# try lzf for large packets
		2889	$pkt = "lzf " . Compress::LZF::compress $pkt
		2890	if 1024 <= length $pkt and $self->{can_lzf};
		2891
		2892	# split very large packets
		2893	if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
		2894	$self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
		2895	$pkt = "frag";
		2896	}
		2897
		2898	$self->send_packet ($pkt);
		2899	}
		2900
2729	=item $client->send_msg ($channel, $msg, $color, [extra...])	2901	=item $client->send_msg ($channel, $msg, $color, [extra...])
2730		2902
2731	Send a drawinfo or msg packet to the client, formatting the msg for the	2903	Send a drawinfo or msg packet to the client, formatting the msg for the
2732	client if neccessary. C<$type> should be a string identifying the type of	2904	client if neccessary. C<$type> should be a string identifying the type of
2733	the message, with C<log> being the default. If C<$color> is negative, suppress	2905	the message, with C<log> being the default. If C<$color> is negative, suppress
…		…
2735		2907
2736	=cut	2908	=cut
2737		2909
2738	# non-persistent channels (usually the info channel)	2910	# non-persistent channels (usually the info channel)
2739	our %CHANNEL = (	2911	our %CHANNEL = (
		2912	"c/motd" => {
		2913	id => "infobox",
		2914	title => "MOTD",
		2915	reply => undef,
		2916	tooltip => "The message of the day",
		2917	},
2740	"c/identify" => {	2918	"c/identify" => {
2741	id => "infobox",	2919	id => "infobox",
2742	title => "Identify",	2920	title => "Identify",
2743	reply => undef,	2921	reply => undef,
2744	tooltip => "Items recently identified",	2922	tooltip => "Items recently identified",
…		…
2746	"c/examine" => {	2924	"c/examine" => {
2747	id => "infobox",	2925	id => "infobox",
2748	title => "Examine",	2926	title => "Examine",
2749	reply => undef,	2927	reply => undef,
2750	tooltip => "Signs and other items you examined",	2928	tooltip => "Signs and other items you examined",
		2929	},
		2930	"c/shopinfo" => {
		2931	id => "infobox",
		2932	title => "Shop Info",
		2933	reply => undef,
		2934	tooltip => "What your bargaining skill tells you about the shop",
2751	},	2935	},
2752	"c/book" => {	2936	"c/book" => {
2753	id => "infobox",	2937	id => "infobox",
2754	title => "Book",	2938	title => "Book",
2755	reply => undef,	2939	reply => undef,
…		…
2783	id => "infobox",	2967	id => "infobox",
2784	title => "Skills",	2968	title => "Skills",
2785	reply => undef,	2969	reply => undef,
2786	tooltip => "Shows your experience per skill and item power",	2970	tooltip => "Shows your experience per skill and item power",
2787	},	2971	},
		2972	"c/shopitems" => {
		2973	id => "infobox",
		2974	title => "Shop Items",
		2975	reply => undef,
		2976	tooltip => "Shows the items currently for sale in this shop",
		2977	},
2788	"c/resistances" => {	2978	"c/resistances" => {
2789	id => "infobox",	2979	id => "infobox",
2790	title => "Resistances",	2980	title => "Resistances",
2791	reply => undef,	2981	reply => undef,
2792	tooltip => "Shows your resistances",	2982	tooltip => "Shows your resistances",
…		…
2794	"c/pets" => {	2984	"c/pets" => {
2795	id => "infobox",	2985	id => "infobox",
2796	title => "Pets",	2986	title => "Pets",
2797	reply => undef,	2987	reply => undef,
2798	tooltip => "Shows information abotu your pets/a specific pet",	2988	tooltip => "Shows information abotu your pets/a specific pet",
		2989	},
		2990	"c/perceiveself" => {
		2991	id => "infobox",
		2992	title => "Perceive Self",
		2993	reply => undef,
		2994	tooltip => "You gained detailed knowledge about yourself",
2799	},	2995	},
2800	"c/uptime" => {	2996	"c/uptime" => {
2801	id => "infobox",	2997	id => "infobox",
2802	title => "Uptime",	2998	title => "Uptime",
2803	reply => undef,	2999	reply => undef,
…		…
2859	my $pkt = "msg "	3055	my $pkt = "msg "
2860	. $self->{json_coder}->encode (	3056	. $self->{json_coder}->encode (
2861	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]	3057	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2862	);	3058	);
2863		3059
2864	# try lzf for large packets
2865	$pkt = "lzf " . Compress::LZF::compress $pkt
2866	if 1024 <= length $pkt and $self->{can_lzf};
2867
2868	# split very large packets
2869	if (8192 < length $pkt and $self->{can_lzf}) {
2870	$self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2871	$pkt = "frag";
2872	}
2873
2874	$self->send_packet ($pkt);	3060	$self->send_big_packet ($pkt);
2875	}	3061	}
2876		3062
2877	=item $client->ext_msg ($type, @msg)	3063	=item $client->ext_msg ($type, @msg)
2878		3064
2879	Sends an ext event to the client.	3065	Sends an ext event to the client.
…		…
2882		3068
2883	sub cf::client::ext_msg($$@) {	3069	sub cf::client::ext_msg($$@) {
2884	my ($self, $type, @msg) = @_;	3070	my ($self, $type, @msg) = @_;
2885		3071
2886	if ($self->extcmd == 2) {	3072	if ($self->extcmd == 2) {
2887	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));	3073	$self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2888	} elsif ($self->extcmd == 1) { # TODO: remove	3074	} elsif ($self->extcmd == 1) { # TODO: remove
2889	push @msg, msgtype => "event_$type";	3075	push @msg, msgtype => "event_$type";
2890	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));	3076	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2891	}	3077	}
2892	}	3078	}
2893		3079
2894	=item $client->ext_reply ($msgid, @msg)	3080	=item $client->ext_reply ($msgid, @msg)
2895		3081
…		…
2899		3085
2900	sub cf::client::ext_reply($$@) {	3086	sub cf::client::ext_reply($$@) {
2901	my ($self, $id, @msg) = @_;	3087	my ($self, $id, @msg) = @_;
2902		3088
2903	if ($self->extcmd == 2) {	3089	if ($self->extcmd == 2) {
2904	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));	3090	$self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2905	} elsif ($self->extcmd == 1) {	3091	} elsif ($self->extcmd == 1) {
2906	#TODO: version 1, remove	3092	#TODO: version 1, remove
2907	unshift @msg, msgtype => "reply", msgid => $id;	3093	unshift @msg, msgtype => "reply", msgid => $id;
2908	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));	3094	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2909	}	3095	}
2910	}	3096	}
2911		3097
2912	=item $success = $client->query ($flags, "text", \&cb)	3098	=item $success = $client->query ($flags, "text", \&cb)
2913		3099
…		…
3014		3200
3015	$coro	3201	$coro
3016	}	3202	}
3017		3203
3018	cf::client->attach (	3204	cf::client->attach (
3019	on_destroy => sub {	3205	on_client_destroy => sub {
3020	my ($ns) = @_;	3206	my ($ns) = @_;
3021		3207
3022	$_->cancel for values %{ (delete $ns->{_coro}) \|\| {} };	3208	$_->cancel for values %{ (delete $ns->{_coro}) \|\| {} };
3023	},	3209	},
3024	);	3210	);
…		…
3040	our $safe_hole = new Safe::Hole;	3226	our $safe_hole = new Safe::Hole;
3041		3227
3042	$SIG{FPE} = 'IGNORE';	3228	$SIG{FPE} = 'IGNORE';
3043		3229
3044	$safe->permit_only (Opcode::opset qw(	3230	$safe->permit_only (Opcode::opset qw(
3045	:base_core :base_mem :base_orig :base_math	3231	:base_core :base_mem :base_orig :base_math :base_loop
3046	grepstart grepwhile mapstart mapwhile	3232	grepstart grepwhile mapstart mapwhile
3047	sort time	3233	sort time
3048	));	3234	));
3049		3235
3050	# here we export the classes and methods available to script code	3236	# here we export the classes and methods available to script code
…		…
3102	$qcode =~ s/"/‟/g; # not allowed in #line filenames	3288	$qcode =~ s/"/‟/g; # not allowed in #line filenames
3103	$qcode =~ s/\n/\\n/g;	3289	$qcode =~ s/\n/\\n/g;
3104		3290
3105	%vars = (_dummy => 0) unless %vars;	3291	%vars = (_dummy => 0) unless %vars;
3106		3292
		3293	my @res;
3107	local $_;	3294	local $_;
3108	local @safe::cf::_safe_eval_args = values %vars;
3109		3295
3110	my $eval =	3296	my $eval =
3111	"do {\n"	3297	"do {\n"
3112	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"	3298	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3113	. "#line 0 \"{$qcode}\"\n"	3299	. "#line 0 \"{$qcode}\"\n"
3114	. $code	3300	. $code
3115	. "\n}"	3301	. "\n}"
3116	;	3302	;
3117		3303
		3304	if ($CFG{safe_eval}) {
3118	sub_generation_inc;	3305	sub_generation_inc;
		3306	local @safe::cf::_safe_eval_args = values %vars;
3119	my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);	3307	@res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3120	sub_generation_inc;	3308	sub_generation_inc;
		3309	} else {
		3310	local @cf::_safe_eval_args = values %vars;
		3311	@res = wantarray ? eval eval : scalar eval $eval;
		3312	}
3121		3313
3122	if ($@) {	3314	if ($@) {
3123	warn "$@";	3315	warn "$@";
3124	warn "while executing safe code '$code'\n";	3316	warn "while executing safe code '$code'\n";
3125	warn "with arguments " . (join " ", %vars) . "\n";	3317	warn "with arguments " . (join " ", %vars) . "\n";
…		…
3144	=cut	3336	=cut
3145		3337
3146	sub register_script_function {	3338	sub register_script_function {
3147	my ($fun, $cb) = @_;	3339	my ($fun, $cb) = @_;
3148		3340
3149	no strict 'refs';	3341	$fun = "safe::$fun" if $CFG{safe_eval};
3150	*{"safe::$fun"} = $safe_hole->wrap ($cb);	3342	*$fun = $safe_hole->wrap ($cb);
3151	}	3343	}
3152		3344
3153	=back	3345	=back
3154		3346
3155	=cut	3347	=cut
…		…
3176		3368
3177	$facedata->{version} == 2	3369	$facedata->{version} == 2
3178	or cf::cleanup "$path: version mismatch, cannot proceed.";	3370	or cf::cleanup "$path: version mismatch, cannot proceed.";
3179		3371
3180	# patch in the exptable	3372	# patch in the exptable
		3373	my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3181	$facedata->{resource}{"res/exp_table"} = {	3374	$facedata->{resource}{"res/exp_table"} = {
3182	type => FT_RSRC,	3375	type => FT_RSRC,
3183	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),	3376	data => $exp_table,
		3377	hash => (Digest::MD5::md5 $exp_table),
3184	};	3378	};
3185	cf::cede_to_tick;	3379	cf::cede_to_tick;
3186		3380
3187	{	3381	{
3188	my $faces = $facedata->{faceinfo};	3382	my $faces = $facedata->{faceinfo};
…		…
3190	while (my ($face, $info) = each %$faces) {	3384	while (my ($face, $info) = each %$faces) {
3191	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	3385	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
3192		3386
3193	cf::face::set_visibility $idx, $info->{visibility};	3387	cf::face::set_visibility $idx, $info->{visibility};
3194	cf::face::set_magicmap $idx, $info->{magicmap};	3388	cf::face::set_magicmap $idx, $info->{magicmap};
3195	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};	3389	cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3196	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};	3390	cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3197		3391
3198	cf::cede_to_tick;	3392	cf::cede_to_tick;
3199	}	3393	}
3200		3394
3201	while (my ($face, $info) = each %$faces) {	3395	while (my ($face, $info) = each %$faces) {
…		…
3225		3419
3226	cf::anim::invalidate_all; # d'oh	3420	cf::anim::invalidate_all; # d'oh
3227	}	3421	}
3228		3422
3229	{	3423	{
3230	# TODO: for gcfclient pleasure, we should give resources
3231	# that gcfclient doesn't grok a >10000 face index.
3232	my $res = $facedata->{resource};	3424	my $res = $facedata->{resource};
3233		3425
3234	while (my ($name, $info) = each %$res) {	3426	while (my ($name, $info) = each %$res) {
3235	if (defined $info->{type}) {	3427	if (defined $info->{type}) {
3236	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	3428	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
3237	my $data;
3238		3429
3239	if ($info->{type} & 1) {	3430	cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3240	# prepend meta info
3241
3242	my $meta = $enc->encode ({
3243	name => $name,
3244	%{ $info->{meta} \|\| {} },
3245	});
3246
3247	$data = pack "(w/a)", $meta, $info->{data};
3248	} else {
3249	$data = $info->{data};
3250	}
3251
3252	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3253	cf::face::set_type $idx, $info->{type};	3431	cf::face::set_type $idx, $info->{type};
3254	} else {	3432	} else {
3255	$RESOURCE{$name} = $info;	3433	$RESOURCE{$name} = $info;
3256	}	3434	}
3257		3435
…		…
3341		3519
3342	warn "finished reloading resource files\n";	3520	warn "finished reloading resource files\n";
3343	}	3521	}
3344		3522
3345	sub reload_config {	3523	sub reload_config {
		3524	warn "reloading config file...\n";
		3525
3346	open my $fh, "<:utf8", "$CONFDIR/config"	3526	open my $fh, "<:utf8", "$CONFDIR/config"
3347	or return;	3527	or return;
3348		3528
3349	local $/;	3529	local $/;
3350	*CFG = YAML::Load <$fh>;	3530	*CFG = YAML::XS::Load scalar <$fh>;
3351		3531
3352	$EMERGENCY_POSITION = $CFG{emergency_position} \|\| ["/world/world_105_115", 5, 37];	3532	$EMERGENCY_POSITION = $CFG{emergency_position} \|\| ["/world/world_104_115", 49, 38];
3353		3533
3354	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};	3534	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3355	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};	3535	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3356		3536
3357	if (exists $CFG{mlockall}) {	3537	if (exists $CFG{mlockall}) {
…		…
3359	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"	3539	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3360	and die "WARNING: m(un)lockall failed: $!\n";	3540	and die "WARNING: m(un)lockall failed: $!\n";
3361	};	3541	};
3362	warn $@ if $@;	3542	warn $@ if $@;
3363	}	3543	}
		3544
		3545	warn "finished reloading resource files\n";
3364	}	3546	}
3365		3547
3366	sub pidfile() {	3548	sub pidfile() {
3367	sysopen my $fh, $PIDFILE, O_RDWR \| O_CREAT	3549	sysopen my $fh, $PIDFILE, O_RDWR \| O_CREAT
3368	or die "$PIDFILE: $!";	3550	or die "$PIDFILE: $!";
…		…
3380		3562
3381	seek $fh, 0, 0;	3563	seek $fh, 0, 0;
3382	print $fh $$;	3564	print $fh $$;
3383	}	3565	}
3384		3566
		3567	sub main_loop {
		3568	warn "EV::loop starting\n";
		3569	if (1) {
		3570	EV::loop;
		3571	}
		3572	warn "EV::loop returned\n";
		3573	goto &main_loop unless $REALLY_UNLOOP;
		3574	}
		3575
3385	sub main {	3576	sub main {
3386	cf::init_globals; # initialise logging	3577	cf::init_globals; # initialise logging
3387		3578
3388	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;	3579	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3389	LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";	3580	LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3390	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";	3581	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3391	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";	3582	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3392
3393	cf::init_experience;
3394	cf::init_anim;
3395	cf::init_attackmess;
3396	cf::init_dynamic;
3397		3583
3398	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority	3584	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3399		3585
3400	# we must not ever block the main coroutine	3586	# we must not ever block the main coroutine
3401	local $Coro::idle = sub {	3587	local $Coro::idle = sub {
…		…
3407	};	3593	};
3408		3594
3409	evthread_start IO::AIO::poll_fileno;	3595	evthread_start IO::AIO::poll_fileno;
3410		3596
3411	cf::sync_job {	3597	cf::sync_job {
		3598	cf::init_experience;
		3599	cf::init_anim;
		3600	cf::init_attackmess;
		3601	cf::init_dynamic;
		3602
		3603	cf::load_settings;
		3604	cf::load_materials;
		3605
3412	reload_resources;	3606	reload_resources;
3413	reload_config;	3607	reload_config;
3414	db_init;	3608	db_init;
3415		3609
3416	cf::load_settings;
3417	cf::load_materials;
3418	cf::init_uuid;	3610	cf::init_uuid;
3419	cf::init_signals;	3611	cf::init_signals;
3420	cf::init_commands;
3421	cf::init_skills;	3612	cf::init_skills;
3422		3613
3423	cf::init_beforeplay;	3614	cf::init_beforeplay;
3424		3615
3425	atomic;	3616	atomic;
…		…
3427	load_extensions;	3618	load_extensions;
3428		3619
3429	utime time, time, $RUNTIMEFILE;	3620	utime time, time, $RUNTIMEFILE;
3430		3621
3431	# no (long-running) fork's whatsoever before this point(!)	3622	# no (long-running) fork's whatsoever before this point(!)
		3623	use POSIX ();
3432	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};	3624	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3433		3625
3434	(pop @POST_INIT)->(0) while @POST_INIT;	3626	(pop @POST_INIT)->(0) while @POST_INIT;
3435	};	3627	};
3436		3628
3437	EV::loop;	3629	cf::object::thawer::errors_are_fatal 0;
		3630	warn "parse errors in files are no longer fatal from this point on.\n";
		3631
		3632	main_loop;
3438	}	3633	}
3439		3634
3440	#############################################################################	3635	#############################################################################
3441	# initialisation and cleanup	3636	# initialisation and cleanup
3442		3637
3443	# install some emergency cleanup handlers	3638	# install some emergency cleanup handlers
3444	BEGIN {	3639	BEGIN {
3445	our %SIGWATCHER = ();	3640	our %SIGWATCHER = ();
3446	for my $signal (qw(INT HUP TERM)) {	3641	for my $signal (qw(INT HUP TERM)) {
3447	$SIGWATCHER{$signal} = EV::signal $signal, sub {	3642	$SIGWATCHER{$signal} = AE::signal $signal, sub {
3448	cf::cleanup "SIG$signal";	3643	cf::cleanup "SIG$signal";
3449	};	3644	};
3450	}	3645	}
3451	}	3646	}
3452		3647
3453	sub write_runtime_sync {	3648	sub write_runtime_sync {
		3649	my $t0 = AE::time;
		3650
3454	# first touch the runtime file to show we are still running:	3651	# first touch the runtime file to show we are still running:
3455	# the fsync below can take a very very long time.	3652	# the fsync below can take a very very long time.
3456		3653
3457	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;	3654	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3458		3655
3459	my $guard = cf::lock_acquire "write_runtime";	3656	my $guard = cf::lock_acquire "write_runtime";
3460		3657
3461	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY \| O_CREAT, 0644	3658	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY \| O_CREAT \| O_TRUNC, 0644
3462	or return;	3659	or return;
3463		3660
3464	my $value = $cf::RUNTIME + 90 + 10;	3661	my $value = $cf::RUNTIME + 90 + 10;
3465	# 10 is the runtime save interval, for a monotonic clock	3662	# 10 is the runtime save interval, for a monotonic clock
3466	# 60 allows for the watchdog to kill the server.	3663	# 60 allows for the watchdog to kill the server.
…		…
3479	or return;	3676	or return;
3480		3677
3481	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE	3678	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3482	and return;	3679	and return;
3483		3680
3484	warn "runtime file written.\n";	3681	warn sprintf "runtime file written (%gs).\n", AE::time - $t0;
3485		3682
3486	1	3683	1
3487	}	3684	}
3488		3685
3489	our $uuid_lock;	3686	our $uuid_lock;
…		…
3615	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};	3812	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3616	for my $name (keys %$leaf_symtab) {	3813	for my $name (keys %$leaf_symtab) {
3617	_gv_clear *{"$pkg$name"};	3814	_gv_clear *{"$pkg$name"};
3618	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};	3815	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3619	}	3816	}
3620	warn "cleared package $pkg\n";#d#
3621	}	3817	}
3622		3818
3623	sub do_reload_perl() {	3819	sub do_reload_perl() {
3624	# can/must only be called in main	3820	# can/must only be called in main
3625	if ($Coro::current != $Coro::main) {	3821	if (in_main) {
3626	warn "can only reload from main coroutine";	3822	warn "can only reload from main coroutine";
3627	return;	3823	return;
3628	}	3824	}
3629		3825
3630	return if $RELOAD++;	3826	return if $RELOAD++;
3631		3827
3632	my $t1 = EV::time;	3828	my $t1 = AE::time;
3633		3829
3634	while ($RELOAD) {	3830	while ($RELOAD) {
3635	warn "reloading...";	3831	warn "reloading...";
3636		3832
3637	warn "entering sync_job";	3833	warn "entering sync_job";
…		…
3708		3904
3709	warn "unload completed, starting to reload now";	3905	warn "unload completed, starting to reload now";
3710		3906
3711	warn "reloading cf.pm";	3907	warn "reloading cf.pm";
3712	require cf;	3908	require cf;
3713	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3909	cf::_connect_to_perl_1;
3714		3910
3715	warn "loading config and database again";	3911	warn "loading config and database again";
3716	cf::reload_config;	3912	cf::reload_config;
3717		3913
3718	warn "loading extensions";	3914	warn "loading extensions";
…		…
3740		3936
3741	warn "reloaded";	3937	warn "reloaded";
3742	--$RELOAD;	3938	--$RELOAD;
3743	}	3939	}
3744		3940
3745	$t1 = EV::time - $t1;	3941	$t1 = AE::time - $t1;
3746	warn "reload completed in ${t1}s\n";	3942	warn "reload completed in ${t1}s\n";
3747	};	3943	};
3748		3944
3749	our $RELOAD_WATCHER; # used only during reload	3945	our $RELOAD_WATCHER; # used only during reload
3750		3946
…		…
3753	# coro crashes during coro_state_free->destroy here.	3949	# coro crashes during coro_state_free->destroy here.
3754		3950
3755	$RELOAD_WATCHER \|\|= cf::async {	3951	$RELOAD_WATCHER \|\|= cf::async {
3756	Coro::AIO::aio_wait cache_extensions;	3952	Coro::AIO::aio_wait cache_extensions;
3757		3953
3758	$RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {	3954	$RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3759	do_reload_perl;	3955	do_reload_perl;
3760	undef $RELOAD_WATCHER;	3956	undef $RELOAD_WATCHER;
3761	};	3957	};
3762	};	3958	};
3763	}	3959	}
…		…
3780		3976
3781	our @WAIT_FOR_TICK;	3977	our @WAIT_FOR_TICK;
3782	our @WAIT_FOR_TICK_BEGIN;	3978	our @WAIT_FOR_TICK_BEGIN;
3783		3979
3784	sub wait_for_tick {	3980	sub wait_for_tick {
3785	return if tick_inhibit \|\| $Coro::current == $Coro::main;	3981	return Coro::cede if tick_inhibit \|\| $Coro::current == $Coro::main;
3786		3982
3787	my $signal = new Coro::Signal;	3983	my $signal = new Coro::Signal;
3788	push @WAIT_FOR_TICK, $signal;	3984	push @WAIT_FOR_TICK, $signal;
3789	$signal->wait;	3985	$signal->wait;
3790	}	3986	}
3791		3987
3792	sub wait_for_tick_begin {	3988	sub wait_for_tick_begin {
3793	return if tick_inhibit \|\| $Coro::current == $Coro::main;	3989	return Coro::cede if tick_inhibit \|\| $Coro::current == $Coro::main;
3794		3990
3795	my $signal = new Coro::Signal;	3991	my $signal = new Coro::Signal;
3796	push @WAIT_FOR_TICK_BEGIN, $signal;	3992	push @WAIT_FOR_TICK_BEGIN, $signal;
3797	$signal->wait;	3993	$signal->wait;
3798	}	3994	}
…		…
3803	unless ++$bug_warning > 10;	3999	unless ++$bug_warning > 10;
3804	return;	4000	return;
3805	}	4001	}
3806		4002
3807	cf::server_tick; # one server iteration	4003	cf::server_tick; # one server iteration
		4004
		4005	#for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3808		4006
3809	if ($NOW >= $NEXT_RUNTIME_WRITE) {	4007	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3810	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;	4008	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3811	Coro::async_pool {	4009	Coro::async_pool {
3812	$Coro::current->{desc} = "runtime saver";	4010	$Coro::current->{desc} = "runtime saver";
…		…
3835	}	4033	}
3836		4034
3837	{	4035	{
3838	# configure BDB	4036	# configure BDB
3839		4037
3840	BDB::min_parallel 8;	4038	BDB::min_parallel 16;
3841	BDB::max_poll_reqs $TICK * 0.1;	4039	BDB::max_poll_reqs $TICK * 0.1;
3842	$AnyEvent::BDB::WATCHER->priority (1);	4040	$AnyEvent::BDB::WATCHER->priority (1);
3843		4041
3844	unless ($DB_ENV) {	4042	unless ($DB_ENV) {
3845	$DB_ENV = BDB::db_env_create;	4043	$DB_ENV = BDB::db_env_create;
…		…
3925	LOG llevInfo, "[ABT] [suppressed]\n";	4123	LOG llevInfo, "[ABT] [suppressed]\n";
3926	}	4124	}
3927	}	4125	}
3928		4126
3929	# load additional modules	4127	# load additional modules
3930	eval "use cf::$_" for @EXTRA_MODULES;	4128	require "cf/$_.pm" for @EXTRA_MODULES;
		4129	cf::_connect_to_perl_2;
3931		4130
3932	END { cf::emergency_save }	4131	END { cf::emergency_save }
3933		4132
3934	1	4133	1
3935		4134

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.466 by root, Thu Jan 8 03:03:24 2009 UTC vs. Revision 1.529 by root, Wed Apr 28 11:28:22 2010 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.466 by root, Thu Jan 8 03:03:24 2009 UTC vs.
Revision 1.529 by root, Wed Apr 28 11:28:22 2010 UTC