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.444 by root, Mon Sep 8 11:27:25 2008 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;
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
…		…
63		66
64	# configure various modules to our taste	67	# configure various modules to our taste
65	#	68	#
66	$Storable::canonical = 1; # reduce rsync transfers	69	$Storable::canonical = 1; # reduce rsync transfers
67	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator	70	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
		71
		72	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
		73
		74	# make sure c-lzf reinitialises itself
		75	Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
68	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
69		77
70	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority	78	# strictly for debugging
		79	$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
71		80
72	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	81	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
73		82
74	our %COMMAND = ();	83	our %COMMAND = ();
75	our %COMMAND_TIME = ();	84	our %COMMAND_TIME = ();
…		…
78	our %EXTCMD = ();	87	our %EXTCMD = ();
79	our %EXTICMD = ();	88	our %EXTICMD = ();
80	our %EXT_CORO = (); # coroutines bound to extensions	89	our %EXT_CORO = (); # coroutines bound to extensions
81	our %EXT_MAP = (); # pluggable maps	90	our %EXT_MAP = (); # pluggable maps
82		91
83	our $RELOAD; # number of reloads so far	92	our $RELOAD; # number of reloads so far, non-zero while in reload
84	our @EVENT;	93	our @EVENT;
		94	our @REFLECT; # set by XS
		95	our %REFLECT; # set by us
85		96
86	our $CONFDIR = confdir;	97	our $CONFDIR = confdir;
87	our $DATADIR = datadir;	98	our $DATADIR = datadir;
88	our $LIBDIR = "$DATADIR/ext";	99	our $LIBDIR = "$DATADIR/ext";
89	our $PODDIR = "$DATADIR/pod";	100	our $PODDIR = "$DATADIR/pod";
90	our $MAPDIR = "$DATADIR/" . mapdir;	101	our $MAPDIR = "$DATADIR/" . mapdir;
91	our $LOCALDIR = localdir;	102	our $LOCALDIR = localdir;
92	our $TMPDIR = "$LOCALDIR/" . tmpdir;	103	our $TMPDIR = "$LOCALDIR/" . tmpdir;
93	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;	104	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
94	our $PLAYERDIR = "$LOCALDIR/" . playerdir;	105	our $PLAYERDIR = "$LOCALDIR/" . playerdir;
95	our $RANDOMDIR = "$LOCALDIR/random";	106	our $RANDOMDIR = "$LOCALDIR/random";
96	our $BDBDIR = "$LOCALDIR/db";	107	our $BDBDIR = "$LOCALDIR/db";
		108	our $PIDFILE = "$LOCALDIR/pid";
		109	our $RUNTIMEFILE = "$LOCALDIR/runtime";
		110
97	our %RESOURCE;	111	our %RESOURCE;
		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;
98		118
99	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	119	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
100	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	120	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
101	our $NEXT_TICK;	121	our $NEXT_TICK;
102	our $USE_FSYNC = 1; # use fsync to write maps - default off	122	our $USE_FSYNC = 1; # use fsync to write maps - default on
103		123
104	our $BDB_DEADLOCK_WATCHER;	124	our $BDB_DEADLOCK_WATCHER;
105	our $BDB_CHECKPOINT_WATCHER;	125	our $BDB_CHECKPOINT_WATCHER;
106	our $BDB_TRICKLE_WATCHER;	126	our $BDB_TRICKLE_WATCHER;
107	our $DB_ENV;	127	our $DB_ENV;
108		128
		129	our @EXTRA_MODULES = qw(pod match mapscript);
		130
109	our %CFG;	131	our %CFG;
110		132
111	our $UPTIME; $UPTIME ||= time;	133	our $UPTIME; $UPTIME ||= time;
112	our $RUNTIME;	134	our $RUNTIME;
113	our $NOW;	135	our $NOW;
…		…
122	our $LOAD; # a number between 0 (idle) and 1 (too many objects)	144	our $LOAD; # a number between 0 (idle) and 1 (too many objects)
123	our $LOADAVG; # same thing, but with alpha-smoothing	145	our $LOADAVG; # same thing, but with alpha-smoothing
124	our $JITTER; # average jitter	146	our $JITTER; # average jitter
125	our $TICK_START; # for load detecting purposes	147	our $TICK_START; # for load detecting purposes
126		148
		149	our @POST_INIT;
		150
		151	our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
		152	our $REALLY_UNLOOP; # never set to true, please :)
		153
127	binmode STDOUT;	154	binmode STDOUT;
128	binmode STDERR;	155	binmode STDERR;
129		156
130	# read virtual server time, if available	157	# read virtual server time, if available
131	unless ($RUNTIME || !-e "$LOCALDIR/runtime") {	158	unless ($RUNTIME || !-e $RUNTIMEFILE) {
132	open my $fh, "<", "$LOCALDIR/runtime"	159	open my $fh, "<", $RUNTIMEFILE
133	or die "unable to read runtime file: $!";	160	or die "unable to read $RUNTIMEFILE file: $!";
134	$RUNTIME = <$fh> + 0.;	161	$RUNTIME = <$fh> + 0.;
135	}	162	}
		163
		164	eval "sub TICK() { $TICK } 1" or die;
136		165
137	mkdir $_	166	mkdir $_
138	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;	167	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
139		168
140	our $EMERGENCY_POSITION;	169	our $EMERGENCY_POSITION;
141		170
142	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::"} };
143		187
144	#############################################################################	188	#############################################################################
145		189
146	=head2 GLOBAL VARIABLES	190	=head2 GLOBAL VARIABLES
147		191
…		…
194	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
195	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.
196		240
197	=item @cf::INVOKE_RESULTS	241	=item @cf::INVOKE_RESULTS
198		242
199	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
200	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
201	that call.	245	that call.
202		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
203	=back	253	=back
204		254
205	=cut	255	=cut
206		256
207	BEGIN {	257	$Coro::State::WARNHOOK = sub {
208	*CORE::GLOBAL::warn = sub {
209	my $msg = join "", @_;	258	my $msg = join "", @_;
210		259
211	$msg .= "\n"	260	$msg .= "\n"
212	unless $msg =~ /\n$/;	261	unless $msg =~ /\n$/;
213		262
214	$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;
215		264
216	LOG llevError, $msg;	265	LOG llevError, $msg;
217	};	266	};
218	}
219		267
220	$Coro::State::DIEHOOK = sub {	268	$Coro::State::DIEHOOK = sub {
221	return unless $^S eq 0; # "eq", not "=="	269	return unless $^S eq 0; # "eq", not "=="
222		270
223	if ($Coro::current == $Coro::main) {#d#	271	warn Carp::longmess $_[0];
		272
		273	if (in_main) {#d#
224	warn "DIEHOOK called in main context, Coro bug?\n";#d#	274	warn "DIEHOOK called in main context, Coro bug?\n";#d#
225	return;#d#	275	return;#d#
226	}#d#	276	}#d#
227		277
228	# kill coroutine otherwise	278	# kill coroutine otherwise
229	warn Carp::longmess $_[0];
230	Coro::terminate	279	Coro::terminate
231	};	280	};
232
233	$SIG{__DIE__} = sub { }; #d#?
234		281
235	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	282	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
236	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';	283	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
237	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';	284	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
238	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';	285	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
…		…
252	)) {	299	)) {
253	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	300	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
254	}	301	}
255		302
256	$EV::DIED = sub {	303	$EV::DIED = sub {
257	warn "error in event callback: @_";	304	Carp::cluck "error in event callback: @_";
258	};	305	};
259		306
260	#############################################################################	307	#############################################################################
261		308
262	=head2 UTILITY FUNCTIONS	309	=head2 UTILITY FUNCTIONS
…		…
299	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max	346	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
300		347
301	sub encode_json($) { $json_coder->encode ($_[0]) }	348	sub encode_json($) { $json_coder->encode ($_[0]) }
302	sub decode_json($) { $json_coder->decode ($_[0]) }	349	sub decode_json($) { $json_coder->decode ($_[0]) }
303		350
		351	=item cf::post_init { BLOCK }
		352
		353	Execute the given codeblock, I<after> all extensions have been (re-)loaded,
		354	but I<before> the server starts ticking again.
		355
		356	The cdoeblock will have a single boolean argument to indicate whether this
		357	is a reload or not.
		358
		359	=cut
		360
		361	sub post_init(&) {
		362	push @POST_INIT, shift;
		363	}
		364
304	=item cf::lock_wait $string	365	=item cf::lock_wait $string
305		366
306	Wait until the given lock is available. See cf::lock_acquire.	367	Wait until the given lock is available. See cf::lock_acquire.
307		368
308	=item my $lock = cf::lock_acquire $string	369	=item my $lock = cf::lock_acquire $string
309		370
310	Wait until the given lock is available and then acquires it and returns	371	Wait until the given lock is available and then acquires it and returns
311	a Coro::guard object. If the guard object gets destroyed (goes out of scope,	372	a L<Guard> object. If the guard object gets destroyed (goes out of scope,
312	for example when the coroutine gets canceled), the lock is automatically	373	for example when the coroutine gets canceled), the lock is automatically
313	returned.	374	returned.
314		375
315	Locks are *not* recursive, locking from the same coro twice results in a	376	Locks are *not* recursive, locking from the same coro twice results in a
316	deadlocked coro.	377	deadlocked coro.
…		…
322		383
323	Return true if the lock is currently active, i.e. somebody has locked it.	384	Return true if the lock is currently active, i.e. somebody has locked it.
324		385
325	=cut	386	=cut
326		387
327	our %LOCK;	388	our $LOCKS = new Coro::SemaphoreSet;
328	our %LOCKER;#d#
329		389
330	sub lock_wait($) {	390	sub lock_wait($) {
331	my ($key) = @_;	391	$LOCKS->wait ($_[0]);
332
333	if ($LOCKER{$key} == $Coro::current) {#d#
334	Carp::cluck "lock_wait($key) for already-acquired lock";#d#
335	return;#d#
336	}#d#
337
338	# wait for lock, if any
339	while ($LOCK{$key}) {
340	push @{ $LOCK{$key} }, $Coro::current;
341	Coro::schedule;
342	}
343	}	392	}
344		393
345	sub lock_acquire($) {	394	sub lock_acquire($) {
346	my ($key) = @_;	395	$LOCKS->guard ($_[0])
347
348	# wait, to be sure we are not locked
349	lock_wait $key;
350
351	$LOCK{$key} = [];
352	$LOCKER{$key} = $Coro::current;#d#
353
354	Coro::guard {
355	delete $LOCKER{$key};#d#
356	# wake up all waiters, to be on the safe side
357	$_->ready for @{ delete $LOCK{$key} };
358	}
359	}	396	}
360		397
361	sub lock_active($) {	398	sub lock_active($) {
362	my ($key) = @_;	399	$LOCKS->count ($_[0]) < 1
363
364	! ! $LOCK{$key}
365	}	400	}
366		401
367	sub freeze_mainloop {	402	sub freeze_mainloop {
368	tick_inhibit_inc;	403	tick_inhibit_inc;
369		404
370	Coro::guard \&tick_inhibit_dec;	405	&Guard::guard (\&tick_inhibit_dec);
371	}	406	}
372		407
373	=item cf::periodic $interval, $cb	408	=item cf::periodic $interval, $cb
374		409
375	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
376	get spread over timer.	411	get spread over time.
377		412
378	=cut	413	=cut
379		414
380	sub periodic($$) {	415	sub periodic($$) {
381	my ($interval, $cb) = @_;	416	my ($interval, $cb) = @_;
…		…
398		433
399	=cut	434	=cut
400		435
401	our @SLOT_QUEUE;	436	our @SLOT_QUEUE;
402	our $SLOT_QUEUE;	437	our $SLOT_QUEUE;
		438	our $SLOT_DECAY = 0.9;
403		439
404	$SLOT_QUEUE->cancel if $SLOT_QUEUE;	440	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
405	$SLOT_QUEUE = Coro::async {	441	$SLOT_QUEUE = Coro::async {
406	$Coro::current->desc ("timeslot manager");	442	$Coro::current->desc ("timeslot manager");
407		443
408	my $signal = new Coro::Signal;	444	my $signal = new Coro::Signal;
		445	my $busy;
409		446
410	while () {	447	while () {
411	next_job:	448	next_job:
		449
412	my $avail = cf::till_tick;	450	my $avail = cf::till_tick;
413	if ($avail > 0.01) {	451
414	for (0 .. $#SLOT_QUEUE) {	452	for (0 .. $#SLOT_QUEUE) {
415	if ($SLOT_QUEUE[$_][0] < $avail) {	453	if ($SLOT_QUEUE[$_][0] <= $avail) {
		454	$busy = 0;
416	my $job = splice @SLOT_QUEUE, $_, 1, ();	455	my $job = splice @SLOT_QUEUE, $_, 1, ();
417	$job->[2]->send;	456	$job->[2]->send;
418	Coro::cede;	457	Coro::cede;
419	goto next_job;	458	goto next_job;
420	}	459	} else {
		460	$SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
421	}	461	}
422	}	462	}
423		463
424	if (@SLOT_QUEUE) {	464	if (@SLOT_QUEUE) {
425	# 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
426	push @cf::WAIT_FOR_TICK, $signal;	466	push @cf::WAIT_FOR_TICK, $signal;
427	$signal->wait;	467	$signal->wait;
428	} else {	468	} else {
		469	$busy = 0;
429	Coro::schedule;	470	Coro::schedule;
430	}	471	}
431	}	472	}
432	};	473	};
433		474
434	sub get_slot($;$$) {	475	sub get_slot($;$$) {
435	return if tick_inhibit || $Coro::current == $Coro::main;	476	return if tick_inhibit || $Coro::current == $Coro::main;
436		477
437	my ($time, $pri, $name) = @_;	478	my ($time, $pri, $name) = @_;
438		479
439	$time = $TICK * .6 if $time > $TICK * .6;	480	$time = clamp $time, 0.01, $TICK * .6;
		481
440	my $sig = new Coro::Signal;	482	my $sig = new Coro::Signal;
441		483
442	push @SLOT_QUEUE, [$time, $pri, $sig, $name];	484	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
443	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;	485	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
444	$SLOT_QUEUE->ready;	486	$SLOT_QUEUE->ready;
…		…
471		513
472	sub sync_job(&) {	514	sub sync_job(&) {
473	my ($job) = @_;	515	my ($job) = @_;
474		516
475	if ($Coro::current == $Coro::main) {	517	if ($Coro::current == $Coro::main) {
476	my $time = EV::time;	518	my $time = AE::time;
477		519
478	# this is the main coro, too bad, we have to block	520	# this is the main coro, too bad, we have to block
479	# till the operation succeeds, freezing the server :/	521	# till the operation succeeds, freezing the server :/
480		522
481	LOG llevError, Carp::longmess "sync job";#d#	523	LOG llevError, Carp::longmess "sync job";#d#
…		…
498	} else {	540	} else {
499	EV::loop EV::LOOP_ONESHOT;	541	EV::loop EV::LOOP_ONESHOT;
500	}	542	}
501	}	543	}
502		544
503	my $time = EV::time - $time;	545	my $time = AE::time - $time;
504		546
505	$TICK_START += $time; # do not account sync jobs to server load	547	$TICK_START += $time; # do not account sync jobs to server load
506		548
507	wantarray ? @res : $res[0]	549	wantarray ? @res : $res[0]
508	} else {	550	} else {
…		…
552	reset_signals;	594	reset_signals;
553	&$cb	595	&$cb
554	}, @args;	596	}, @args;
555		597
556	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	)
557	}	610	}
558		611
559	=item $coin = coin_from_name $name	612	=item $coin = coin_from_name $name
560		613
561	=cut	614	=cut
…		…
727		780
728	#############################################################################	781	#############################################################################
729		782
730	=head2 ATTACHABLE OBJECTS	783	=head2 ATTACHABLE OBJECTS
731		784
732	Many objects in crossfire are so-called attachable objects. That means you can	785	Many objects in deliantra are so-called attachable objects. That means you can
733	attach callbacks/event handlers (a collection of which is called an "attachment")	786	attach callbacks/event handlers (a collection of which is called an "attachment")
734	to it. All such attachable objects support the following methods.	787	to it. All such attachable objects support the following methods.
735		788
736	In the following description, CLASS can be any of C<global>, C<object>	789	In the following description, CLASS can be any of C<global>, C<object>
737	C<player>, C<client> or C<map> (i.e. the attachable objects in	790	C<player>, C<client> or C<map> (i.e. the attachable objects in
…		…
787	=item cf::CLASS::attachment $name, ...	840	=item cf::CLASS::attachment $name, ...
788		841
789	Register an attachment by C<$name> through which attachable objects of the	842	Register an attachment by C<$name> through which attachable objects of the
790	given CLASS can refer to this attachment.	843	given CLASS can refer to this attachment.
791		844
792	Some classes such as crossfire maps and objects can specify attachments	845	Some classes such as deliantra maps and objects can specify attachments
793	that are attached at load/instantiate time, thus the need for a name.	846	that are attached at load/instantiate time, thus the need for a name.
794		847
795	These calls expect any number of the following handler/hook descriptions:	848	These calls expect any number of the following handler/hook descriptions:
796		849
797	=over 4	850	=over 4
…		…
1142		1195
1143	sync_job {	1196	sync_job {
1144	if (length $$rdata) {	1197	if (length $$rdata) {
1145	utf8::decode (my $decname = $filename);	1198	utf8::decode (my $decname = $filename);
1146	warn sprintf "saving %s (%d,%d)\n",	1199	warn sprintf "saving %s (%d,%d)\n",
1147	$decname, length $$rdata, scalar @$objs;	1200	$decname, length $$rdata, scalar @$objs
		1201	if $VERBOSE_IO;
1148		1202
1149	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {	1203	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1150	aio_chmod $fh, SAVE_MODE;	1204	aio_chmod $fh, SAVE_MODE;
1151	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1205	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1152	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	}
1153	aio_close $fh;	1210	aio_close $fh;
1154		1211
1155	if (@$objs) {	1212	if (@$objs) {
1156	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) {
1157	aio_chmod $fh, SAVE_MODE;	1214	aio_chmod $fh, SAVE_MODE;
1158	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };	1215	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1159	aio_write $fh, 0, (length $data), $data, 0;	1216	aio_write $fh, 0, (length $data), $data, 0;
1160	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	}
1161	aio_close $fh;	1221	aio_close $fh;
1162	aio_rename "$filename.pst~", "$filename.pst";	1222	aio_rename "$filename.pst~", "$filename.pst";
1163	}	1223	}
1164	} else {	1224	} else {
1165	aio_unlink "$filename.pst";	1225	aio_unlink "$filename.pst";
1166	}	1226	}
1167		1227
1168	aio_rename "$filename~", $filename;	1228	aio_rename "$filename~", $filename;
		1229
		1230	$filename =~ s%/[^/]+$%%;
		1231	aio_pathsync $filename if $cf::USE_FSYNC;
1169	} else {	1232	} else {
1170	warn "FATAL: $filename~: $!\n";	1233	warn "unable to save objects: $filename~: $!\n";
1171	}	1234	}
1172	} else {	1235	} else {
1173	aio_unlink $filename;	1236	aio_unlink $filename;
1174	aio_unlink "$filename.pst";	1237	aio_unlink "$filename.pst";
1175	}	1238	}
…		…
1200	$av = $st->{objs};	1263	$av = $st->{objs};
1201	}	1264	}
1202		1265
1203	utf8::decode (my $decname = $filename);	1266	utf8::decode (my $decname = $filename);
1204	warn sprintf "loading %s (%d,%d)\n",	1267	warn sprintf "loading %s (%d,%d)\n",
1205	$decname, length $data, scalar @{$av || []};	1268	$decname, length $data, scalar @{$av || []}
		1269	if $VERBOSE_IO;
1206		1270
1207	($data, $av)	1271	($data, $av)
1208	}	1272	}
1209		1273
1210	=head2 COMMAND CALLBACKS	1274	=head2 COMMAND CALLBACKS
…		…
1266	my ($name, $cb) = @_;	1330	my ($name, $cb) = @_;
1267		1331
1268	$EXTICMD{$name} = $cb;	1332	$EXTICMD{$name} = $cb;
1269	}	1333	}
1270		1334
		1335	use File::Glob ();
		1336
1271	cf::player->attach (	1337	cf::player->attach (
1272	on_command => sub {	1338	on_unknown_command => sub {
1273	my ($pl, $name, $params) = @_;	1339	my ($pl, $name, $params) = @_;
1274		1340
1275	my $cb = $COMMAND{$name}	1341	my $cb = $COMMAND{$name}
1276	or return;	1342	or return;
1277		1343
…		…
1307		1373
1308	cf::override;	1374	cf::override;
1309	},	1375	},
1310	);	1376	);
1311		1377
		1378	# "readahead" all extensions
		1379	sub cache_extensions {
		1380	my $grp = IO::AIO::aio_group;
		1381
		1382	add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
		1383	for (grep /\.ext$/, @{$_[0]}) {
		1384	add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
		1385	}
		1386	};
		1387
		1388	$grp
		1389	}
		1390
1312	sub load_extensions {	1391	sub load_extensions {
1313	cf::sync_job {	1392	cf::sync_job {
1314	my %todo;	1393	my %todo;
1315		1394
1316	for my $path (<$LIBDIR/*.ext>) {	1395	for my $path (<$LIBDIR/*.ext>) {
…		…
1343	. "\n};\n1";	1422	. "\n};\n1";
1344		1423
1345	$todo{$base} = \%ext;	1424	$todo{$base} = \%ext;
1346	}	1425	}
1347		1426
		1427	my $pass = 0;
1348	my %done;	1428	my %done;
1349	while (%todo) {	1429	while (%todo) {
1350	my $progress;	1430	my $progress;
1351		1431
		1432	++$pass;
		1433
		1434	ext:
1352	while (my ($k, $v) = each %todo) {	1435	while (my ($k, $v) = each %todo) {
1353	for (split /,\s*/, $v->{meta}{depends}) {	1436	for (split /,\s*/, $v->{meta}{depends}) {
1354	goto skip	1437	next ext
1355	unless exists $done{$_};	1438	unless exists $done{$_};
1356	}	1439	}
1357		1440
1358	warn "... loading '$k' into '$v->{pkg}'\n";	1441	warn "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1359		1442
1360	unless (eval $v->{source}) {	1443	my $active = eval $v->{source};
		1444
		1445	if (length $@) {
1361	my $msg = $@ ? "$v->{path}: $@\n"	1446	warn "$v->{path}: $@\n";
1362	: "$v->{base}: extension inactive.\n";
1363		1447
1364	if (exists $v->{meta}{mandatory}) {
1365	warn $msg;
1366	cf::cleanup "mandatory extension failed to load, exiting.";	1448	cf::cleanup "mandatory extension '$k' failed to load, exiting."
1367	}	1449	if exists $v->{meta}{mandatory};
1368		1450
1369	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;
1370	}	1460	}
1371
1372	$done{$k} = delete $todo{$k};
1373	push @EXTS, $v->{pkg};
1374	$progress = 1;
1375	}	1461	}
1376		1462
1377	skip:	1463	unless ($progress) {
1378	die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"	1464	warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1379	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	}
1380	}	1471	}
1381	};	1472	};
1382	}	1473	}
1383		1474
1384	#############################################################################	1475	#############################################################################
1385		1476
1386	=back	1477	=back
1387		1478
1388	=head2 CORE EXTENSIONS	1479	=head2 CORE EXTENSIONS
1389		1480
1390	Functions and methods that extend core crossfire objects.	1481	Functions and methods that extend core deliantra objects.
1391		1482
1392	=cut	1483	=cut
1393		1484
1394	package cf::player;	1485	package cf::player;
1395		1486
…		…
1438		1529
1439	sub exists($) {	1530	sub exists($) {
1440	my ($login) = @_;	1531	my ($login) = @_;
1441		1532
1442	$cf::PLAYER{$login}	1533	$cf::PLAYER{$login}
1443	or cf::sync_job { !aio_stat path $login }	1534	or !aio_stat path $login
1444	}	1535	}
1445		1536
1446	sub find($) {	1537	sub find($) {
1447	return $cf::PLAYER{$_[0]} || do {	1538	return $cf::PLAYER{$_[0]} || do {
1448	my $login = $_[0];	1539	my $login = $_[0];
…		…
1468	$cf::PLAYER{$login} = $pl	1559	$cf::PLAYER{$login} = $pl
1469	}	1560	}
1470	}	1561	}
1471	}	1562	}
1472		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
1473	sub save($) {	1577	sub save($) {
1474	my ($pl) = @_;	1578	my ($pl) = @_;
1475		1579
1476	return if $pl->{deny_save};	1580	return if $pl->{deny_save};
1477		1581
…		…
1482		1586
1483	aio_mkdir playerdir $pl, 0770;	1587	aio_mkdir playerdir $pl, 0770;
1484	$pl->{last_save} = $cf::RUNTIME;	1588	$pl->{last_save} = $cf::RUNTIME;
1485		1589
1486	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];
1487		1594
1488	$pl->save_pl ($path);	1595	$pl->save_pl ($path);
1489	cf::cede_to_tick;	1596	cf::cede_to_tick;
1490	}	1597	}
1491		1598
…		…
1528	$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
1529		1636
1530	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;	1637	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1531	$pl->deactivate;	1638	$pl->deactivate;
1532	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;
1533	$pl->ob->check_score;
1534	$pl->invoke (cf::EVENT_PLAYER_QUIT);	1640	$pl->invoke (cf::EVENT_PLAYER_QUIT);
1535	$pl->ns->destroy if $pl->ns;	1641	$pl->ns->destroy if $pl->ns;
1536		1642
1537	my $path = playerdir $pl;	1643	my $path = playerdir $pl;
1538	my $temp = "$path~$cf::RUNTIME~deleting~";	1644	my $temp = "$path~$cf::RUNTIME~deleting~";
…		…
1593	\@logins	1699	\@logins
1594	}	1700	}
1595		1701
1596	=item $player->maps	1702	=item $player->maps
1597		1703
		1704	=item cf::player::maps $login
		1705
1598	Returns an arrayref of map paths that are private for this	1706	Returns an arrayref of map paths that are private for this
1599	player. May block.	1707	player. May block.
1600		1708
1601	=cut	1709	=cut
1602		1710
…		…
1619	}	1727	}
1620		1728
1621	\@paths	1729	\@paths
1622	}	1730	}
1623		1731
1624	=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)	1732	=item $protocol_xml = $player->expand_cfpod ($cfpod)
1625		1733
1626	Expand crossfire pod fragments into protocol xml.	1734	Expand deliantra pod fragments into protocol xml.
1627		1735
1628	=item $player->ext_reply ($msgid, @msg)	1736	=item $player->ext_reply ($msgid, @msg)
1629		1737
1630	Sends an ext reply to the player.	1738	Sends an ext reply to the player.
1631		1739
…		…
1663		1771
1664	=cut	1772	=cut
1665		1773
1666	sub find_by_path($) {	1774	sub find_by_path($) {
1667	my ($path) = @_;	1775	my ($path) = @_;
		1776
		1777	$path =~ s/^~[^\/]*//; # skip ~login
1668		1778
1669	my ($match, $specificity);	1779	my ($match, $specificity);
1670		1780
1671	for my $region (list) {	1781	for my $region (list) {
1672	if ($region->{match} && $path =~ $region->{match}) {	1782	if ($region->{match} && $path =~ $region->{match}) {
…		…
1704	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
1705		1815
1706	# mit "rum" bekleckern, nicht	1816	# mit "rum" bekleckern, nicht
1707	$self->_create_random_map (	1817	$self->_create_random_map (
1708	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},	1818	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1709	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},	1819	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1710	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},	1820	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1711	$rmp->{exit_on_final_map},	1821	$rmp->{exit_on_final_map},
1712	$rmp->{xsize}, $rmp->{ysize},	1822	$rmp->{xsize}, $rmp->{ysize},
1713	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},	1823	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1714	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},	1824	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
…		…
1736		1846
1737	$EXT_MAP{$pkg} = [$prio, qr<$regex>];	1847	$EXT_MAP{$pkg} = [$prio, qr<$regex>];
1738	}	1848	}
1739		1849
1740	# also paths starting with '/'	1850	# also paths starting with '/'
1741	$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];	1851	$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1742		1852
1743	sub thawer_merge {	1853	sub thawer_merge {
1744	my ($self, $merge) = @_;	1854	my ($self, $merge) = @_;
1745		1855
1746	# we have to keep some variables in memory intact	1856	# we have to keep some variables in memory intact
…		…
1844		1954
1845	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;	1955	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1846	"$UNIQUEDIR/$path"	1956	"$UNIQUEDIR/$path"
1847	}	1957	}
1848		1958
1849	# and all this just because we cannot iterate over
1850	# all maps in C++...
1851	sub change_all_map_light {
1852	my ($change) = @_;
1853
1854	$_->change_map_light ($change)
1855	for grep $_->outdoor, values %cf::MAP;
1856	}
1857
1858	sub decay_objects {	1959	sub decay_objects {
1859	my ($self) = @_;	1960	my ($self) = @_;
1860		1961
1861	return if $self->{deny_reset};	1962	return if $self->{deny_reset};
1862		1963
…		…
1944	sub find {	2045	sub find {
1945	my ($path, $origin) = @_;	2046	my ($path, $origin) = @_;
1946		2047
1947	$path = normalise $path, $origin && $origin->path;	2048	$path = normalise $path, $origin && $origin->path;
1948		2049
1949	cf::lock_wait "map_data:$path";#d#remove	2050	my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1950	cf::lock_wait "map_find:$path";	2051	my $guard2 = cf::lock_acquire "map_find:$path";
1951		2052
1952	$cf::MAP{$path} || do {	2053	$cf::MAP{$path} || do {
1953	my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1954	my $guard2 = cf::lock_acquire "map_find:$path";
1955
1956	my $map = new_from_path cf::map $path	2054	my $map = new_from_path cf::map $path
1957	or return;	2055	or return;
1958		2056
1959	$map->{last_save} = $cf::RUNTIME;	2057	$map->{last_save} = $cf::RUNTIME;
1960		2058
…		…
1972		2070
1973	$cf::MAP{$path} = $map	2071	$cf::MAP{$path} = $map
1974	}	2072	}
1975	}	2073	}
1976		2074
1977	sub pre_load { }	2075	sub pre_load { }
1978	sub post_load { }	2076	#sub post_load { } # XS
1979		2077
1980	sub load {	2078	sub load {
1981	my ($self) = @_;	2079	my ($self) = @_;
1982		2080
1983	local $self->{deny_reset} = 1; # loading can take a long time	2081	local $self->{deny_reset} = 1; # loading can take a long time
…		…
2028	unless ($self->{deny_activate}) {	2126	unless ($self->{deny_activate}) {
2029	$self->decay_objects;	2127	$self->decay_objects;
2030	$self->fix_auto_apply;	2128	$self->fix_auto_apply;
2031	$self->update_buttons;	2129	$self->update_buttons;
2032	cf::cede_to_tick;	2130	cf::cede_to_tick;
2033	$self->set_darkness_map;
2034	cf::cede_to_tick;
2035	$self->activate;	2131	$self->activate;
2036	}	2132	}
2037		2133
2038	$self->{last_save} = $cf::RUNTIME;	2134	$self->{last_save} = $cf::RUNTIME;
2039	$self->last_access ($cf::RUNTIME);	2135	$self->last_access ($cf::RUNTIME);
…		…
2042	}	2138	}
2043		2139
2044	$self->post_load;	2140	$self->post_load;
2045	}	2141	}
2046		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
2047	sub customise_for {	2146	sub customise_for {
2048	my ($self, $ob) = @_;	2147	my ($self, $ob) = @_;
2049		2148
2050	return find "~" . $ob->name . "/" . $self->{path}	2149	return find "~" . $ob->name . "/" . $self->{path}
2051	if $self->per_player;	2150	if $self->per_player;
…		…
2067	or next;	2166	or next;
2068	$neigh = find $neigh, $map	2167	$neigh = find $neigh, $map
2069	or next;	2168	or next;
2070	$neigh->load;	2169	$neigh->load;
2071		2170
		2171	# now find the diagonal neighbours
2072	push @neigh,	2172	push @neigh,
2073	[$neigh->tile_path (($_ + 3) % 4), $neigh],	2173	[$neigh->tile_path (($_ + 3) % 4), $neigh],
2074	[$neigh->tile_path (($_ + 1) % 4), $neigh];	2174	[$neigh->tile_path (($_ + 1) % 4), $neigh];
2075	}	2175	}
2076		2176
…		…
2128	$MAP_PREFETCHER->prio (6);	2228	$MAP_PREFETCHER->prio (6);
2129		2229
2130	()	2230	()
2131	}	2231	}
2132		2232
		2233	# common code, used by both ->save and ->swapout
2133	sub save {	2234	sub _save {
2134	my ($self) = @_;	2235	my ($self) = @_;
2135
2136	my $lock = cf::lock_acquire "map_data:$self->{path}";
2137		2236
2138	$self->{last_save} = $cf::RUNTIME;	2237	$self->{last_save} = $cf::RUNTIME;
2139		2238
2140	return unless $self->dirty;	2239	return unless $self->dirty;
2141		2240
…		…
2161	} else {	2260	} else {
2162	$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);
2163	}	2262	}
2164	}	2263	}
2165		2264
		2265	sub save {
		2266	my ($self) = @_;
		2267
		2268	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2269
		2270	$self->_save;
		2271	}
		2272
2166	sub swap_out {	2273	sub swap_out {
2167	my ($self) = @_;	2274	my ($self) = @_;
2168		2275
2169	# save first because save cedes
2170	$self->save;
2171
2172	my $lock = cf::lock_acquire "map_data:$self->{path}";	2276	my $lock = cf::lock_acquire "map_data:$self->{path}";
2173		2277
2174	return if $self->players;
2175	return if $self->in_memory != cf::MAP_ACTIVE;	2278	return if $self->in_memory != cf::MAP_ACTIVE;
2176	return if $self->{deny_save};	2279	return if $self->{deny_save};
		2280	return if $self->players;
2177		2281
		2282	# first deactivate the map and "unlink" it from the core
		2283	$self->deactivate;
		2284	$_->clear_links_to ($self) for values %cf::MAP;
2178	$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};
2179		2332
2180	$self->deactivate;	2333	$self->deactivate;
2181	$_->clear_links_to ($self) for values %cf::MAP;	2334	$_->clear_links_to ($self) for values %cf::MAP;
2182	$self->clear;	2335	$self->clear;
2183	}
2184
2185	sub reset_at {
2186	my ($self) = @_;
2187
2188	# TODO: safety, remove and allow resettable per-player maps
2189	return 1e99 if $self->{deny_reset};
2190
2191	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2192	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2193
2194	$time + $to
2195	}
2196
2197	sub should_reset {
2198	my ($self) = @_;
2199
2200	$self->reset_at <= $cf::RUNTIME
2201	}
2202
2203	sub reset {
2204	my ($self) = @_;
2205
2206	my $lock = cf::lock_acquire "map_data:$self->{path}";
2207
2208	return if $self->players;
2209
2210	warn "resetting map ", $self->path;
2211
2212	$self->in_memory (cf::MAP_SWAPPED);
2213
2214	# need to save uniques path
2215	unless ($self->{deny_save}) {
2216	my $uniq = $self->uniq_path; utf8::encode $uniq;
2217
2218	$self->_save_objects ($uniq, cf::IO_UNIQUES)
2219	if $uniq;
2220	}
2221
2222	delete $cf::MAP{$self->path};
2223
2224	$self->deactivate;
2225	$_->clear_links_to ($self) for values %cf::MAP;
2226	$self->clear;
2227		2336
2228	$self->unlink_save;	2337	$self->unlink_save;
2229	$self->destroy;	2338	$self->destroy;
2230	}	2339	}
2231		2340
…		…
2239		2348
2240	delete $cf::MAP{$self->path};	2349	delete $cf::MAP{$self->path};
2241		2350
2242	$self->unlink_save;	2351	$self->unlink_save;
2243		2352
2244	bless $self, "cf::map";	2353	bless $self, "cf::map::wrap";
2245	delete $self->{deny_reset};	2354	delete $self->{deny_reset};
2246	$self->{deny_save} = 1;	2355	$self->{deny_save} = 1;
2247	$self->reset_timeout (1);	2356	$self->reset_timeout (1);
2248	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2357	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2249		2358
…		…
2306	: normalise $_	2415	: normalise $_
2307	} @{ aio_readdir $UNIQUEDIR or [] }	2416	} @{ aio_readdir $UNIQUEDIR or [] }
2308	]	2417	]
2309	}	2418	}
2310		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
2311	=back	2452	=back
2312		2453
2313	=head3 cf::object	2454	=head3 cf::object
2314		2455
2315	=cut	2456	=cut
…		…
2380		2521
2381	our $SAY_CHANNEL = {	2522	our $SAY_CHANNEL = {
2382	id => "say",	2523	id => "say",
2383	title => "Map",	2524	title => "Map",
2384	reply => "say ",	2525	reply => "say ",
2385	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.",
2386	};	2527	};
2387		2528
2388	our $CHAT_CHANNEL = {	2529	our $CHAT_CHANNEL = {
2389	id => "chat",	2530	id => "chat",
2390	title => "Chat",	2531	title => "Chat",
…		…
2445		2586
2446	=item $player_object->enter_link	2587	=item $player_object->enter_link
2447		2588
2448	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}>).
2449		2590
2450	The player should be reasonably safe there for short amounts of time. You	2591	The player should be reasonably safe there for short amounts of time (e.g.
2451	I<MUST> call C<leave_link> as soon as possible, though.	2592	for loading a map). You I<MUST> call C<leave_link> as soon as possible,
		2593	though, as the player cannot control the character while it is on the link
		2594	map.
2452		2595
2453	Will never block.	2596	Will never block.
2454		2597
2455	=item $player_object->leave_link ($map, $x, $y)	2598	=item $player_object->leave_link ($map, $x, $y)
2456		2599
…		…
2476	sub cf::object::player::enter_link {	2619	sub cf::object::player::enter_link {
2477	my ($self) = @_;	2620	my ($self) = @_;
2478		2621
2479	$self->deactivate_recursive;	2622	$self->deactivate_recursive;
2480		2623
		2624	++$self->{_link_recursion};
		2625
2481	return if UNIVERSAL::isa $self->map, "ext::map_link";	2626	return if UNIVERSAL::isa $self->map, "ext::map_link";
2482		2627
2483	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]	2628	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2484	if $self->map && $self->map->{path} ne "{link}";	2629	if $self->map && $self->map->{path} ne "{link}";
2485		2630
2486	$self->enter_map ($LINK_MAP || link_map, 10, 10);	2631	$self->enter_map ($LINK_MAP || link_map, 3, 3);
2487	}	2632	}
2488		2633
2489	sub cf::object::player::leave_link {	2634	sub cf::object::player::leave_link {
2490	my ($self, $map, $x, $y) = @_;	2635	my ($self, $map, $x, $y) = @_;
2491		2636
…		…
2508	($x, $y) = (-1, -1)	2653	($x, $y) = (-1, -1)
2509	unless (defined $x) && (defined $y);	2654	unless (defined $x) && (defined $y);
2510		2655
2511	# use -1 or undef as default coordinates, not 0, 0	2656	# use -1 or undef as default coordinates, not 0, 0
2512	($x, $y) = ($map->enter_x, $map->enter_y)	2657	($x, $y) = ($map->enter_x, $map->enter_y)
2513	if $x <=0 && $y <= 0;	2658	if $x <= 0 && $y <= 0;
2514		2659
2515	$map->load;	2660	$map->load;
2516	$map->load_neighbours;	2661	$map->load_neighbours;
2517		2662
2518	return unless $self->contr->active;	2663	return unless $self->contr->active;
2519	$self->activate_recursive;
2520		2664
2521	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2665	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2522	$self->enter_map ($map, $x, $y);	2666	if ($self->enter_map ($map, $x, $y)) {
2523	}	2667	# entering was successful
		2668	delete $self->{_link_recursion};
		2669	# only activate afterwards, to support waiting in hooks
		2670	$self->activate_recursive;
		2671	}
2524		2672
		2673	}
		2674
2525	=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)]])
2526		2676
2527	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
2528	her, loading and preparing them map, calling the provided $check callback	2678	her, loading and preparing them map, calling the provided $check callback
2529	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
2530	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
…		…
2537		2687
2538	our $GOTOGEN;	2688	our $GOTOGEN;
2539		2689
2540	sub cf::object::player::goto {	2690	sub cf::object::player::goto {
2541	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	}
2542		2698
2543	# 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
2544	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2700	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2545		2701
2546	$self->enter_link;	2702	$self->enter_link;
…		…
2570	my $map = eval {	2726	my $map = eval {
2571	my $map = defined $path ? cf::map::find $path : undef;	2727	my $map = defined $path ? cf::map::find $path : undef;
2572		2728
2573	if ($map) {	2729	if ($map) {
2574	$map = $map->customise_for ($self);	2730	$map = $map->customise_for ($self);
2575	$map = $check->($map) if $check && $map;	2731	$map = $check->($map, $x, $y, $self) if $check && $map;
2576	} else {	2732	} else {
2577	$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);
2578	}	2734	}
2579		2735
2580	$map	2736	$map
…		…
2588	if ($gen == $self->{_goto_generation}) {	2744	if ($gen == $self->{_goto_generation}) {
2589	delete $self->{_goto_generation};	2745	delete $self->{_goto_generation};
2590	$self->leave_link ($map, $x, $y);	2746	$self->leave_link ($map, $x, $y);
2591	}	2747	}
2592		2748
2593	$done->() if $done;	2749	$done->($self) if $done;
2594	})->prio (1);	2750	})->prio (1);
2595	}	2751	}
2596		2752
2597	=item $player_object->enter_exit ($exit_object)	2753	=item $player_object->enter_exit ($exit_object)
2598		2754
…		…
2686	$self->contr->savebed ($map, $x, $y)	2842	$self->contr->savebed ($map, $x, $y)
2687	if $exit->flag (cf::FLAG_DAMNED);	2843	if $exit->flag (cf::FLAG_DAMNED);
2688		2844
2689	1	2845	1
2690	}) {	2846	}) {
2691	$self->message ("Something went wrong deep within the crossfire server. "	2847	$self->message ("Something went wrong deep within the deliantra server. "
2692	. "I'll try to bring you back to the map you were before. "	2848	. "I'll try to bring you back to the map you were before. "
2693	. "Please report this to the dungeon master!",	2849	. "Please report this to the dungeon master!",
2694	cf::NDI_UNIQUE | cf::NDI_RED);	2850	cf::NDI_UNIQUE | cf::NDI_RED);
2695		2851
2696	warn "ERROR in enter_exit: $@";	2852	warn "ERROR in enter_exit: $@";
…		…
2713	sub cf::client::send_drawinfo {	2869	sub cf::client::send_drawinfo {
2714	my ($self, $text, $flags) = @_;	2870	my ($self, $text, $flags) = @_;
2715		2871
2716	utf8::encode $text;	2872	utf8::encode $text;
2717	$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);
		2874	}
		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);
2718	}	2899	}
2719		2900
2720	=item $client->send_msg ($channel, $msg, $color, [extra...])	2901	=item $client->send_msg ($channel, $msg, $color, [extra...])
2721		2902
2722	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
…		…
2726		2907
2727	=cut	2908	=cut
2728		2909
2729	# non-persistent channels (usually the info channel)	2910	# non-persistent channels (usually the info channel)
2730	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	},
2731	"c/identify" => {	2918	"c/identify" => {
2732	id => "infobox",	2919	id => "infobox",
2733	title => "Identify",	2920	title => "Identify",
2734	reply => undef,	2921	reply => undef,
2735	tooltip => "Items recently identified",	2922	tooltip => "Items recently identified",
…		…
2737	"c/examine" => {	2924	"c/examine" => {
2738	id => "infobox",	2925	id => "infobox",
2739	title => "Examine",	2926	title => "Examine",
2740	reply => undef,	2927	reply => undef,
2741	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",
2742	},	2935	},
2743	"c/book" => {	2936	"c/book" => {
2744	id => "infobox",	2937	id => "infobox",
2745	title => "Book",	2938	title => "Book",
2746	reply => undef,	2939	reply => undef,
…		…
2762	id => "infobox",	2955	id => "infobox",
2763	title => "Body Parts",	2956	title => "Body Parts",
2764	reply => undef,	2957	reply => undef,
2765	tooltip => "Shows which body parts you posess and are available",	2958	tooltip => "Shows which body parts you posess and are available",
2766	},	2959	},
		2960	"c/statistics" => {
		2961	id => "infobox",
		2962	title => "Statistics",
		2963	reply => undef,
		2964	tooltip => "Shows your primary statistics",
		2965	},
		2966	"c/skills" => {
		2967	id => "infobox",
		2968	title => "Skills",
		2969	reply => undef,
		2970	tooltip => "Shows your experience per skill and item power",
		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	},
		2978	"c/resistances" => {
		2979	id => "infobox",
		2980	title => "Resistances",
		2981	reply => undef,
		2982	tooltip => "Shows your resistances",
		2983	},
		2984	"c/pets" => {
		2985	id => "infobox",
		2986	title => "Pets",
		2987	reply => undef,
		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",
		2995	},
2767	"c/uptime" => {	2996	"c/uptime" => {
2768	id => "infobox",	2997	id => "infobox",
2769	title => "Uptime",	2998	title => "Uptime",
2770	reply => undef,	2999	reply => undef,
2771	tooltip => "How long the server has been running since last restart",	3000	tooltip => "How long the server has been running since last restart",
…		…
2780	id => "party",	3009	id => "party",
2781	title => "Party",	3010	title => "Party",
2782	reply => "gsay ",	3011	reply => "gsay ",
2783	tooltip => "Messages and chat related to your party",	3012	tooltip => "Messages and chat related to your party",
2784	},	3013	},
		3014	"c/death" => {
		3015	id => "death",
		3016	title => "Death",
		3017	reply => undef,
		3018	tooltip => "Reason for and more info about your most recent death",
		3019	},
		3020	"c/say" => $SAY_CHANNEL,
		3021	"c/chat" => $CHAT_CHANNEL,
2785	);	3022	);
2786		3023
2787	sub cf::client::send_msg {	3024	sub cf::client::send_msg {
2788	my ($self, $channel, $msg, $color, @extra) = @_;	3025	my ($self, $channel, $msg, $color, @extra) = @_;
2789		3026
2790	$msg = $self->pl->expand_cfpod ($msg);	3027	$msg = $self->pl->expand_cfpod ($msg)
		3028	unless $color & cf::NDI_VERBATIM;
2791		3029
2792	$color &= cf::NDI_CLIENT_MASK; # just in case...	3030	$color &= cf::NDI_CLIENT_MASK; # just in case...
2793		3031
2794	# check predefined channels, for the benefit of C	3032	# check predefined channels, for the benefit of C
2795	if ($CHANNEL{$channel}) {	3033	if ($CHANNEL{$channel}) {
2796	$channel = $CHANNEL{$channel};	3034	$channel = $CHANNEL{$channel};
2797		3035
2798	$self->ext_msg (channel_info => $channel)	3036	$self->ext_msg (channel_info => $channel);
2799	if $self->can_msg;
2800
2801	$channel = $channel->{id};	3037	$channel = $channel->{id};
2802		3038
2803	} elsif (ref $channel) {	3039	} elsif (ref $channel) {
2804	# send meta info to client, if not yet sent	3040	# send meta info to client, if not yet sent
2805	unless (exists $self->{channel}{$channel->{id}}) {	3041	unless (exists $self->{channel}{$channel->{id}}) {
2806	$self->{channel}{$channel->{id}} = $channel;	3042	$self->{channel}{$channel->{id}} = $channel;
2807	$self->ext_msg (channel_info => $channel)	3043	$self->ext_msg (channel_info => $channel);
2808	if $self->can_msg;
2809	}	3044	}
2810		3045
2811	$channel = $channel->{id};	3046	$channel = $channel->{id};
2812	}	3047	}
2813		3048
2814	return unless @extra || length $msg;	3049	return unless @extra || length $msg;
2815		3050
2816	if ($self->can_msg) {
2817	# default colour, mask it out	3051	# default colour, mask it out
2818	$color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)	3052	$color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2819	if $color & cf::NDI_DEF;	3053	if $color & cf::NDI_DEF;
2820		3054
2821	my $pkt = "msg "	3055	my $pkt = "msg "
2822	. $self->{json_coder}->encode (	3056	. $self->{json_coder}->encode (
2823	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]	3057	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2824	);	3058	);
2825		3059
2826	# try lzf for large packets
2827	$pkt = "lzf " . Compress::LZF::compress $pkt
2828	if 1024 <= length $pkt and $self->{can_lzf};
2829
2830	# split very large packets
2831	if (8192 < length $pkt and $self->{can_lzf}) {
2832	$self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2833	$pkt = "frag";
2834	}
2835
2836	$self->send_packet ($pkt);	3060	$self->send_big_packet ($pkt);
2837	} else {
2838	if ($color >= 0) {
2839	# replace some tags by gcfclient-compatible ones
2840	for ($msg) {
2841	1 while
2842	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2843	|| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2844	|| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2845	|| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2846	|| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2847	}
2848
2849	$color &= cf::NDI_COLOR_MASK;
2850
2851	utf8::encode $msg;
2852
2853	if (0 && $msg =~ /\[/) {
2854	# COMMAND/INFO
2855	$self->send_packet ("drawextinfo $color 10 8 $msg")
2856	} else {
2857	$msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2858	$self->send_packet ("drawinfo $color $msg")
2859	}
2860	}
2861	}
2862	}	3061	}
2863		3062
2864	=item $client->ext_msg ($type, @msg)	3063	=item $client->ext_msg ($type, @msg)
2865		3064
2866	Sends an ext event to the client.	3065	Sends an ext event to the client.
…		…
2869		3068
2870	sub cf::client::ext_msg($$@) {	3069	sub cf::client::ext_msg($$@) {
2871	my ($self, $type, @msg) = @_;	3070	my ($self, $type, @msg) = @_;
2872		3071
2873	if ($self->extcmd == 2) {	3072	if ($self->extcmd == 2) {
2874	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));	3073	$self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2875	} elsif ($self->extcmd == 1) { # TODO: remove	3074	} elsif ($self->extcmd == 1) { # TODO: remove
2876	push @msg, msgtype => "event_$type";	3075	push @msg, msgtype => "event_$type";
2877	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));	3076	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2878	}	3077	}
2879	}	3078	}
2880		3079
2881	=item $client->ext_reply ($msgid, @msg)	3080	=item $client->ext_reply ($msgid, @msg)
2882		3081
…		…
2886		3085
2887	sub cf::client::ext_reply($$@) {	3086	sub cf::client::ext_reply($$@) {
2888	my ($self, $id, @msg) = @_;	3087	my ($self, $id, @msg) = @_;
2889		3088
2890	if ($self->extcmd == 2) {	3089	if ($self->extcmd == 2) {
2891	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));	3090	$self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2892	} elsif ($self->extcmd == 1) {	3091	} elsif ($self->extcmd == 1) {
2893	#TODO: version 1, remove	3092	#TODO: version 1, remove
2894	unshift @msg, msgtype => "reply", msgid => $id;	3093	unshift @msg, msgtype => "reply", msgid => $id;
2895	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));	3094	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2896	}	3095	}
2897	}	3096	}
2898		3097
2899	=item $success = $client->query ($flags, "text", \&cb)	3098	=item $success = $client->query ($flags, "text", \&cb)
2900		3099
…		…
3001		3200
3002	$coro	3201	$coro
3003	}	3202	}
3004		3203
3005	cf::client->attach (	3204	cf::client->attach (
3006	on_destroy => sub {	3205	on_client_destroy => sub {
3007	my ($ns) = @_;	3206	my ($ns) = @_;
3008		3207
3009	$_->cancel for values %{ (delete $ns->{_coro}) || {} };	3208	$_->cancel for values %{ (delete $ns->{_coro}) || {} };
3010	},	3209	},
3011	);	3210	);
…		…
3027	our $safe_hole = new Safe::Hole;	3226	our $safe_hole = new Safe::Hole;
3028		3227
3029	$SIG{FPE} = 'IGNORE';	3228	$SIG{FPE} = 'IGNORE';
3030		3229
3031	$safe->permit_only (Opcode::opset qw(	3230	$safe->permit_only (Opcode::opset qw(
3032	:base_core :base_mem :base_orig :base_math	3231	:base_core :base_mem :base_orig :base_math :base_loop
3033	grepstart grepwhile mapstart mapwhile	3232	grepstart grepwhile mapstart mapwhile
3034	sort time	3233	sort time
3035	));	3234	));
3036		3235
3037	# here we export the classes and methods available to script code	3236	# here we export the classes and methods available to script code
…		…
3041	The following functions and methods are available within a safe environment:	3240	The following functions and methods are available within a safe environment:
3042		3241
3043	cf::object	3242	cf::object
3044	contr pay_amount pay_player map x y force_find force_add destroy	3243	contr pay_amount pay_player map x y force_find force_add destroy
3045	insert remove name archname title slaying race decrease split	3244	insert remove name archname title slaying race decrease split
		3245	value
3046		3246
3047	cf::object::player	3247	cf::object::player
3048	player	3248	player
3049		3249
3050	cf::player	3250	cf::player
…		…
3056	=cut	3256	=cut
3057		3257
3058	for (	3258	for (
3059	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	3259	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3060	insert remove inv nrof name archname title slaying race	3260	insert remove inv nrof name archname title slaying race
3061	decrease split destroy change_exp)],	3261	decrease split destroy change_exp value msg lore send_msg)],
3062	["cf::object::player" => qw(player)],	3262	["cf::object::player" => qw(player)],
3063	["cf::player" => qw(peaceful)],	3263	["cf::player" => qw(peaceful send_msg)],
3064	["cf::map" => qw(trigger)],	3264	["cf::map" => qw(trigger)],
3065	) {	3265	) {
3066	no strict 'refs';	3266	no strict 'refs';
3067	my ($pkg, @funs) = @$_;	3267	my ($pkg, @funs) = @$_;
3068	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	3268	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
…		…
3086		3286
3087	my $qcode = $code;	3287	my $qcode = $code;
3088	$qcode =~ s/"/‟/g; # not allowed in #line filenames	3288	$qcode =~ s/"/‟/g; # not allowed in #line filenames
3089	$qcode =~ s/\n/\\n/g;	3289	$qcode =~ s/\n/\\n/g;
3090		3290
		3291	%vars = (_dummy => 0) unless %vars;
		3292
		3293	my @res;
3091	local $_;	3294	local $_;
3092	local @safe::cf::_safe_eval_args = values %vars;
3093		3295
3094	my $eval =	3296	my $eval =
3095	"do {\n"	3297	"do {\n"
3096	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"	3298	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3097	. "#line 0 \"{$qcode}\"\n"	3299	. "#line 0 \"{$qcode}\"\n"
3098	. $code	3300	. $code
3099	. "\n}"	3301	. "\n}"
3100	;	3302	;
3101		3303
		3304	if ($CFG{safe_eval}) {
3102	sub_generation_inc;	3305	sub_generation_inc;
		3306	local @safe::cf::_safe_eval_args = values %vars;
3103	my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);	3307	@res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3104	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	}
3105		3313
3106	if ($@) {	3314	if ($@) {
3107	warn "$@";	3315	warn "$@";
3108	warn "while executing safe code '$code'\n";	3316	warn "while executing safe code '$code'\n";
3109	warn "with arguments " . (join " ", %vars) . "\n";	3317	warn "with arguments " . (join " ", %vars) . "\n";
…		…
3128	=cut	3336	=cut
3129		3337
3130	sub register_script_function {	3338	sub register_script_function {
3131	my ($fun, $cb) = @_;	3339	my ($fun, $cb) = @_;
3132		3340
3133	no strict 'refs';	3341	$fun = "safe::$fun" if $CFG{safe_eval};
3134	*{"safe::$fun"} = $safe_hole->wrap ($cb);	3342	*$fun = $safe_hole->wrap ($cb);
3135	}	3343	}
3136		3344
3137	=back	3345	=back
3138		3346
3139	=cut	3347	=cut
…		…
3160		3368
3161	$facedata->{version} == 2	3369	$facedata->{version} == 2
3162	or cf::cleanup "$path: version mismatch, cannot proceed.";	3370	or cf::cleanup "$path: version mismatch, cannot proceed.";
3163		3371
3164	# 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]);
3165	$facedata->{resource}{"res/exp_table"} = {	3374	$facedata->{resource}{"res/exp_table"} = {
3166	type => FT_RSRC,	3375	type => FT_RSRC,
3167	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),
3168	};	3378	};
3169	cf::cede_to_tick;	3379	cf::cede_to_tick;
3170		3380
3171	{	3381	{
3172	my $faces = $facedata->{faceinfo};	3382	my $faces = $facedata->{faceinfo};
…		…
3174	while (my ($face, $info) = each %$faces) {	3384	while (my ($face, $info) = each %$faces) {
3175	my $idx = (cf::face::find $face) || cf::face::alloc $face;	3385	my $idx = (cf::face::find $face) || cf::face::alloc $face;
3176		3386
3177	cf::face::set_visibility $idx, $info->{visibility};	3387	cf::face::set_visibility $idx, $info->{visibility};
3178	cf::face::set_magicmap $idx, $info->{magicmap};	3388	cf::face::set_magicmap $idx, $info->{magicmap};
3179	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};	3389	cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3180	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};	3390	cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3181		3391
3182	cf::cede_to_tick;	3392	cf::cede_to_tick;
3183	}	3393	}
3184		3394
3185	while (my ($face, $info) = each %$faces) {	3395	while (my ($face, $info) = each %$faces) {
…		…
3209		3419
3210	cf::anim::invalidate_all; # d'oh	3420	cf::anim::invalidate_all; # d'oh
3211	}	3421	}
3212		3422
3213	{	3423	{
3214	# TODO: for gcfclient pleasure, we should give resources
3215	# that gcfclient doesn't grok a >10000 face index.
3216	my $res = $facedata->{resource};	3424	my $res = $facedata->{resource};
3217		3425
3218	while (my ($name, $info) = each %$res) {	3426	while (my ($name, $info) = each %$res) {
3219	if (defined $info->{type}) {	3427	if (defined $info->{type}) {
3220	my $idx = (cf::face::find $name) || cf::face::alloc $name;	3428	my $idx = (cf::face::find $name) || cf::face::alloc $name;
3221	my $data;
3222		3429
3223	if ($info->{type} & 1) {	3430	cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3224	# prepend meta info
3225
3226	my $meta = $enc->encode ({
3227	name => $name,
3228	%{ $info->{meta} || {} },
3229	});
3230
3231	$data = pack "(w/a*)*", $meta, $info->{data};
3232	} else {
3233	$data = $info->{data};
3234	}
3235
3236	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3237	cf::face::set_type $idx, $info->{type};	3431	cf::face::set_type $idx, $info->{type};
3238	} else {	3432	} else {
3239	$RESOURCE{$name} = $info;	3433	$RESOURCE{$name} = $info;
3240	}	3434	}
3241		3435
…		…
3324	reload_treasures;	3518	reload_treasures;
3325		3519
3326	warn "finished reloading resource files\n";	3520	warn "finished reloading resource files\n";
3327	}	3521	}
3328		3522
3329	sub init {
3330	my $guard = freeze_mainloop;
3331
3332	evthread_start IO::AIO::poll_fileno;
3333
3334	reload_resources;
3335	}
3336
3337	sub reload_config {	3523	sub reload_config {
		3524	warn "reloading config file...\n";
		3525
3338	open my $fh, "<:utf8", "$CONFDIR/config"	3526	open my $fh, "<:utf8", "$CONFDIR/config"
3339	or return;	3527	or return;
3340		3528
3341	local $/;	3529	local $/;
3342	*CFG = YAML::Load <$fh>;	3530	*CFG = YAML::XS::Load scalar <$fh>;
3343		3531
3344	$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];	3532	$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3345		3533
3346	$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};
3347	$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};
3348		3536
3349	if (exists $CFG{mlockall}) {	3537	if (exists $CFG{mlockall}) {
…		…
3351	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"	3539	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3352	and die "WARNING: m(un)lockall failed: $!\n";	3540	and die "WARNING: m(un)lockall failed: $!\n";
3353	};	3541	};
3354	warn $@ if $@;	3542	warn $@ if $@;
3355	}	3543	}
		3544
		3545	warn "finished reloading resource files\n";
		3546	}
		3547
		3548	sub pidfile() {
		3549	sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
		3550	or die "$PIDFILE: $!";
		3551	flock $fh, &Fcntl::LOCK_EX
		3552	or die "$PIDFILE: flock: $!";
		3553	$fh
		3554	}
		3555
		3556	# make sure only one server instance is running at any one time
		3557	sub atomic {
		3558	my $fh = pidfile;
		3559
		3560	my $pid = <$fh>;
		3561	kill 9, $pid if $pid > 0;
		3562
		3563	seek $fh, 0, 0;
		3564	print $fh $$;
		3565	}
		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;
3356	}	3574	}
3357		3575
3358	sub main {	3576	sub main {
		3577	cf::init_globals; # initialise logging
		3578
		3579	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
		3580	LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
		3581	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
		3582	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
		3583
		3584	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
		3585
3359	# we must not ever block the main coroutine	3586	# we must not ever block the main coroutine
3360	local $Coro::idle = sub {	3587	local $Coro::idle = sub {
3361	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#	3588	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3362	(async {	3589	(async {
3363	$Coro::current->{desc} = "IDLE BUG HANDLER";	3590	$Coro::current->{desc} = "IDLE BUG HANDLER";
3364	EV::loop EV::LOOP_ONESHOT;	3591	EV::loop EV::LOOP_ONESHOT;
3365	})->prio (Coro::PRIO_MAX);	3592	})->prio (Coro::PRIO_MAX);
3366	};	3593	};
3367		3594
3368	{	3595	evthread_start IO::AIO::poll_fileno;
3369	my $guard = freeze_mainloop;	3596
		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
		3606	reload_resources;
3370	reload_config;	3607	reload_config;
3371	db_init;	3608	db_init;
		3609
		3610	cf::init_uuid;
		3611	cf::init_signals;
		3612	cf::init_skills;
		3613
		3614	cf::init_beforeplay;
		3615
		3616	atomic;
		3617
3372	load_extensions;	3618	load_extensions;
3373		3619
3374	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority	3620	utime time, time, $RUNTIMEFILE;
		3621
		3622	# no (long-running) fork's whatsoever before this point(!)
		3623	use POSIX ();
		3624	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
		3625
		3626	(pop @POST_INIT)->(0) while @POST_INIT;
3375	}	3627	};
3376		3628
3377	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;
3378	}	3633	}
3379		3634
3380	#############################################################################	3635	#############################################################################
3381	# initialisation and cleanup	3636	# initialisation and cleanup
3382		3637
3383	# install some emergency cleanup handlers	3638	# install some emergency cleanup handlers
3384	BEGIN {	3639	BEGIN {
3385	our %SIGWATCHER = ();	3640	our %SIGWATCHER = ();
3386	for my $signal (qw(INT HUP TERM)) {	3641	for my $signal (qw(INT HUP TERM)) {
3387	$SIGWATCHER{$signal} = EV::signal $signal, sub {	3642	$SIGWATCHER{$signal} = AE::signal $signal, sub {
3388	cf::cleanup "SIG$signal";	3643	cf::cleanup "SIG$signal";
3389	};	3644	};
3390	}	3645	}
3391	}	3646	}
3392		3647
3393	sub write_runtime_sync {	3648	sub write_runtime_sync {
3394	my $runtime = "$LOCALDIR/runtime";	3649	my $t0 = AE::time;
3395		3650
3396	# first touch the runtime file to show we are still running:	3651	# first touch the runtime file to show we are still running:
3397	# the fsync below can take a very very long time.	3652	# the fsync below can take a very very long time.
3398		3653
3399	IO::AIO::aio_utime $runtime, undef, undef;	3654	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3400		3655
3401	my $guard = cf::lock_acquire "write_runtime";	3656	my $guard = cf::lock_acquire "write_runtime";
3402		3657
3403	my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644	3658	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3404	or return;	3659	or return;
3405		3660
3406	my $value = $cf::RUNTIME + 90 + 10;	3661	my $value = $cf::RUNTIME + 90 + 10;
3407	# 10 is the runtime save interval, for a monotonic clock	3662	# 10 is the runtime save interval, for a monotonic clock
3408	# 60 allows for the watchdog to kill the server.	3663	# 60 allows for the watchdog to kill the server.
…		…
3418	aio_utime $fh, undef, undef;	3673	aio_utime $fh, undef, undef;
3419		3674
3420	close $fh	3675	close $fh
3421	or return;	3676	or return;
3422		3677
3423	aio_rename "$runtime~", $runtime	3678	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3424	and return;	3679	and return;
3425		3680
3426	warn "runtime file written.\n";	3681	warn sprintf "runtime file written (%gs).\n", AE::time - $t0;
3427		3682
3428	1	3683	1
3429	}	3684	}
3430		3685
3431	our $uuid_lock;	3686	our $uuid_lock;
…		…
3440	my $uuid = "$LOCALDIR/uuid";	3695	my $uuid = "$LOCALDIR/uuid";
3441		3696
3442	my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644	3697	my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3443	or return;	3698	or return;
3444		3699
3445	my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;	3700	my $value = uuid_seq uuid_cur;
		3701
		3702	unless ($value) {
		3703	warn "cowardly refusing to write zero uuid value!\n";
		3704	return;
		3705	}
		3706
		3707	my $value = uuid_str $value + $uuid_skip;
3446	$uuid_skip = 0;	3708	$uuid_skip = 0;
3447		3709
3448	(aio_write $fh, 0, (length $value), $value, 0) <= 0	3710	(aio_write $fh, 0, (length $value), $value, 0) <= 0
3449	and return;	3711	and return;
3450		3712
…		…
3472	}	3734	}
3473		3735
3474	sub emergency_save() {	3736	sub emergency_save() {
3475	my $freeze_guard = cf::freeze_mainloop;	3737	my $freeze_guard = cf::freeze_mainloop;
3476		3738
3477	warn "enter emergency perl save\n";	3739	warn "emergency_perl_save: enter\n";
3478		3740
3479	cf::sync_job {	3741	cf::sync_job {
		3742	# this is a trade-off: we want to be very quick here, so
		3743	# save all maps without fsync, and later call a global sync
		3744	# (which in turn might be very very slow)
		3745	local $USE_FSYNC = 0;
		3746
3480	# use a peculiar iteration method to avoid tripping on perl	3747	# use a peculiar iteration method to avoid tripping on perl
3481	# refcount bugs in for. also avoids problems with players	3748	# refcount bugs in for. also avoids problems with players
3482	# and maps saved/destroyed asynchronously.	3749	# and maps saved/destroyed asynchronously.
3483	warn "begin emergency player save\n";	3750	warn "emergency_perl_save: begin player save\n";
3484	for my $login (keys %cf::PLAYER) {	3751	for my $login (keys %cf::PLAYER) {
3485	my $pl = $cf::PLAYER{$login} or next;	3752	my $pl = $cf::PLAYER{$login} or next;
3486	$pl->valid or next;	3753	$pl->valid or next;
3487	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt	3754	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3488	$pl->save;	3755	$pl->save;
3489	}	3756	}
3490	warn "end emergency player save\n";	3757	warn "emergency_perl_save: end player save\n";
3491		3758
3492	warn "begin emergency map save\n";	3759	warn "emergency_perl_save: begin map save\n";
3493	for my $path (keys %cf::MAP) {	3760	for my $path (keys %cf::MAP) {
3494	my $map = $cf::MAP{$path} or next;	3761	my $map = $cf::MAP{$path} or next;
3495	$map->valid or next;	3762	$map->valid or next;
3496	$map->save;	3763	$map->save;
3497	}	3764	}
3498	warn "end emergency map save\n";	3765	warn "emergency_perl_save: end map save\n";
3499		3766
3500	warn "begin emergency database checkpoint\n";	3767	warn "emergency_perl_save: begin database checkpoint\n";
3501	BDB::db_env_txn_checkpoint $DB_ENV;	3768	BDB::db_env_txn_checkpoint $DB_ENV;
3502	warn "end emergency database checkpoint\n";	3769	warn "emergency_perl_save: end database checkpoint\n";
3503		3770
3504	warn "begin write uuid\n";	3771	warn "emergency_perl_save: begin write uuid\n";
3505	write_uuid_sync 1;	3772	write_uuid_sync 1;
3506	warn "end write uuid\n";	3773	warn "emergency_perl_save: end write uuid\n";
3507	};	3774	};
3508		3775
		3776	warn "emergency_perl_save: starting sync()\n";
		3777	IO::AIO::aio_sync sub {
		3778	warn "emergency_perl_save: finished sync()\n";
		3779	};
		3780
3509	warn "leave emergency perl save\n";	3781	warn "emergency_perl_save: leave\n";
3510	}	3782	}
3511		3783
3512	sub post_cleanup {	3784	sub post_cleanup {
3513	my ($make_core) = @_;	3785	my ($make_core) = @_;
3514		3786
3515	warn Carp::longmess "post_cleanup backtrace"	3787	warn Carp::longmess "post_cleanup backtrace"
3516	if $make_core;	3788	if $make_core;
		3789
		3790	my $fh = pidfile;
		3791	unlink $PIDFILE if <$fh> == $$;
3517	}	3792	}
3518		3793
3519	# a safer delete_package, copied from Symbol	3794	# a safer delete_package, copied from Symbol
3520	sub clear_package($) {	3795	sub clear_package($) {
3521	my $pkg = shift;	3796	my $pkg = shift;
…		…
3537	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};	3812	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3538	for my $name (keys %$leaf_symtab) {	3813	for my $name (keys %$leaf_symtab) {
3539	_gv_clear *{"$pkg$name"};	3814	_gv_clear *{"$pkg$name"};
3540	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};	3815	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3541	}	3816	}
3542	warn "cleared package #$pkg\n";#d#
3543	}	3817	}
3544
3545	our $RELOAD; # how many times to reload
3546		3818
3547	sub do_reload_perl() {	3819	sub do_reload_perl() {
3548	# can/must only be called in main	3820	# can/must only be called in main
3549	if ($Coro::current != $Coro::main) {	3821	if (in_main) {
3550	warn "can only reload from main coroutine";	3822	warn "can only reload from main coroutine";
3551	return;	3823	return;
3552	}	3824	}
3553		3825
3554	return if $RELOAD++;	3826	return if $RELOAD++;
		3827
		3828	my $t1 = AE::time;
3555		3829
3556	while ($RELOAD) {	3830	while ($RELOAD) {
3557	warn "reloading...";	3831	warn "reloading...";
3558		3832
3559	warn "entering sync_job";	3833	warn "entering sync_job";
…		…
3620	clear_package "safe::$_"	3894	clear_package "safe::$_"
3621	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	3895	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3622		3896
3623	warn "unloading cf.pm \"a bit\"";	3897	warn "unloading cf.pm \"a bit\"";
3624	delete $INC{"cf.pm"};	3898	delete $INC{"cf.pm"};
3625	delete $INC{"cf/pod.pm"};	3899	delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3626		3900
3627	# don't, removes xs symbols, too,	3901	# don't, removes xs symbols, too,
3628	# and global variables created in xs	3902	# and global variables created in xs
3629	#clear_package __PACKAGE__;	3903	#clear_package __PACKAGE__;
3630		3904
3631	warn "unload completed, starting to reload now";	3905	warn "unload completed, starting to reload now";
3632		3906
3633	warn "reloading cf.pm";	3907	warn "reloading cf.pm";
3634	require cf;	3908	require cf;
3635	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3909	cf::_connect_to_perl_1;
3636		3910
3637	warn "loading config and database again";	3911	warn "loading config and database again";
3638	cf::reload_config;	3912	cf::reload_config;
3639		3913
3640	warn "loading extensions";	3914	warn "loading extensions";
3641	cf::load_extensions;	3915	cf::load_extensions;
3642		3916
		3917	if ($REATTACH_ON_RELOAD) {
3643	warn "reattaching attachments to objects/players";	3918	warn "reattaching attachments to objects/players";
3644	_global_reattach; # objects, sockets	3919	_global_reattach; # objects, sockets
3645	warn "reattaching attachments to maps";	3920	warn "reattaching attachments to maps";
3646	reattach $_ for values %MAP;	3921	reattach $_ for values %MAP;
3647	warn "reattaching attachments to players";	3922	warn "reattaching attachments to players";
3648	reattach $_ for values %PLAYER;	3923	reattach $_ for values %PLAYER;
		3924	}
		3925
		3926	warn "running post_init jobs";
		3927	(pop @POST_INIT)->(1) while @POST_INIT;
3649		3928
3650	warn "leaving sync_job";	3929	warn "leaving sync_job";
3651		3930
3652	1	3931	1
3653	} or do {	3932	} or do {
…		…
3656	};	3935	};
3657		3936
3658	warn "reloaded";	3937	warn "reloaded";
3659	--$RELOAD;	3938	--$RELOAD;
3660	}	3939	}
		3940
		3941	$t1 = AE::time - $t1;
		3942	warn "reload completed in ${t1}s\n";
3661	};	3943	};
3662		3944
3663	our $RELOAD_WATCHER; # used only during reload	3945	our $RELOAD_WATCHER; # used only during reload
3664		3946
3665	sub reload_perl() {	3947	sub reload_perl() {
3666	# doing reload synchronously and two reloads happen back-to-back,	3948	# doing reload synchronously and two reloads happen back-to-back,
3667	# coro crashes during coro_state_free->destroy here.	3949	# coro crashes during coro_state_free->destroy here.
3668		3950
		3951	$RELOAD_WATCHER ||= cf::async {
		3952	Coro::AIO::aio_wait cache_extensions;
		3953
3669	$RELOAD_WATCHER ||= EV::timer 0, 0, sub {	3954	$RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3670	do_reload_perl;	3955	do_reload_perl;
3671	undef $RELOAD_WATCHER;	3956	undef $RELOAD_WATCHER;
		3957	};
3672	};	3958	};
3673	}	3959	}
3674		3960
3675	register_command "reload" => sub {	3961	register_command "reload" => sub {
3676	my ($who, $arg) = @_;	3962	my ($who, $arg) = @_;
…		…
3690		3976
3691	our @WAIT_FOR_TICK;	3977	our @WAIT_FOR_TICK;
3692	our @WAIT_FOR_TICK_BEGIN;	3978	our @WAIT_FOR_TICK_BEGIN;
3693		3979
3694	sub wait_for_tick {	3980	sub wait_for_tick {
3695	return if tick_inhibit || $Coro::current == $Coro::main;	3981	return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3696		3982
3697	my $signal = new Coro::Signal;	3983	my $signal = new Coro::Signal;
3698	push @WAIT_FOR_TICK, $signal;	3984	push @WAIT_FOR_TICK, $signal;
3699	$signal->wait;	3985	$signal->wait;
3700	}	3986	}
3701		3987
3702	sub wait_for_tick_begin {	3988	sub wait_for_tick_begin {
3703	return if tick_inhibit || $Coro::current == $Coro::main;	3989	return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3704		3990
3705	my $signal = new Coro::Signal;	3991	my $signal = new Coro::Signal;
3706	push @WAIT_FOR_TICK_BEGIN, $signal;	3992	push @WAIT_FOR_TICK_BEGIN, $signal;
3707	$signal->wait;	3993	$signal->wait;
3708	}	3994	}
…		…
3713	unless ++$bug_warning > 10;	3999	unless ++$bug_warning > 10;
3714	return;	4000	return;
3715	}	4001	}
3716		4002
3717	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#
3718		4006
3719	if ($NOW >= $NEXT_RUNTIME_WRITE) {	4007	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3720	$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.;
3721	Coro::async_pool {	4009	Coro::async_pool {
3722	$Coro::current->{desc} = "runtime saver";	4010	$Coro::current->{desc} = "runtime saver";
…		…
3745	}	4033	}
3746		4034
3747	{	4035	{
3748	# configure BDB	4036	# configure BDB
3749		4037
3750	BDB::min_parallel 8;	4038	BDB::min_parallel 16;
3751	BDB::max_poll_reqs $TICK * 0.1;	4039	BDB::max_poll_reqs $TICK * 0.1;
3752	$AnyEvent::BDB::WATCHER->priority (1);	4040	$AnyEvent::BDB::WATCHER->priority (1);
3753		4041
3754	unless ($DB_ENV) {	4042	unless ($DB_ENV) {
3755	$DB_ENV = BDB::db_env_create;	4043	$DB_ENV = BDB::db_env_create;
…		…
3802	$msg =~ s/\n//;	4090	$msg =~ s/\n//;
3803		4091
3804	# limit the # of concurrent backtraces	4092	# limit the # of concurrent backtraces
3805	if ($_log_backtrace < 2) {	4093	if ($_log_backtrace < 2) {
3806	++$_log_backtrace;	4094	++$_log_backtrace;
		4095	my $perl_bt = Carp::longmess $msg;
3807	async {	4096	async {
3808	$Coro::current->{desc} = "abt $msg";	4097	$Coro::current->{desc} = "abt $msg";
3809		4098
3810	my @bt = fork_call {	4099	my @bt = fork_call {
3811	@addr = map { sprintf "%x", $_ } @addr;	4100	@addr = map { sprintf "%x", $_ } @addr;
…		…
3822	}	4111	}
3823		4112
3824	@funcs	4113	@funcs
3825	};	4114	};
3826		4115
3827	LOG llevInfo, "[ABT] $msg\n";	4116	LOG llevInfo, "[ABT] $perl_bt\n";
		4117	LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3828	LOG llevInfo, "[ABT] $_\n" for @bt;	4118	LOG llevInfo, "[ABT] $_\n" for @bt;
3829	--$_log_backtrace;	4119	--$_log_backtrace;
3830	};	4120	};
3831	} else {	4121	} else {
3832	LOG llevInfo, "[ABT] $msg\n";	4122	LOG llevInfo, "[ABT] $msg\n";
3833	LOG llevInfo, "[ABT] [suppressed]\n";	4123	LOG llevInfo, "[ABT] [suppressed]\n";
3834	}	4124	}
3835	}	4125	}
3836		4126
3837	# load additional modules	4127	# load additional modules
3838	use cf::pod;	4128	require "cf/$_.pm" for @EXTRA_MODULES;
		4129	cf::_connect_to_perl_2;
3839		4130
3840	END { cf::emergency_save }	4131	END { cf::emergency_save }
3841		4132
3842	1	4133	1
3843		4134

Diff Legend

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