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.457 by root, Wed Oct 1 05:50:19 2008 UTC vs.
Revision 1.520 by root, Fri Apr 16 02:37:50 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;
26	use strict "vars", "subs";	27	use strict qw(vars subs);
27		28
28	use Symbol;	29	use Symbol;
29	use List::Util;	30	use List::Util;
30	use Socket;	31	use Socket;
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
		39	use Guard ();
37	use Coro ();	40	use Coro ();
38	use Coro::State;	41	use Coro::State;
39	use Coro::Handle;	42	use Coro::Handle;
40	use Coro::EV;	43	use Coro::EV;
41	use Coro::AnyEvent;	44	use Coro::AnyEvent;
42	use Coro::Timer;	45	use Coro::Timer;
43	use Coro::Signal;	46	use Coro::Signal;
44	use Coro::Semaphore;	47	use Coro::Semaphore;
		48	use Coro::SemaphoreSet;
45	use Coro::AnyEvent;	49	use Coro::AnyEvent;
46	use Coro::AIO;	50	use Coro::AIO;
47	use Coro::BDB 1.6;	51	use Coro::BDB 1.6;
48	use Coro::Storable;	52	use Coro::Storable;
49	use Coro::Util ();	53	use Coro::Util ();
50		54
51	use JSON::XS 2.01 ();	55	use JSON::XS 2.01 ();
52	use BDB ();	56	use BDB ();
53	use Data::Dumper;	57	use Data::Dumper;
54	use Digest::MD5;
55	use Fcntl;	58	use Fcntl;
56	use YAML ();	59	use YAML::XS ();
57	use IO::AIO ();	60	use IO::AIO ();
58	use Time::HiRes;	61	use Time::HiRes;
59	use Compress::LZF;	62	use Compress::LZF;
60	use Digest::MD5 ();	63	use Digest::MD5 ();
61		64
…		…
69	$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
70		73
71	# make sure c-lzf reinitialises itself	74	# make sure c-lzf reinitialises itself
72	Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";	75	Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
73	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" };
74		80
75	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	81	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
76		82
77	our %COMMAND = ();	83	our %COMMAND = ();
78	our %COMMAND_TIME = ();	84	our %COMMAND_TIME = ();
…		…
83	our %EXT_CORO = (); # coroutines bound to extensions	89	our %EXT_CORO = (); # coroutines bound to extensions
84	our %EXT_MAP = (); # pluggable maps	90	our %EXT_MAP = (); # pluggable maps
85		91
86	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
87	our @EVENT;	93	our @EVENT;
		94	our @REFLECT; # set by XS
		95	our %REFLECT; # set by us
88		96
89	our $CONFDIR = confdir;	97	our $CONFDIR = confdir;
90	our $DATADIR = datadir;	98	our $DATADIR = datadir;
91	our $LIBDIR = "$DATADIR/ext";	99	our $LIBDIR = "$DATADIR/ext";
92	our $PODDIR = "$DATADIR/pod";	100	our $PODDIR = "$DATADIR/pod";
…		…
100	our $PIDFILE = "$LOCALDIR/pid";	108	our $PIDFILE = "$LOCALDIR/pid";
101	our $RUNTIMEFILE = "$LOCALDIR/runtime";	109	our $RUNTIMEFILE = "$LOCALDIR/runtime";
102		110
103	our %RESOURCE;	111	our %RESOURCE;
104		112
		113	our $OUTPUT_RATE_MIN = 4000;
		114	our $OUTPUT_RATE_MAX = 100000;
		115
105	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	116	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
106	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	117	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
107	our $NEXT_TICK;	118	our $NEXT_TICK;
108	our $USE_FSYNC = 1; # use fsync to write maps - default off	119	our $USE_FSYNC = 1; # use fsync to write maps - default on
109		120
110	our $BDB_DEADLOCK_WATCHER;	121	our $BDB_DEADLOCK_WATCHER;
111	our $BDB_CHECKPOINT_WATCHER;	122	our $BDB_CHECKPOINT_WATCHER;
112	our $BDB_TRICKLE_WATCHER;	123	our $BDB_TRICKLE_WATCHER;
113	our $DB_ENV;	124	our $DB_ENV;
114		125
		126	our @EXTRA_MODULES = qw(pod match mapscript);
		127
115	our %CFG;	128	our %CFG;
116		129
117	our $UPTIME; $UPTIME ||= time;	130	our $UPTIME; $UPTIME ||= time;
118	our $RUNTIME;	131	our $RUNTIME;
119	our $NOW;	132	our $NOW;
…		…
130	our $JITTER; # average jitter	143	our $JITTER; # average jitter
131	our $TICK_START; # for load detecting purposes	144	our $TICK_START; # for load detecting purposes
132		145
133	our @POST_INIT;	146	our @POST_INIT;
134		147
135	our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow)	148	our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
		149	our $REALLY_UNLOOP; # never set to true, please :)
136		150
137	binmode STDOUT;	151	binmode STDOUT;
138	binmode STDERR;	152	binmode STDERR;
139		153
140	# read virtual server time, if available	154	# read virtual server time, if available
…		…
142	open my $fh, "<", $RUNTIMEFILE	156	open my $fh, "<", $RUNTIMEFILE
143	or die "unable to read $RUNTIMEFILE file: $!";	157	or die "unable to read $RUNTIMEFILE file: $!";
144	$RUNTIME = <$fh> + 0.;	158	$RUNTIME = <$fh> + 0.;
145	}	159	}
146		160
		161	eval "sub TICK() { $TICK } 1" or die;
		162
147	mkdir $_	163	mkdir $_
148	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;	164	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
149		165
150	our $EMERGENCY_POSITION;	166	our $EMERGENCY_POSITION;
151		167
152	sub cf::map::normalise;	168	sub cf::map::normalise;
		169
		170	#############################################################################
		171
		172	%REFLECT = ();
		173	for (@REFLECT) {
		174	my $reflect = JSON::XS::decode_json $_;
		175	$REFLECT{$reflect->{class}} = $reflect;
		176	}
		177
		178	# this is decidedly evil
		179	$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
153		180
154	#############################################################################	181	#############################################################################
155		182
156	=head2 GLOBAL VARIABLES	183	=head2 GLOBAL VARIABLES
157		184
…		…
204	returns directly I<after> the tick processing (and consequently, can only wake one process	231	returns directly I<after> the tick processing (and consequently, can only wake one process
205	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	232	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
206		233
207	=item @cf::INVOKE_RESULTS	234	=item @cf::INVOKE_RESULTS
208		235
209	This array contains the results of the last C<invoke ()> call. When	236	This array contains the results of the last C<invoke ()> call. When
210	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of	237	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
211	that call.	238	that call.
212		239
		240	=item %cf::REFLECT
		241
		242	Contains, for each (C++) class name, a hash reference with information
		243	about object members (methods, scalars, arrays and flags) and other
		244	metadata, which is useful for introspection.
		245
213	=back	246	=back
214		247
215	=cut	248	=cut
216		249
217	BEGIN {	250	$Coro::State::WARNHOOK = sub {
218	*CORE::GLOBAL::warn = sub {
219	my $msg = join "", @_;	251	my $msg = join "", @_;
220		252
221	$msg .= "\n"	253	$msg .= "\n"
222	unless $msg =~ /\n$/;	254	unless $msg =~ /\n$/;
223		255
224	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;	256	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
225		257
226	LOG llevError, $msg;	258	LOG llevError, $msg;
227	};	259	};
228	}
229		260
230	$Coro::State::DIEHOOK = sub {	261	$Coro::State::DIEHOOK = sub {
231	return unless $^S eq 0; # "eq", not "=="	262	return unless $^S eq 0; # "eq", not "=="
		263
		264	warn Carp::longmess $_[0];
232		265
233	if ($Coro::current == $Coro::main) {#d#	266	if ($Coro::current == $Coro::main) {#d#
234	warn "DIEHOOK called in main context, Coro bug?\n";#d#	267	warn "DIEHOOK called in main context, Coro bug?\n";#d#
235	return;#d#	268	return;#d#
236	}#d#	269	}#d#
237		270
238	# kill coroutine otherwise	271	# kill coroutine otherwise
239	warn Carp::longmess $_[0];
240	Coro::terminate	272	Coro::terminate
241	};	273	};
242
243	$SIG{__DIE__} = sub { }; #d#?
244		274
245	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	275	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
246	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';	276	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
247	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';	277	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
248	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';	278	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
…		…
262	)) {	292	)) {
263	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	293	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
264	}	294	}
265		295
266	$EV::DIED = sub {	296	$EV::DIED = sub {
267	warn "error in event callback: @_";	297	Carp::cluck "error in event callback: @_";
268	};	298	};
269		299
270	#############################################################################	300	#############################################################################
271		301
272	=head2 UTILITY FUNCTIONS	302	=head2 UTILITY FUNCTIONS
…		…
330	Wait until the given lock is available. See cf::lock_acquire.	360	Wait until the given lock is available. See cf::lock_acquire.
331		361
332	=item my $lock = cf::lock_acquire $string	362	=item my $lock = cf::lock_acquire $string
333		363
334	Wait until the given lock is available and then acquires it and returns	364	Wait until the given lock is available and then acquires it and returns
335	a Coro::guard object. If the guard object gets destroyed (goes out of scope,	365	a L<Guard> object. If the guard object gets destroyed (goes out of scope,
336	for example when the coroutine gets canceled), the lock is automatically	366	for example when the coroutine gets canceled), the lock is automatically
337	returned.	367	returned.
338		368
339	Locks are *not* recursive, locking from the same coro twice results in a	369	Locks are *not* recursive, locking from the same coro twice results in a
340	deadlocked coro.	370	deadlocked coro.
…		…
346		376
347	Return true if the lock is currently active, i.e. somebody has locked it.	377	Return true if the lock is currently active, i.e. somebody has locked it.
348		378
349	=cut	379	=cut
350		380
351	our %LOCK;	381	our $LOCKS = new Coro::SemaphoreSet;
352	our %LOCKER;#d#
353		382
354	sub lock_wait($) {	383	sub lock_wait($) {
355	my ($key) = @_;	384	$LOCKS->wait ($_[0]);
356
357	if ($LOCKER{$key} == $Coro::current) {#d#
358	Carp::cluck "lock_wait($key) for already-acquired lock";#d#
359	return;#d#
360	}#d#
361
362	# wait for lock, if any
363	while ($LOCK{$key}) {
364	#local $Coro::current->{desc} = "$Coro::current->{desc} <waiting for lock $key>";
365	push @{ $LOCK{$key} }, $Coro::current;
366	Coro::schedule;
367	}
368	}	385	}
369		386
370	sub lock_acquire($) {	387	sub lock_acquire($) {
371	my ($key) = @_;	388	$LOCKS->guard ($_[0])
372
373	# wait, to be sure we are not locked
374	lock_wait $key;
375
376	$LOCK{$key} = [];
377	$LOCKER{$key} = $Coro::current;#d#
378
379	Coro::guard {
380	delete $LOCKER{$key};#d#
381	# wake up all waiters, to be on the safe side
382	$_->ready for @{ delete $LOCK{$key} };
383	}
384	}	389	}
385		390
386	sub lock_active($) {	391	sub lock_active($) {
387	my ($key) = @_;	392	$LOCKS->count ($_[0]) < 1
388
389	! ! $LOCK{$key}
390	}	393	}
391		394
392	sub freeze_mainloop {	395	sub freeze_mainloop {
393	tick_inhibit_inc;	396	tick_inhibit_inc;
394		397
395	Coro::guard \&tick_inhibit_dec;	398	&Guard::guard (\&tick_inhibit_dec);
396	}	399	}
397		400
398	=item cf::periodic $interval, $cb	401	=item cf::periodic $interval, $cb
399		402
400	Like EV::periodic, but randomly selects a starting point so that the actions	403	Like EV::periodic, but randomly selects a starting point so that the actions
401	get spread over timer.	404	get spread over time.
402		405
403	=cut	406	=cut
404		407
405	sub periodic($$) {	408	sub periodic($$) {
406	my ($interval, $cb) = @_;	409	my ($interval, $cb) = @_;
…		…
423		426
424	=cut	427	=cut
425		428
426	our @SLOT_QUEUE;	429	our @SLOT_QUEUE;
427	our $SLOT_QUEUE;	430	our $SLOT_QUEUE;
		431	our $SLOT_DECAY = 0.9;
428		432
429	$SLOT_QUEUE->cancel if $SLOT_QUEUE;	433	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
430	$SLOT_QUEUE = Coro::async {	434	$SLOT_QUEUE = Coro::async {
431	$Coro::current->desc ("timeslot manager");	435	$Coro::current->desc ("timeslot manager");
432		436
433	my $signal = new Coro::Signal;	437	my $signal = new Coro::Signal;
		438	my $busy;
434		439
435	while () {	440	while () {
436	next_job:	441	next_job:
		442
437	my $avail = cf::till_tick;	443	my $avail = cf::till_tick;
438	if ($avail > 0.01) {	444
439	for (0 .. $#SLOT_QUEUE) {	445	for (0 .. $#SLOT_QUEUE) {
440	if ($SLOT_QUEUE[$_][0] < $avail) {	446	if ($SLOT_QUEUE[$_][0] <= $avail) {
		447	$busy = 0;
441	my $job = splice @SLOT_QUEUE, $_, 1, ();	448	my $job = splice @SLOT_QUEUE, $_, 1, ();
442	$job->[2]->send;	449	$job->[2]->send;
443	Coro::cede;	450	Coro::cede;
444	goto next_job;	451	goto next_job;
445	}	452	} else {
		453	$SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
446	}	454	}
447	}	455	}
448		456
449	if (@SLOT_QUEUE) {	457	if (@SLOT_QUEUE) {
450	# we do not use wait_for_tick() as it returns immediately when tick is inactive	458	# we do not use wait_for_tick() as it returns immediately when tick is inactive
451	push @cf::WAIT_FOR_TICK, $signal;	459	push @cf::WAIT_FOR_TICK, $signal;
452	$signal->wait;	460	$signal->wait;
453	} else {	461	} else {
		462	$busy = 0;
454	Coro::schedule;	463	Coro::schedule;
455	}	464	}
456	}	465	}
457	};	466	};
458		467
459	sub get_slot($;$$) {	468	sub get_slot($;$$) {
460	return if tick_inhibit || $Coro::current == $Coro::main;	469	return if tick_inhibit || $Coro::current == $Coro::main;
461		470
462	my ($time, $pri, $name) = @_;	471	my ($time, $pri, $name) = @_;
463		472
464	$time = $TICK * .6 if $time > $TICK * .6;	473	$time = clamp $time, 0.01, $TICK * .6;
		474
465	my $sig = new Coro::Signal;	475	my $sig = new Coro::Signal;
466		476
467	push @SLOT_QUEUE, [$time, $pri, $sig, $name];	477	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
468	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;	478	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
469	$SLOT_QUEUE->ready;	479	$SLOT_QUEUE->ready;
…		…
496		506
497	sub sync_job(&) {	507	sub sync_job(&) {
498	my ($job) = @_;	508	my ($job) = @_;
499		509
500	if ($Coro::current == $Coro::main) {	510	if ($Coro::current == $Coro::main) {
501	my $time = EV::time;	511	my $time = AE::time;
502		512
503	# this is the main coro, too bad, we have to block	513	# this is the main coro, too bad, we have to block
504	# till the operation succeeds, freezing the server :/	514	# till the operation succeeds, freezing the server :/
505		515
506	LOG llevError, Carp::longmess "sync job";#d#	516	LOG llevError, Carp::longmess "sync job";#d#
…		…
523	} else {	533	} else {
524	EV::loop EV::LOOP_ONESHOT;	534	EV::loop EV::LOOP_ONESHOT;
525	}	535	}
526	}	536	}
527		537
528	my $time = EV::time - $time;	538	my $time = AE::time - $time;
529		539
530	$TICK_START += $time; # do not account sync jobs to server load	540	$TICK_START += $time; # do not account sync jobs to server load
531		541
532	wantarray ? @res : $res[0]	542	wantarray ? @res : $res[0]
533	} else {	543	} else {
…		…
577	reset_signals;	587	reset_signals;
578	&$cb	588	&$cb
579	}, @args;	589	}, @args;
580		590
581	wantarray ? @res : $res[-1]	591	wantarray ? @res : $res[-1]
		592	}
		593
		594	sub objinfo {
		595	(
		596	"counter value" => cf::object::object_count,
		597	"objects created" => cf::object::create_count,
		598	"objects destroyed" => cf::object::destroy_count,
		599	"freelist size" => cf::object::free_count,
		600	"allocated objects" => cf::object::objects_size,
		601	"active objects" => cf::object::actives_size,
		602	)
582	}	603	}
583		604
584	=item $coin = coin_from_name $name	605	=item $coin = coin_from_name $name
585		606
586	=cut	607	=cut
…		…
1172	$decname, length $$rdata, scalar @$objs;	1193	$decname, length $$rdata, scalar @$objs;
1173		1194
1174	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {	1195	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1175	aio_chmod $fh, SAVE_MODE;	1196	aio_chmod $fh, SAVE_MODE;
1176	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1197	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1177	aio_fsync $fh if $cf::USE_FSYNC;	1198	if ($cf::USE_FSYNC) {
		1199	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;
		1200	aio_fsync $fh;
		1201	}
1178	aio_close $fh;	1202	aio_close $fh;
1179		1203
1180	if (@$objs) {	1204	if (@$objs) {
1181	if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {	1205	if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1182	aio_chmod $fh, SAVE_MODE;	1206	aio_chmod $fh, SAVE_MODE;
1183	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };	1207	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1184	aio_write $fh, 0, (length $data), $data, 0;	1208	aio_write $fh, 0, (length $data), $data, 0;
1185	aio_fsync $fh if $cf::USE_FSYNC;	1209	if ($cf::USE_FSYNC) {
		1210	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;
		1211	aio_fsync $fh;
		1212	}
1186	aio_close $fh;	1213	aio_close $fh;
1187	aio_rename "$filename.pst~", "$filename.pst";	1214	aio_rename "$filename.pst~", "$filename.pst";
1188	}	1215	}
1189	} else {	1216	} else {
1190	aio_unlink "$filename.pst";	1217	aio_unlink "$filename.pst";
…		…
1193	aio_rename "$filename~", $filename;	1220	aio_rename "$filename~", $filename;
1194		1221
1195	$filename =~ s%/[^/]+$%%;	1222	$filename =~ s%/[^/]+$%%;
1196	aio_pathsync $filename if $cf::USE_FSYNC;	1223	aio_pathsync $filename if $cf::USE_FSYNC;
1197	} else {	1224	} else {
1198	warn "FATAL: $filename~: $!\n";	1225	warn "unable to save objects: $filename~: $!\n";
1199	}	1226	}
1200	} else {	1227	} else {
1201	aio_unlink $filename;	1228	aio_unlink $filename;
1202	aio_unlink "$filename.pst";	1229	aio_unlink "$filename.pst";
1203	}	1230	}
…		…
1297	}	1324	}
1298		1325
1299	use File::Glob ();	1326	use File::Glob ();
1300		1327
1301	cf::player->attach (	1328	cf::player->attach (
1302	on_command => sub {	1329	on_unknown_command => sub {
1303	my ($pl, $name, $params) = @_;	1330	my ($pl, $name, $params) = @_;
1304		1331
1305	my $cb = $COMMAND{$name}	1332	my $cb = $COMMAND{$name}
1306	or return;	1333	or return;
1307		1334
…		…
1341		1368
1342	# "readahead" all extensions	1369	# "readahead" all extensions
1343	sub cache_extensions {	1370	sub cache_extensions {
1344	my $grp = IO::AIO::aio_group;	1371	my $grp = IO::AIO::aio_group;
1345		1372
1346	add $grp IO::AIO::aio_readdir $LIBDIR, sub {	1373	add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1347	for (grep /\.ext$/, @{$_[0]}) {	1374	for (grep /\.ext$/, @{$_[0]}) {
1348	add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;	1375	add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1349	}	1376	}
1350	};	1377	};
1351		1378
…		…
1386	. "\n};\n1";	1413	. "\n};\n1";
1387		1414
1388	$todo{$base} = \%ext;	1415	$todo{$base} = \%ext;
1389	}	1416	}
1390		1417
		1418	my $pass = 0;
1391	my %done;	1419	my %done;
1392	while (%todo) {	1420	while (%todo) {
1393	my $progress;	1421	my $progress;
1394		1422
		1423	++$pass;
		1424
		1425	ext:
1395	while (my ($k, $v) = each %todo) {	1426	while (my ($k, $v) = each %todo) {
1396	for (split /,\s*/, $v->{meta}{depends}) {	1427	for (split /,\s*/, $v->{meta}{depends}) {
1397	goto skip	1428	next ext
1398	unless exists $done{$_};	1429	unless exists $done{$_};
1399	}	1430	}
1400		1431
1401	warn "... loading '$k' into '$v->{pkg}'\n";	1432	warn "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1402		1433
1403	unless (eval $v->{source}) {	1434	my $active = eval $v->{source};
		1435
		1436	if (length $@) {
1404	my $msg = $@ ? "$v->{path}: $@\n"	1437	warn "$v->{path}: $@\n";
1405	: "$v->{base}: extension inactive.\n";
1406		1438
1407	if (exists $v->{meta}{mandatory}) {
1408	warn $msg;
1409	cf::cleanup "mandatory extension failed to load, exiting.";	1439	cf::cleanup "mandatory extension '$k' failed to load, exiting."
1410	}	1440	if exists $v->{meta}{mandatory};
1411		1441	} else {
1412	warn $msg;	1442	$done{$k} = delete $todo{$k};
		1443	push @EXTS, $v->{pkg};
		1444	$progress = 1;
		1445
		1446	warn "$v->{base}: extension inactive.\n"
		1447	unless $active;
1413	}	1448	}
1414
1415	$done{$k} = delete $todo{$k};
1416	push @EXTS, $v->{pkg};
1417	$progress = 1;
1418	}	1449	}
1419		1450
1420	skip:	1451	unless ($progress) {
1421	die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"	1452	warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1422	unless $progress;	1453
		1454	while (my ($k, $v) = each %todo) {
		1455	cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
		1456	if exists $v->{meta}{mandatory};
		1457	}
		1458	}
1423	}	1459	}
1424	};	1460	};
1425	}	1461	}
1426		1462
1427	#############################################################################	1463	#############################################################################
…		…
1511	$cf::PLAYER{$login} = $pl	1547	$cf::PLAYER{$login} = $pl
1512	}	1548	}
1513	}	1549	}
1514	}	1550	}
1515		1551
		1552	cf::player->attach (
		1553	on_load => sub {
		1554	my ($pl, $path) = @_;
		1555
		1556	# restore slots saved in save, below
		1557	my $slots = delete $pl->{_slots};
		1558
		1559	$pl->ob->current_weapon ($slots->[0]);
		1560	$pl->combat_ob ($slots->[1]);
		1561	$pl->ranged_ob ($slots->[2]);
		1562	},
		1563	);
		1564
1516	sub save($) {	1565	sub save($) {
1517	my ($pl) = @_;	1566	my ($pl) = @_;
1518		1567
1519	return if $pl->{deny_save};	1568	return if $pl->{deny_save};
1520		1569
…		…
1525		1574
1526	aio_mkdir playerdir $pl, 0770;	1575	aio_mkdir playerdir $pl, 0770;
1527	$pl->{last_save} = $cf::RUNTIME;	1576	$pl->{last_save} = $cf::RUNTIME;
1528		1577
1529	cf::get_slot 0.01;	1578	cf::get_slot 0.01;
		1579
		1580	# save slots, to be restored later
		1581	local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1530		1582
1531	$pl->save_pl ($path);	1583	$pl->save_pl ($path);
1532	cf::cede_to_tick;	1584	cf::cede_to_tick;
1533	}	1585	}
1534		1586
…		…
1747	my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM	1799	my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1748		1800
1749	# mit "rum" bekleckern, nicht	1801	# mit "rum" bekleckern, nicht
1750	$self->_create_random_map (	1802	$self->_create_random_map (
1751	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},	1803	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1752	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},	1804	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1753	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},	1805	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1754	$rmp->{exit_on_final_map},	1806	$rmp->{exit_on_final_map},
1755	$rmp->{xsize}, $rmp->{ysize},	1807	$rmp->{xsize}, $rmp->{ysize},
1756	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},	1808	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1757	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},	1809	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
…		…
1887		1939
1888	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;	1940	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1889	"$UNIQUEDIR/$path"	1941	"$UNIQUEDIR/$path"
1890	}	1942	}
1891		1943
1892	# and all this just because we cannot iterate over
1893	# all maps in C++...
1894	sub change_all_map_light {
1895	my ($change) = @_;
1896
1897	$_->change_map_light ($change)
1898	for grep $_->outdoor, values %cf::MAP;
1899	}
1900
1901	sub decay_objects {	1944	sub decay_objects {
1902	my ($self) = @_;	1945	my ($self) = @_;
1903		1946
1904	return if $self->{deny_reset};	1947	return if $self->{deny_reset};
1905		1948
…		…
1987	sub find {	2030	sub find {
1988	my ($path, $origin) = @_;	2031	my ($path, $origin) = @_;
1989		2032
1990	$path = normalise $path, $origin && $origin->path;	2033	$path = normalise $path, $origin && $origin->path;
1991		2034
1992	cf::lock_wait "map_data:$path";#d#remove	2035	my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1993	cf::lock_wait "map_find:$path";	2036	my $guard2 = cf::lock_acquire "map_find:$path";
1994		2037
1995	$cf::MAP{$path} || do {	2038	$cf::MAP{$path} || do {
1996	my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1997	my $guard2 = cf::lock_acquire "map_find:$path";
1998
1999	my $map = new_from_path cf::map $path	2039	my $map = new_from_path cf::map $path
2000	or return;	2040	or return;
2001		2041
2002	$map->{last_save} = $cf::RUNTIME;	2042	$map->{last_save} = $cf::RUNTIME;
2003		2043
…		…
2015		2055
2016	$cf::MAP{$path} = $map	2056	$cf::MAP{$path} = $map
2017	}	2057	}
2018	}	2058	}
2019		2059
2020	sub pre_load { }	2060	sub pre_load { }
2021	sub post_load { }	2061	#sub post_load { } # XS
2022		2062
2023	sub load {	2063	sub load {
2024	my ($self) = @_;	2064	my ($self) = @_;
2025		2065
2026	local $self->{deny_reset} = 1; # loading can take a long time	2066	local $self->{deny_reset} = 1; # loading can take a long time
…		…
2071	unless ($self->{deny_activate}) {	2111	unless ($self->{deny_activate}) {
2072	$self->decay_objects;	2112	$self->decay_objects;
2073	$self->fix_auto_apply;	2113	$self->fix_auto_apply;
2074	$self->update_buttons;	2114	$self->update_buttons;
2075	cf::cede_to_tick;	2115	cf::cede_to_tick;
2076	$self->set_darkness_map;
2077	cf::cede_to_tick;
2078	$self->activate;	2116	$self->activate;
2079	}	2117	}
2080		2118
2081	$self->{last_save} = $cf::RUNTIME;	2119	$self->{last_save} = $cf::RUNTIME;
2082	$self->last_access ($cf::RUNTIME);	2120	$self->last_access ($cf::RUNTIME);
…		…
2085	}	2123	}
2086		2124
2087	$self->post_load;	2125	$self->post_load;
2088	}	2126	}
2089		2127
		2128	# customize the map for a given player, i.e.
		2129	# return the _real_ map. used by e.g. per-player
		2130	# maps to change the path to ~playername/mappath
2090	sub customise_for {	2131	sub customise_for {
2091	my ($self, $ob) = @_;	2132	my ($self, $ob) = @_;
2092		2133
2093	return find "~" . $ob->name . "/" . $self->{path}	2134	return find "~" . $ob->name . "/" . $self->{path}
2094	if $self->per_player;	2135	if $self->per_player;
…		…
2171	$MAP_PREFETCHER->prio (6);	2212	$MAP_PREFETCHER->prio (6);
2172		2213
2173	()	2214	()
2174	}	2215	}
2175		2216
		2217	# common code, used by both ->save and ->swapout
2176	sub save {	2218	sub _save {
2177	my ($self) = @_;	2219	my ($self) = @_;
2178
2179	my $lock = cf::lock_acquire "map_data:$self->{path}";
2180		2220
2181	$self->{last_save} = $cf::RUNTIME;	2221	$self->{last_save} = $cf::RUNTIME;
2182		2222
2183	return unless $self->dirty;	2223	return unless $self->dirty;
2184		2224
…		…
2204	} else {	2244	} else {
2205	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);	2245	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2206	}	2246	}
2207	}	2247	}
2208		2248
		2249	sub save {
		2250	my ($self) = @_;
		2251
		2252	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2253
		2254	$self->_save;
		2255	}
		2256
2209	sub swap_out {	2257	sub swap_out {
2210	my ($self) = @_;	2258	my ($self) = @_;
2211		2259
2212	# save first because save cedes
2213	$self->save;
2214
2215	my $lock = cf::lock_acquire "map_data:$self->{path}";	2260	my $lock = cf::lock_acquire "map_data:$self->{path}";
2216		2261
2217	return if $self->players;
2218	return if $self->in_memory != cf::MAP_ACTIVE;	2262	return if $self->in_memory != cf::MAP_ACTIVE;
2219	return if $self->{deny_save};	2263	return if $self->{deny_save};
		2264	return if $self->players;
2220		2265
2221	$self->in_memory (cf::MAP_SWAPPED);	2266	# first deactivate the map and "unlink" it from the core
2222
2223	$self->deactivate;	2267	$self->deactivate;
2224	$_->clear_links_to ($self) for values %cf::MAP;	2268	$_->clear_links_to ($self) for values %cf::MAP;
		2269	$self->in_memory (cf::MAP_SWAPPED);
		2270
		2271	# then atomically save
		2272	$self->_save;
		2273
		2274	# then free the map
2225	$self->clear;	2275	$self->clear;
2226	}	2276	}
2227		2277
2228	sub reset_at {	2278	sub reset_at {
2229	my ($self) = @_;	2279	my ($self) = @_;
…		…
2248		2298
2249	my $lock = cf::lock_acquire "map_data:$self->{path}";	2299	my $lock = cf::lock_acquire "map_data:$self->{path}";
2250		2300
2251	return if $self->players;	2301	return if $self->players;
2252		2302
2253	warn "resetting map ", $self->path;	2303	warn "resetting map ", $self->path, "\n";
2254		2304
2255	$self->in_memory (cf::MAP_SWAPPED);	2305	$self->in_memory (cf::MAP_SWAPPED);
2256		2306
2257	# need to save uniques path	2307	# need to save uniques path
2258	unless ($self->{deny_save}) {	2308	unless ($self->{deny_save}) {
…		…
2349	: normalise $_	2399	: normalise $_
2350	} @{ aio_readdir $UNIQUEDIR or [] }	2400	} @{ aio_readdir $UNIQUEDIR or [] }
2351	]	2401	]
2352	}	2402	}
2353		2403
		2404	=item cf::map::static_maps
		2405
		2406	Returns an arrayref if paths of all static maps (all preinstalled F<.map>
		2407	file in the shared directory excluding F</styles> and F</editor>). May
		2408	block.
		2409
		2410	=cut
		2411
		2412	sub static_maps() {
		2413	my @dirs = "";
		2414	my @maps;
		2415
		2416	while (@dirs) {
		2417	my $dir = shift @dirs;
		2418
		2419	next if $dir eq "/styles" || $dir eq "/editor";
		2420
		2421	my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
		2422	or return;
		2423
		2424	for (@$files) {
		2425	s/\.map$// or next;
		2426	utf8::decode $_;
		2427	push @maps, "$dir/$_";
		2428	}
		2429
		2430	push @dirs, map "$dir/$_", @$dirs;
		2431	}
		2432
		2433	\@maps
		2434	}
		2435
2354	=back	2436	=back
2355		2437
2356	=head3 cf::object	2438	=head3 cf::object
2357		2439
2358	=cut	2440	=cut
…		…
2423		2505
2424	our $SAY_CHANNEL = {	2506	our $SAY_CHANNEL = {
2425	id => "say",	2507	id => "say",
2426	title => "Map",	2508	title => "Map",
2427	reply => "say ",	2509	reply => "say ",
2428	tooltip => "Things said to and replied from npcs near you and other players on the same map only.",	2510	tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2429	};	2511	};
2430		2512
2431	our $CHAT_CHANNEL = {	2513	our $CHAT_CHANNEL = {
2432	id => "chat",	2514	id => "chat",
2433	title => "Chat",	2515	title => "Chat",
…		…
2526	return if UNIVERSAL::isa $self->map, "ext::map_link";	2608	return if UNIVERSAL::isa $self->map, "ext::map_link";
2527		2609
2528	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]	2610	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2529	if $self->map && $self->map->{path} ne "{link}";	2611	if $self->map && $self->map->{path} ne "{link}";
2530		2612
2531	$self->enter_map ($LINK_MAP || link_map, 10, 10);	2613	$self->enter_map ($LINK_MAP || link_map, 3, 3);
2532	}	2614	}
2533		2615
2534	sub cf::object::player::leave_link {	2616	sub cf::object::player::leave_link {
2535	my ($self, $map, $x, $y) = @_;	2617	my ($self, $map, $x, $y) = @_;
2536		2618
…		…
2553	($x, $y) = (-1, -1)	2635	($x, $y) = (-1, -1)
2554	unless (defined $x) && (defined $y);	2636	unless (defined $x) && (defined $y);
2555		2637
2556	# use -1 or undef as default coordinates, not 0, 0	2638	# use -1 or undef as default coordinates, not 0, 0
2557	($x, $y) = ($map->enter_x, $map->enter_y)	2639	($x, $y) = ($map->enter_x, $map->enter_y)
2558	if $x <=0 && $y <= 0;	2640	if $x <= 0 && $y <= 0;
2559		2641
2560	$map->load;	2642	$map->load;
2561	$map->load_neighbours;	2643	$map->load_neighbours;
2562		2644
2563	return unless $self->contr->active;	2645	return unless $self->contr->active;
2564	$self->flag (cf::FLAG_DEBUG, 0);#d# temp
2565	$self->activate_recursive;
2566		2646
2567	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2647	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2568	$self->enter_map ($map, $x, $y);	2648	$self->enter_map ($map, $x, $y);
		2649
		2650	# only activate afterwards, to support waiting in hooks
		2651	$self->activate_recursive;
2569	}	2652	}
2570		2653
2571	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])	2654	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2572		2655
2573	Moves the player to the given map-path and coordinates by first freezing	2656	Moves the player to the given map-path and coordinates by first freezing
…		…
2761		2844
2762	utf8::encode $text;	2845	utf8::encode $text;
2763	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);	2846	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2764	}	2847	}
2765		2848
		2849	=item $client->send_big_packet ($pkt)
		2850
		2851	Like C<send_packet>, but tries to compress large packets, and fragments
		2852	them as required.
		2853
		2854	=cut
		2855
		2856	our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
		2857
		2858	sub cf::client::send_big_packet {
		2859	my ($self, $pkt) = @_;
		2860
		2861	# try lzf for large packets
		2862	$pkt = "lzf " . Compress::LZF::compress $pkt
		2863	if 1024 <= length $pkt and $self->{can_lzf};
		2864
		2865	# split very large packets
		2866	if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
		2867	$self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
		2868	$pkt = "frag";
		2869	}
		2870
		2871	$self->send_packet ($pkt);
		2872	}
		2873
2766	=item $client->send_msg ($channel, $msg, $color, [extra...])	2874	=item $client->send_msg ($channel, $msg, $color, [extra...])
2767		2875
2768	Send a drawinfo or msg packet to the client, formatting the msg for the	2876	Send a drawinfo or msg packet to the client, formatting the msg for the
2769	client if neccessary. C<$type> should be a string identifying the type of	2877	client if neccessary. C<$type> should be a string identifying the type of
2770	the message, with C<log> being the default. If C<$color> is negative, suppress	2878	the message, with C<log> being the default. If C<$color> is negative, suppress
…		…
2772		2880
2773	=cut	2881	=cut
2774		2882
2775	# non-persistent channels (usually the info channel)	2883	# non-persistent channels (usually the info channel)
2776	our %CHANNEL = (	2884	our %CHANNEL = (
		2885	"c/motd" => {
		2886	id => "infobox",
		2887	title => "MOTD",
		2888	reply => undef,
		2889	tooltip => "The message of the day",
		2890	},
2777	"c/identify" => {	2891	"c/identify" => {
2778	id => "infobox",	2892	id => "infobox",
2779	title => "Identify",	2893	title => "Identify",
2780	reply => undef,	2894	reply => undef,
2781	tooltip => "Items recently identified",	2895	tooltip => "Items recently identified",
…		…
2783	"c/examine" => {	2897	"c/examine" => {
2784	id => "infobox",	2898	id => "infobox",
2785	title => "Examine",	2899	title => "Examine",
2786	reply => undef,	2900	reply => undef,
2787	tooltip => "Signs and other items you examined",	2901	tooltip => "Signs and other items you examined",
		2902	},
		2903	"c/shopinfo" => {
		2904	id => "infobox",
		2905	title => "Shop Info",
		2906	reply => undef,
		2907	tooltip => "What your bargaining skill tells you about the shop",
2788	},	2908	},
2789	"c/book" => {	2909	"c/book" => {
2790	id => "infobox",	2910	id => "infobox",
2791	title => "Book",	2911	title => "Book",
2792	reply => undef,	2912	reply => undef,
…		…
2808	id => "infobox",	2928	id => "infobox",
2809	title => "Body Parts",	2929	title => "Body Parts",
2810	reply => undef,	2930	reply => undef,
2811	tooltip => "Shows which body parts you posess and are available",	2931	tooltip => "Shows which body parts you posess and are available",
2812	},	2932	},
		2933	"c/statistics" => {
		2934	id => "infobox",
		2935	title => "Statistics",
		2936	reply => undef,
		2937	tooltip => "Shows your primary statistics",
		2938	},
2813	"c/skills" => {	2939	"c/skills" => {
2814	id => "infobox",	2940	id => "infobox",
2815	title => "Skills",	2941	title => "Skills",
2816	reply => undef,	2942	reply => undef,
2817	tooltip => "Shows your experience per skill and item power",	2943	tooltip => "Shows your experience per skill and item power",
		2944	},
		2945	"c/shopitems" => {
		2946	id => "infobox",
		2947	title => "Shop Items",
		2948	reply => undef,
		2949	tooltip => "Shows the items currently for sale in this shop",
		2950	},
		2951	"c/resistances" => {
		2952	id => "infobox",
		2953	title => "Resistances",
		2954	reply => undef,
		2955	tooltip => "Shows your resistances",
		2956	},
		2957	"c/pets" => {
		2958	id => "infobox",
		2959	title => "Pets",
		2960	reply => undef,
		2961	tooltip => "Shows information abotu your pets/a specific pet",
		2962	},
		2963	"c/perceiveself" => {
		2964	id => "infobox",
		2965	title => "Perceive Self",
		2966	reply => undef,
		2967	tooltip => "You gained detailed knowledge about yourself",
2818	},	2968	},
2819	"c/uptime" => {	2969	"c/uptime" => {
2820	id => "infobox",	2970	id => "infobox",
2821	title => "Uptime",	2971	title => "Uptime",
2822	reply => undef,	2972	reply => undef,
…		…
2832	id => "party",	2982	id => "party",
2833	title => "Party",	2983	title => "Party",
2834	reply => "gsay ",	2984	reply => "gsay ",
2835	tooltip => "Messages and chat related to your party",	2985	tooltip => "Messages and chat related to your party",
2836	},	2986	},
		2987	"c/death" => {
		2988	id => "death",
		2989	title => "Death",
		2990	reply => undef,
		2991	tooltip => "Reason for and more info about your most recent death",
		2992	},
		2993	"c/say" => $SAY_CHANNEL,
		2994	"c/chat" => $CHAT_CHANNEL,
2837	);	2995	);
2838		2996
2839	sub cf::client::send_msg {	2997	sub cf::client::send_msg {
2840	my ($self, $channel, $msg, $color, @extra) = @_;	2998	my ($self, $channel, $msg, $color, @extra) = @_;
2841		2999
…		…
2846		3004
2847	# check predefined channels, for the benefit of C	3005	# check predefined channels, for the benefit of C
2848	if ($CHANNEL{$channel}) {	3006	if ($CHANNEL{$channel}) {
2849	$channel = $CHANNEL{$channel};	3007	$channel = $CHANNEL{$channel};
2850		3008
2851	$self->ext_msg (channel_info => $channel)	3009	$self->ext_msg (channel_info => $channel);
2852	if $self->can_msg;
2853
2854	$channel = $channel->{id};	3010	$channel = $channel->{id};
2855		3011
2856	} elsif (ref $channel) {	3012	} elsif (ref $channel) {
2857	# send meta info to client, if not yet sent	3013	# send meta info to client, if not yet sent
2858	unless (exists $self->{channel}{$channel->{id}}) {	3014	unless (exists $self->{channel}{$channel->{id}}) {
2859	$self->{channel}{$channel->{id}} = $channel;	3015	$self->{channel}{$channel->{id}} = $channel;
2860	$self->ext_msg (channel_info => $channel)	3016	$self->ext_msg (channel_info => $channel);
2861	if $self->can_msg;
2862	}	3017	}
2863		3018
2864	$channel = $channel->{id};	3019	$channel = $channel->{id};
2865	}	3020	}
2866		3021
2867	return unless @extra || length $msg;	3022	return unless @extra || length $msg;
2868		3023
2869	if ($self->can_msg) {
2870	# default colour, mask it out	3024	# default colour, mask it out
2871	$color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)	3025	$color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2872	if $color & cf::NDI_DEF;	3026	if $color & cf::NDI_DEF;
2873		3027
2874	my $pkt = "msg "	3028	my $pkt = "msg "
2875	. $self->{json_coder}->encode (	3029	. $self->{json_coder}->encode (
2876	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]	3030	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2877	);	3031	);
2878		3032
2879	# try lzf for large packets
2880	$pkt = "lzf " . Compress::LZF::compress $pkt
2881	if 1024 <= length $pkt and $self->{can_lzf};
2882
2883	# split very large packets
2884	if (8192 < length $pkt and $self->{can_lzf}) {
2885	$self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2886	$pkt = "frag";
2887	}
2888
2889	$self->send_packet ($pkt);	3033	$self->send_big_packet ($pkt);
2890	} else {
2891	if ($color >= 0) {
2892	# replace some tags by gcfclient-compatible ones
2893	for ($msg) {
2894	1 while
2895	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2896	|| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2897	|| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2898	|| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2899	|| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2900	}
2901
2902	$color &= cf::NDI_COLOR_MASK;
2903
2904	utf8::encode $msg;
2905
2906	if (0 && $msg =~ /\[/) {
2907	# COMMAND/INFO
2908	$self->send_packet ("drawextinfo $color 10 8 $msg")
2909	} else {
2910	$msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2911	$self->send_packet ("drawinfo $color $msg")
2912	}
2913	}
2914	}
2915	}	3034	}
2916		3035
2917	=item $client->ext_msg ($type, @msg)	3036	=item $client->ext_msg ($type, @msg)
2918		3037
2919	Sends an ext event to the client.	3038	Sends an ext event to the client.
…		…
2922		3041
2923	sub cf::client::ext_msg($$@) {	3042	sub cf::client::ext_msg($$@) {
2924	my ($self, $type, @msg) = @_;	3043	my ($self, $type, @msg) = @_;
2925		3044
2926	if ($self->extcmd == 2) {	3045	if ($self->extcmd == 2) {
2927	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));	3046	$self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2928	} elsif ($self->extcmd == 1) { # TODO: remove	3047	} elsif ($self->extcmd == 1) { # TODO: remove
2929	push @msg, msgtype => "event_$type";	3048	push @msg, msgtype => "event_$type";
2930	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));	3049	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2931	}	3050	}
2932	}	3051	}
2933		3052
2934	=item $client->ext_reply ($msgid, @msg)	3053	=item $client->ext_reply ($msgid, @msg)
2935		3054
…		…
2939		3058
2940	sub cf::client::ext_reply($$@) {	3059	sub cf::client::ext_reply($$@) {
2941	my ($self, $id, @msg) = @_;	3060	my ($self, $id, @msg) = @_;
2942		3061
2943	if ($self->extcmd == 2) {	3062	if ($self->extcmd == 2) {
2944	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));	3063	$self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2945	} elsif ($self->extcmd == 1) {	3064	} elsif ($self->extcmd == 1) {
2946	#TODO: version 1, remove	3065	#TODO: version 1, remove
2947	unshift @msg, msgtype => "reply", msgid => $id;	3066	unshift @msg, msgtype => "reply", msgid => $id;
2948	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));	3067	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2949	}	3068	}
2950	}	3069	}
2951		3070
2952	=item $success = $client->query ($flags, "text", \&cb)	3071	=item $success = $client->query ($flags, "text", \&cb)
2953		3072
…		…
3054		3173
3055	$coro	3174	$coro
3056	}	3175	}
3057		3176
3058	cf::client->attach (	3177	cf::client->attach (
3059	on_destroy => sub {	3178	on_client_destroy => sub {
3060	my ($ns) = @_;	3179	my ($ns) = @_;
3061		3180
3062	$_->cancel for values %{ (delete $ns->{_coro}) || {} };	3181	$_->cancel for values %{ (delete $ns->{_coro}) || {} };
3063	},	3182	},
3064	);	3183	);
…		…
3080	our $safe_hole = new Safe::Hole;	3199	our $safe_hole = new Safe::Hole;
3081		3200
3082	$SIG{FPE} = 'IGNORE';	3201	$SIG{FPE} = 'IGNORE';
3083		3202
3084	$safe->permit_only (Opcode::opset qw(	3203	$safe->permit_only (Opcode::opset qw(
3085	:base_core :base_mem :base_orig :base_math	3204	:base_core :base_mem :base_orig :base_math :base_loop
3086	grepstart grepwhile mapstart mapwhile	3205	grepstart grepwhile mapstart mapwhile
3087	sort time	3206	sort time
3088	));	3207	));
3089		3208
3090	# here we export the classes and methods available to script code	3209	# here we export the classes and methods available to script code
…		…
3094	The following functions and methods are available within a safe environment:	3213	The following functions and methods are available within a safe environment:
3095		3214
3096	cf::object	3215	cf::object
3097	contr pay_amount pay_player map x y force_find force_add destroy	3216	contr pay_amount pay_player map x y force_find force_add destroy
3098	insert remove name archname title slaying race decrease split	3217	insert remove name archname title slaying race decrease split
		3218	value
3099		3219
3100	cf::object::player	3220	cf::object::player
3101	player	3221	player
3102		3222
3103	cf::player	3223	cf::player
…		…
3109	=cut	3229	=cut
3110		3230
3111	for (	3231	for (
3112	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	3232	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3113	insert remove inv nrof name archname title slaying race	3233	insert remove inv nrof name archname title slaying race
3114	decrease split destroy change_exp)],	3234	decrease split destroy change_exp value msg lore send_msg)],
3115	["cf::object::player" => qw(player)],	3235	["cf::object::player" => qw(player)],
3116	["cf::player" => qw(peaceful)],	3236	["cf::player" => qw(peaceful send_msg)],
3117	["cf::map" => qw(trigger)],	3237	["cf::map" => qw(trigger)],
3118	) {	3238	) {
3119	no strict 'refs';	3239	no strict 'refs';
3120	my ($pkg, @funs) = @$_;	3240	my ($pkg, @funs) = @$_;
3121	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	3241	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
…		…
3139		3259
3140	my $qcode = $code;	3260	my $qcode = $code;
3141	$qcode =~ s/"/‟/g; # not allowed in #line filenames	3261	$qcode =~ s/"/‟/g; # not allowed in #line filenames
3142	$qcode =~ s/\n/\\n/g;	3262	$qcode =~ s/\n/\\n/g;
3143		3263
		3264	%vars = (_dummy => 0) unless %vars;
		3265
		3266	my @res;
3144	local $_;	3267	local $_;
3145	local @safe::cf::_safe_eval_args = values %vars;
3146		3268
3147	my $eval =	3269	my $eval =
3148	"do {\n"	3270	"do {\n"
3149	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"	3271	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3150	. "#line 0 \"{$qcode}\"\n"	3272	. "#line 0 \"{$qcode}\"\n"
3151	. $code	3273	. $code
3152	. "\n}"	3274	. "\n}"
3153	;	3275	;
3154		3276
		3277	if ($CFG{safe_eval}) {
3155	sub_generation_inc;	3278	sub_generation_inc;
		3279	local @safe::cf::_safe_eval_args = values %vars;
3156	my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);	3280	@res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3157	sub_generation_inc;	3281	sub_generation_inc;
		3282	} else {
		3283	local @cf::_safe_eval_args = values %vars;
		3284	@res = wantarray ? eval eval : scalar eval $eval;
		3285	}
3158		3286
3159	if ($@) {	3287	if ($@) {
3160	warn "$@";	3288	warn "$@";
3161	warn "while executing safe code '$code'\n";	3289	warn "while executing safe code '$code'\n";
3162	warn "with arguments " . (join " ", %vars) . "\n";	3290	warn "with arguments " . (join " ", %vars) . "\n";
…		…
3181	=cut	3309	=cut
3182		3310
3183	sub register_script_function {	3311	sub register_script_function {
3184	my ($fun, $cb) = @_;	3312	my ($fun, $cb) = @_;
3185		3313
3186	no strict 'refs';	3314	$fun = "safe::$fun" if $CFG{safe_eval};
3187	*{"safe::$fun"} = $safe_hole->wrap ($cb);	3315	*$fun = $safe_hole->wrap ($cb);
3188	}	3316	}
3189		3317
3190	=back	3318	=back
3191		3319
3192	=cut	3320	=cut
…		…
3213		3341
3214	$facedata->{version} == 2	3342	$facedata->{version} == 2
3215	or cf::cleanup "$path: version mismatch, cannot proceed.";	3343	or cf::cleanup "$path: version mismatch, cannot proceed.";
3216		3344
3217	# patch in the exptable	3345	# patch in the exptable
		3346	my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3218	$facedata->{resource}{"res/exp_table"} = {	3347	$facedata->{resource}{"res/exp_table"} = {
3219	type => FT_RSRC,	3348	type => FT_RSRC,
3220	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),	3349	data => $exp_table,
		3350	hash => (Digest::MD5::md5 $exp_table),
3221	};	3351	};
3222	cf::cede_to_tick;	3352	cf::cede_to_tick;
3223		3353
3224	{	3354	{
3225	my $faces = $facedata->{faceinfo};	3355	my $faces = $facedata->{faceinfo};
…		…
3227	while (my ($face, $info) = each %$faces) {	3357	while (my ($face, $info) = each %$faces) {
3228	my $idx = (cf::face::find $face) || cf::face::alloc $face;	3358	my $idx = (cf::face::find $face) || cf::face::alloc $face;
3229		3359
3230	cf::face::set_visibility $idx, $info->{visibility};	3360	cf::face::set_visibility $idx, $info->{visibility};
3231	cf::face::set_magicmap $idx, $info->{magicmap};	3361	cf::face::set_magicmap $idx, $info->{magicmap};
3232	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};	3362	cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3233	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};	3363	cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3234		3364
3235	cf::cede_to_tick;	3365	cf::cede_to_tick;
3236	}	3366	}
3237		3367
3238	while (my ($face, $info) = each %$faces) {	3368	while (my ($face, $info) = each %$faces) {
…		…
3262		3392
3263	cf::anim::invalidate_all; # d'oh	3393	cf::anim::invalidate_all; # d'oh
3264	}	3394	}
3265		3395
3266	{	3396	{
3267	# TODO: for gcfclient pleasure, we should give resources
3268	# that gcfclient doesn't grok a >10000 face index.
3269	my $res = $facedata->{resource};	3397	my $res = $facedata->{resource};
3270		3398
3271	while (my ($name, $info) = each %$res) {	3399	while (my ($name, $info) = each %$res) {
3272	if (defined $info->{type}) {	3400	if (defined $info->{type}) {
3273	my $idx = (cf::face::find $name) || cf::face::alloc $name;	3401	my $idx = (cf::face::find $name) || cf::face::alloc $name;
3274	my $data;
3275		3402
3276	if ($info->{type} & 1) {	3403	cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3277	# prepend meta info
3278
3279	my $meta = $enc->encode ({
3280	name => $name,
3281	%{ $info->{meta} || {} },
3282	});
3283
3284	$data = pack "(w/a*)*", $meta, $info->{data};
3285	} else {
3286	$data = $info->{data};
3287	}
3288
3289	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3290	cf::face::set_type $idx, $info->{type};	3404	cf::face::set_type $idx, $info->{type};
3291	} else {	3405	} else {
3292	$RESOURCE{$name} = $info;	3406	$RESOURCE{$name} = $info;
3293	}	3407	}
3294		3408
…		…
3378		3492
3379	warn "finished reloading resource files\n";	3493	warn "finished reloading resource files\n";
3380	}	3494	}
3381		3495
3382	sub reload_config {	3496	sub reload_config {
		3497	warn "reloading config file...\n";
		3498
3383	open my $fh, "<:utf8", "$CONFDIR/config"	3499	open my $fh, "<:utf8", "$CONFDIR/config"
3384	or return;	3500	or return;
3385		3501
3386	local $/;	3502	local $/;
3387	*CFG = YAML::Load <$fh>;	3503	*CFG = YAML::XS::Load scalar <$fh>;
3388		3504
3389	$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];	3505	$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3390		3506
3391	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};	3507	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3392	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};	3508	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
…		…
3396	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"	3512	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3397	and die "WARNING: m(un)lockall failed: $!\n";	3513	and die "WARNING: m(un)lockall failed: $!\n";
3398	};	3514	};
3399	warn $@ if $@;	3515	warn $@ if $@;
3400	}	3516	}
		3517
		3518	warn "finished reloading resource files\n";
3401	}	3519	}
3402		3520
3403	sub pidfile() {	3521	sub pidfile() {
3404	sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT	3522	sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3405	or die "$PIDFILE: $!";	3523	or die "$PIDFILE: $!";
…		…
3417		3535
3418	seek $fh, 0, 0;	3536	seek $fh, 0, 0;
3419	print $fh $$;	3537	print $fh $$;
3420	}	3538	}
3421		3539
		3540	sub main_loop {
		3541	warn "EV::loop starting\n";
		3542	if (1) {
		3543	EV::loop;
		3544	}
		3545	warn "EV::loop returned\n";
		3546	goto &main_loop unless $REALLY_UNLOOP;
		3547	}
		3548
3422	sub main {	3549	sub main {
3423	cf::init_globals; # initialise logging	3550	cf::init_globals; # initialise logging
3424		3551
3425	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;	3552	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3426	LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";	3553	LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3427	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";	3554	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3428	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";	3555	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3429
3430	cf::init_experience;
3431	cf::init_anim;
3432	cf::init_attackmess;
3433	cf::init_dynamic;
3434	cf::init_block;
3435		3556
3436	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority	3557	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3437		3558
3438	# we must not ever block the main coroutine	3559	# we must not ever block the main coroutine
3439	local $Coro::idle = sub {	3560	local $Coro::idle = sub {
…		…
3445	};	3566	};
3446		3567
3447	evthread_start IO::AIO::poll_fileno;	3568	evthread_start IO::AIO::poll_fileno;
3448		3569
3449	cf::sync_job {	3570	cf::sync_job {
		3571	cf::init_experience;
		3572	cf::init_anim;
		3573	cf::init_attackmess;
		3574	cf::init_dynamic;
		3575
		3576	cf::load_settings;
		3577	cf::load_materials;
		3578
3450	reload_resources;	3579	reload_resources;
3451	reload_config;	3580	reload_config;
3452	db_init;	3581	db_init;
3453		3582
3454	cf::load_settings;
3455	cf::load_materials;
3456	cf::init_uuid;	3583	cf::init_uuid;
3457	cf::init_signals;	3584	cf::init_signals;
3458	cf::init_commands;
3459	cf::init_skills;	3585	cf::init_skills;
3460		3586
3461	cf::init_beforeplay;	3587	cf::init_beforeplay;
3462		3588
3463	atomic;	3589	atomic;
…		…
3465	load_extensions;	3591	load_extensions;
3466		3592
3467	utime time, time, $RUNTIMEFILE;	3593	utime time, time, $RUNTIMEFILE;
3468		3594
3469	# no (long-running) fork's whatsoever before this point(!)	3595	# no (long-running) fork's whatsoever before this point(!)
		3596	use POSIX ();
3470	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};	3597	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3471		3598
3472	(pop @POST_INIT)->(0) while @POST_INIT;	3599	(pop @POST_INIT)->(0) while @POST_INIT;
3473	};	3600	};
3474		3601
3475	EV::loop;	3602	cf::object::thawer::errors_are_fatal 0;
		3603	warn "parse errors in files are no longer fatal from this point on.\n";
		3604
		3605	main_loop;
3476	}	3606	}
3477		3607
3478	#############################################################################	3608	#############################################################################
3479	# initialisation and cleanup	3609	# initialisation and cleanup
3480		3610
3481	# install some emergency cleanup handlers	3611	# install some emergency cleanup handlers
3482	BEGIN {	3612	BEGIN {
3483	our %SIGWATCHER = ();	3613	our %SIGWATCHER = ();
3484	for my $signal (qw(INT HUP TERM)) {	3614	for my $signal (qw(INT HUP TERM)) {
3485	$SIGWATCHER{$signal} = EV::signal $signal, sub {	3615	$SIGWATCHER{$signal} = AE::signal $signal, sub {
3486	cf::cleanup "SIG$signal";	3616	cf::cleanup "SIG$signal";
3487	};	3617	};
3488	}	3618	}
3489	}	3619	}
3490		3620
3491	sub write_runtime_sync {	3621	sub write_runtime_sync {
		3622	my $t0 = AE::time;
		3623
3492	# first touch the runtime file to show we are still running:	3624	# first touch the runtime file to show we are still running:
3493	# the fsync below can take a very very long time.	3625	# the fsync below can take a very very long time.
3494		3626
3495	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;	3627	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3496		3628
3497	my $guard = cf::lock_acquire "write_runtime";	3629	my $guard = cf::lock_acquire "write_runtime";
3498		3630
3499	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644	3631	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3500	or return;	3632	or return;
3501		3633
3502	my $value = $cf::RUNTIME + 90 + 10;	3634	my $value = $cf::RUNTIME + 90 + 10;
3503	# 10 is the runtime save interval, for a monotonic clock	3635	# 10 is the runtime save interval, for a monotonic clock
3504	# 60 allows for the watchdog to kill the server.	3636	# 60 allows for the watchdog to kill the server.
…		…
3517	or return;	3649	or return;
3518		3650
3519	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE	3651	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3520	and return;	3652	and return;
3521		3653
3522	warn "runtime file written.\n";	3654	warn sprintf "runtime file written (%gs).\n", AE::time - $t0;
3523		3655
3524	1	3656	1
3525	}	3657	}
3526		3658
3527	our $uuid_lock;	3659	our $uuid_lock;
…		…
3653	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};	3785	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3654	for my $name (keys %$leaf_symtab) {	3786	for my $name (keys %$leaf_symtab) {
3655	_gv_clear *{"$pkg$name"};	3787	_gv_clear *{"$pkg$name"};
3656	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};	3788	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3657	}	3789	}
3658	warn "cleared package $pkg\n";#d#
3659	}	3790	}
3660		3791
3661	sub do_reload_perl() {	3792	sub do_reload_perl() {
3662	# can/must only be called in main	3793	# can/must only be called in main
3663	if ($Coro::current != $Coro::main) {	3794	if ($Coro::current != $Coro::main) {
…		…
3665	return;	3796	return;
3666	}	3797	}
3667		3798
3668	return if $RELOAD++;	3799	return if $RELOAD++;
3669		3800
3670	my $t1 = EV::time;	3801	my $t1 = AE::time;
3671		3802
3672	while ($RELOAD) {	3803	while ($RELOAD) {
3673	warn "reloading...";	3804	warn "reloading...";
3674		3805
3675	warn "entering sync_job";	3806	warn "entering sync_job";
…		…
3736	clear_package "safe::$_"	3867	clear_package "safe::$_"
3737	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	3868	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3738		3869
3739	warn "unloading cf.pm \"a bit\"";	3870	warn "unloading cf.pm \"a bit\"";
3740	delete $INC{"cf.pm"};	3871	delete $INC{"cf.pm"};
3741	delete $INC{"cf/pod.pm"};	3872	delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3742		3873
3743	# don't, removes xs symbols, too,	3874	# don't, removes xs symbols, too,
3744	# and global variables created in xs	3875	# and global variables created in xs
3745	#clear_package __PACKAGE__;	3876	#clear_package __PACKAGE__;
3746		3877
3747	warn "unload completed, starting to reload now";	3878	warn "unload completed, starting to reload now";
3748		3879
3749	warn "reloading cf.pm";	3880	warn "reloading cf.pm";
3750	require cf;	3881	require cf;
3751	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3882	cf::_connect_to_perl_1;
3752		3883
3753	warn "loading config and database again";	3884	warn "loading config and database again";
3754	cf::reload_config;	3885	cf::reload_config;
3755		3886
3756	warn "loading extensions";	3887	warn "loading extensions";
…		…
3778		3909
3779	warn "reloaded";	3910	warn "reloaded";
3780	--$RELOAD;	3911	--$RELOAD;
3781	}	3912	}
3782		3913
3783	$t1 = EV::time - $t1;	3914	$t1 = AE::time - $t1;
3784	warn "reload completed in ${t1}s\n";	3915	warn "reload completed in ${t1}s\n";
3785	};	3916	};
3786		3917
3787	our $RELOAD_WATCHER; # used only during reload	3918	our $RELOAD_WATCHER; # used only during reload
3788		3919
…		…
3791	# coro crashes during coro_state_free->destroy here.	3922	# coro crashes during coro_state_free->destroy here.
3792		3923
3793	$RELOAD_WATCHER ||= cf::async {	3924	$RELOAD_WATCHER ||= cf::async {
3794	Coro::AIO::aio_wait cache_extensions;	3925	Coro::AIO::aio_wait cache_extensions;
3795		3926
3796	$RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {	3927	$RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3797	do_reload_perl;	3928	do_reload_perl;
3798	undef $RELOAD_WATCHER;	3929	undef $RELOAD_WATCHER;
3799	};	3930	};
3800	};	3931	};
3801	}	3932	}
…		…
3818		3949
3819	our @WAIT_FOR_TICK;	3950	our @WAIT_FOR_TICK;
3820	our @WAIT_FOR_TICK_BEGIN;	3951	our @WAIT_FOR_TICK_BEGIN;
3821		3952
3822	sub wait_for_tick {	3953	sub wait_for_tick {
3823	return if tick_inhibit || $Coro::current == $Coro::main;	3954	return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3824		3955
3825	my $signal = new Coro::Signal;	3956	my $signal = new Coro::Signal;
3826	push @WAIT_FOR_TICK, $signal;	3957	push @WAIT_FOR_TICK, $signal;
3827	$signal->wait;	3958	$signal->wait;
3828	}	3959	}
3829		3960
3830	sub wait_for_tick_begin {	3961	sub wait_for_tick_begin {
3831	return if tick_inhibit || $Coro::current == $Coro::main;	3962	return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3832		3963
3833	my $signal = new Coro::Signal;	3964	my $signal = new Coro::Signal;
3834	push @WAIT_FOR_TICK_BEGIN, $signal;	3965	push @WAIT_FOR_TICK_BEGIN, $signal;
3835	$signal->wait;	3966	$signal->wait;
3836	}	3967	}
…		…
3841	unless ++$bug_warning > 10;	3972	unless ++$bug_warning > 10;
3842	return;	3973	return;
3843	}	3974	}
3844		3975
3845	cf::server_tick; # one server iteration	3976	cf::server_tick; # one server iteration
		3977
		3978	#for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3846		3979
3847	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3980	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3848	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;	3981	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3849	Coro::async_pool {	3982	Coro::async_pool {
3850	$Coro::current->{desc} = "runtime saver";	3983	$Coro::current->{desc} = "runtime saver";
…		…
3873	}	4006	}
3874		4007
3875	{	4008	{
3876	# configure BDB	4009	# configure BDB
3877		4010
3878	BDB::min_parallel 8;	4011	BDB::min_parallel 16;
3879	BDB::max_poll_reqs $TICK * 0.1;	4012	BDB::max_poll_reqs $TICK * 0.1;
3880	$AnyEvent::BDB::WATCHER->priority (1);	4013	$AnyEvent::BDB::WATCHER->priority (1);
3881		4014
3882	unless ($DB_ENV) {	4015	unless ($DB_ENV) {
3883	$DB_ENV = BDB::db_env_create;	4016	$DB_ENV = BDB::db_env_create;
…		…
3963	LOG llevInfo, "[ABT] [suppressed]\n";	4096	LOG llevInfo, "[ABT] [suppressed]\n";
3964	}	4097	}
3965	}	4098	}
3966		4099
3967	# load additional modules	4100	# load additional modules
3968	use cf::pod;	4101	require "cf/$_.pm" for @EXTRA_MODULES;
		4102	cf::_connect_to_perl_2;
3969		4103
3970	END { cf::emergency_save }	4104	END { cf::emergency_save }
3971		4105
3972	1	4106	1
3973		4107

Diff Legend

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