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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.349 by root, Fri Aug 31 04:10:43 2007 UTC vs.
Revision 1.407 by root, Sun Jan 13 09:53:53 2008 UTC

…		…
4	use strict;	4	use strict;
5		5
6	use Symbol;	6	use Symbol;
7	use List::Util;	7	use List::Util;
8	use Socket;	8	use Socket;
9	use Storable;	9	use EV 1.86;
10	use Event;
11	use Opcode;	10	use Opcode;
12	use Safe;	11	use Safe;
13	use Safe::Hole;	12	use Safe::Hole;
		13	use Storable ();
14		14
15	use Coro 3.64 ();	15	use Coro 4.32 ();
16	use Coro::State;	16	use Coro::State;
17	use Coro::Handle;	17	use Coro::Handle;
18	use Coro::Event;	18	use Coro::EV;
19	use Coro::Timer;	19	use Coro::Timer;
20	use Coro::Signal;	20	use Coro::Signal;
21	use Coro::Semaphore;	21	use Coro::Semaphore;
22	use Coro::AIO;	22	use Coro::AIO;
		23	use Coro::BDB;
23	use Coro::Storable;	24	use Coro::Storable;
24	use Coro::Util ();	25	use Coro::Util ();
25		26
26	use JSON::XS ();	27	use JSON::XS 2.01 ();
27	use BDB ();	28	use BDB ();
28	use Data::Dumper;	29	use Data::Dumper;
29	use Digest::MD5;	30	use Digest::MD5;
30	use Fcntl;	31	use Fcntl;
31	use YAML::Syck ();	32	use YAML::Syck ();
32	use IO::AIO 2.32 ();	33	use IO::AIO 2.51 ();
33	use Time::HiRes;	34	use Time::HiRes;
34	use Compress::LZF;	35	use Compress::LZF;
35	use Digest::MD5 ();	36	use Digest::MD5 ();
36		37
37	# configure various modules to our taste	38	# configure various modules to our taste
38	#	39	#
39	$Storable::canonical = 1; # reduce rsync transfers	40	$Storable::canonical = 1; # reduce rsync transfers
40	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator	41	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
41	Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later	42	Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42
43	$Event::Eval = 1; # no idea why this is required, but it is
44		43
45	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?	44	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46	$YAML::Syck::ImplicitUnicode = 1;	45	$YAML::Syck::ImplicitUnicode = 1;
47		46
48	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority	47	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
…		…
70	our $TMPDIR = "$LOCALDIR/" . tmpdir;	69	our $TMPDIR = "$LOCALDIR/" . tmpdir;
71	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;	70	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72	our $PLAYERDIR = "$LOCALDIR/" . playerdir;	71	our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73	our $RANDOMDIR = "$LOCALDIR/random";	72	our $RANDOMDIR = "$LOCALDIR/random";
74	our $BDBDIR = "$LOCALDIR/db";	73	our $BDBDIR = "$LOCALDIR/db";
		74	our %RESOURCE;
75		75
76	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	76	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77	our $TICK_WATCHER;	77	our $TICK_WATCHER;
78	our $AIO_POLL_WATCHER;	78	our $AIO_POLL_WATCHER;
79	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	79	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80	our $NEXT_TICK;	80	our $NEXT_TICK;
81	our $NOW;
82	our $USE_FSYNC = 1; # use fsync to write maps - default off	81	our $USE_FSYNC = 1; # use fsync to write maps - default off
83		82
84	our $BDB_POLL_WATCHER;	83	our $BDB_POLL_WATCHER;
		84	our $BDB_DEADLOCK_WATCHER;
		85	our $BDB_CHECKPOINT_WATCHER;
		86	our $BDB_TRICKLE_WATCHER;
85	our $DB_ENV;	87	our $DB_ENV;
86		88
87	our %CFG;	89	our %CFG;
88		90
89	our $UPTIME; $UPTIME \|\|= time;	91	our $UPTIME; $UPTIME \|\|= time;
90	our $RUNTIME;	92	our $RUNTIME;
		93	our $NOW;
91		94
92	our %PLAYER; # all users	95	our (%PLAYER, %PLAYER_LOADING); # all users
93	our %MAP; # all maps	96	our (%MAP, %MAP_LOADING ); # all maps
94	our $LINK_MAP; # the special {link} map, which is always available	97	our $LINK_MAP; # the special {link} map, which is always available
95		98
96	# used to convert map paths into valid unix filenames by replacing / by ∕	99	# used to convert map paths into valid unix filenames by replacing / by ∕
97	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons	100	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
98		101
…		…
159		162
160	The raw value load value from the last tick.	163	The raw value load value from the last tick.
161		164
162	=item %cf::CFG	165	=item %cf::CFG
163		166
164	Configuration for the server, loaded from C</etc/crossfire/config>, or	167	Configuration for the server, loaded from C</etc/deliantra-server/config>, or
165	from wherever your confdir points to.	168	from wherever your confdir points to.
166		169
167	=item cf::wait_for_tick, cf::wait_for_tick_begin	170	=item cf::wait_for_tick, cf::wait_for_tick_begin
168		171
169	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	172	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
…		…
187	$msg .= "\n"	190	$msg .= "\n"
188	unless $msg =~ /\n$/;	191	unless $msg =~ /\n$/;
189		192
190	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;	193	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191		194
192	utf8::encode $msg;
193	LOG llevError, $msg;	195	LOG llevError, $msg;
194	};	196	};
195	}	197	}
		198
		199	$Coro::State::DIEHOOK = sub {
		200	warn Carp::longmess $_[0];
		201	Coro::terminate;
		202	};
196		203
197	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	204	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
198	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';	205	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
199	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';	206	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
200	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';	207	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
…		…
213	)) {	220	)) {
214	no strict 'refs';	221	no strict 'refs';
215	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	222	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
216	}	223	}
217		224
218	$Event::DIED = sub {	225	$EV::DIED = sub {
219	warn "error in event callback: @_";	226	warn "error in event callback: @_";
220	};	227	};
221		228
222	#############################################################################	229	#############################################################################
223		230
…		…
246	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;	253	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
247	$d	254	$d
248	} \|\| "[unable to dump $_[0]: '$@']";	255	} \|\| "[unable to dump $_[0]: '$@']";
249	}	256	}
250		257
251	=item $ref = cf::from_json $json	258	=item $ref = cf::decode_json $json
252		259
253	Converts a JSON string into the corresponding perl data structure.	260	Converts a JSON string into the corresponding perl data structure.
254		261
255	=item $json = cf::to_json $ref	262	=item $json = cf::encode_json $ref
256		263
257	Converts a perl data structure into its JSON representation.	264	Converts a perl data structure into its JSON representation.
258		265
259	=cut	266	=cut
260		267
261	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max	268	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
262		269
263	sub to_json ($) { $json_coder->encode ($_[0]) }	270	sub encode_json($) { $json_coder->encode ($_[0]) }
264	sub from_json ($) { $json_coder->decode ($_[0]) }	271	sub decode_json($) { $json_coder->decode ($_[0]) }
265		272
266	=item cf::lock_wait $string	273	=item cf::lock_wait $string
267		274
268	Wait until the given lock is available. See cf::lock_acquire.	275	Wait until the given lock is available. See cf::lock_acquire.
269		276
…		…
285	Return true if the lock is currently active, i.e. somebody has locked it.	292	Return true if the lock is currently active, i.e. somebody has locked it.
286		293
287	=cut	294	=cut
288		295
289	our %LOCK;	296	our %LOCK;
		297	our %LOCKER;#d#
290		298
291	sub lock_wait($) {	299	sub lock_wait($) {
292	my ($key) = @_;	300	my ($key) = @_;
		301
		302	if ($LOCKER{$key} == $Coro::current) {#d#
		303	Carp::cluck "lock_wait($key) for already-acquired lock";#d#
		304	return;#d#
		305	}#d#
293		306
294	# wait for lock, if any	307	# wait for lock, if any
295	while ($LOCK{$key}) {	308	while ($LOCK{$key}) {
296	push @{ $LOCK{$key} }, $Coro::current;	309	push @{ $LOCK{$key} }, $Coro::current;
297	Coro::schedule;	310	Coro::schedule;
…		…
303		316
304	# wait, to be sure we are not locked	317	# wait, to be sure we are not locked
305	lock_wait $key;	318	lock_wait $key;
306		319
307	$LOCK{$key} = [];	320	$LOCK{$key} = [];
		321	$LOCKER{$key} = $Coro::current;#d#
308		322
309	Coro::guard {	323	Coro::guard {
		324	delete $LOCKER{$key};#d#
310	# wake up all waiters, to be on the safe side	325	# wake up all waiters, to be on the safe side
311	$_->ready for @{ delete $LOCK{$key} };	326	$_->ready for @{ delete $LOCK{$key} };
312	}	327	}
313	}	328	}
314		329
…		…
326	};	341	};
327	$TICK_WATCHER->stop;	342	$TICK_WATCHER->stop;
328	$guard	343	$guard
329	}	344	}
330		345
		346	=item cf::periodic $interval, $cb
		347
		348	Like EV::periodic, but randomly selects a starting point so that the actions
		349	get spread over timer.
		350
		351	=cut
		352
		353	sub periodic($$) {
		354	my ($interval, $cb) = @_;
		355
		356	my $start = rand List::Util::min 180, $interval;
		357
		358	EV::periodic $start, $interval, 0, $cb
		359	}
		360
331	=item cf::get_slot $time[, $priority[, $name]]	361	=item cf::get_slot $time[, $priority[, $name]]
332		362
333	Allocate $time seconds of blocking CPU time at priority C<$priority>:	363	Allocate $time seconds of blocking CPU time at priority C<$priority>:
334	This call blocks and returns only when you have at least C<$time> seconds	364	This call blocks and returns only when you have at least C<$time> seconds
335	of cpu time till the next tick. The slot is only valid till the next cede.	365	of cpu time till the next tick. The slot is only valid till the next cede.
…		…
344	our @SLOT_QUEUE;	374	our @SLOT_QUEUE;
345	our $SLOT_QUEUE;	375	our $SLOT_QUEUE;
346		376
347	$SLOT_QUEUE->cancel if $SLOT_QUEUE;	377	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
348	$SLOT_QUEUE = Coro::async {	378	$SLOT_QUEUE = Coro::async {
		379	$Coro::current->desc ("timeslot manager");
		380
349	my $signal = new Coro::Signal;	381	my $signal = new Coro::Signal;
350		382
351	while () {	383	while () {
352	next_job:	384	next_job:
353	my $avail = cf::till_tick;	385	my $avail = cf::till_tick;
…		…
361	}	393	}
362	}	394	}
363	}	395	}
364		396
365	if (@SLOT_QUEUE) {	397	if (@SLOT_QUEUE) {
366	# we do not use wait_For_tick() as it returns immediately when tick is inactive	398	# we do not use wait_for_tick() as it returns immediately when tick is inactive
367	push @cf::WAIT_FOR_TICK, $signal;	399	push @cf::WAIT_FOR_TICK, $signal;
368	$signal->wait;	400	$signal->wait;
369	} else {	401	} else {
370	Coro::schedule;	402	Coro::schedule;
371	}	403	}
…		…
394		426
395	BEGIN { *async = \&Coro::async_pool }	427	BEGIN { *async = \&Coro::async_pool }
396		428
397	=item cf::sync_job { BLOCK }	429	=item cf::sync_job { BLOCK }
398		430
399	The design of Crossfire TRT requires that the main coroutine ($Coro::main)	431	The design of Deliantra requires that the main coroutine ($Coro::main)
400	is always able to handle events or runnable, as Crossfire TRT is only	432	is always able to handle events or runnable, as Deliantra is only
401	partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not	433	partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
402	acceptable.	434	acceptable.
403		435
404	If it must be done, put the blocking parts into C<sync_job>. This will run	436	If it must be done, put the blocking parts into C<sync_job>. This will run
405	the given BLOCK in another coroutine while waiting for the result. The	437	the given BLOCK in another coroutine while waiting for the result. The
…		…
410		442
411	sub sync_job(&) {	443	sub sync_job(&) {
412	my ($job) = @_;	444	my ($job) = @_;
413		445
414	if ($Coro::current == $Coro::main) {	446	if ($Coro::current == $Coro::main) {
415	my $time = Event::time;	447	my $time = EV::time;
416		448
417	# this is the main coro, too bad, we have to block	449	# this is the main coro, too bad, we have to block
418	# till the operation succeeds, freezing the server :/	450	# till the operation succeeds, freezing the server :/
419		451
		452	LOG llevError, Carp::longmess "sync job";#d#
		453
420	# TODO: use suspend/resume instead	454	# TODO: use suspend/resume instead
421	# (but this is cancel-safe)	455	# (but this is cancel-safe)
422	my $freeze_guard = freeze_mainloop;	456	my $freeze_guard = freeze_mainloop;
423		457
424	my $busy = 1;	458	my $busy = 1;
425	my @res;	459	my @res;
426		460
427	(async {	461	(async {
		462	$Coro::current->desc ("sync job coro");
428	@res = eval { $job->() };	463	@res = eval { $job->() };
429	warn $@ if $@;	464	warn $@ if $@;
430	undef $busy;	465	undef $busy;
431	})->prio (Coro::PRIO_MAX);	466	})->prio (Coro::PRIO_MAX);
432		467
433	while ($busy) {	468	while ($busy) {
434	Coro::cede or Event::one_event;	469	if (Coro::nready) {
		470	Coro::cede_notself;
		471	} else {
		472	EV::loop EV::LOOP_ONESHOT;
435	}	473	}
		474	}
436		475
437	$time = Event::time - $time;	476	$time = EV::time - $time;
438		477
439	LOG llevError \| logBacktrace, Carp::longmess "long sync job"	478	LOG llevError \| logBacktrace, Carp::longmess "long sync job"
440	if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;	479	if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
441		480
442	$tick_start += $time; # do not account sync jobs to server load	481	$tick_start += $time; # do not account sync jobs to server load
…		…
472	=item fork_call { }, $args	511	=item fork_call { }, $args
473		512
474	Executes the given code block with the given arguments in a seperate	513	Executes the given code block with the given arguments in a seperate
475	process, returning the results. Everything must be serialisable with	514	process, returning the results. Everything must be serialisable with
476	Coro::Storable. May, of course, block. Note that the executed sub may	515	Coro::Storable. May, of course, block. Note that the executed sub may
477	never block itself or use any form of Event handling.	516	never block itself or use any form of event handling.
478		517
479	=cut	518	=cut
480		519
481	sub fork_call(&@) {	520	sub fork_call(&@) {
482	my ($cb, @args) = @_;	521	my ($cb, @args) = @_;
483		522
484	# we seemingly have to make a local copy of the whole thing,	523	# we seemingly have to make a local copy of the whole thing,
485	# otherwise perl prematurely frees the stuff :/	524	# otherwise perl prematurely frees the stuff :/
486	# TODO: investigate and fix (liekly this will be rather laborious)	525	# TODO: investigate and fix (likely this will be rather laborious)
487		526
488	my @res = Coro::Util::fork_eval {	527	my @res = Coro::Util::fork_eval {
489	reset_signals;	528	reset_signals;
490	&$cb	529	&$cb
491	}, @args;	530	}, @args;
…		…
500	=item cf::db_put $family => $key => $value	539	=item cf::db_put $family => $key => $value
501		540
502	Stores the given C<$value> in the family. It can currently store binary	541	Stores the given C<$value> in the family. It can currently store binary
503	data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).	542	data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
504		543
		544	=item $db = cf::db_table "name"
		545
		546	Create and/or open a new database table. The string must not be "db" and must be unique
		547	within each server.
		548
505	=cut	549	=cut
		550
		551	sub db_table($) {
		552	my ($name) = @_;
		553	my $db = BDB::db_create $DB_ENV;
		554
		555	eval {
		556	$db->set_flags (BDB::CHKSUM);
		557
		558	utf8::encode $name;
		559	BDB::db_open $db, undef, $name, undef, BDB::BTREE,
		560	BDB::CREATE \| BDB::AUTO_COMMIT, 0666;
		561	cf::cleanup "db_open(db): $!" if $!;
		562	};
		563	cf::cleanup "db_open(db): $@" if $@;
		564
		565	$db
		566	}
506		567
507	our $DB;	568	our $DB;
508		569
509	sub db_init {	570	sub db_init {
510	unless ($DB) {
511	$DB = BDB::db_create $DB_ENV;
512
513	cf::sync_job {	571	cf::sync_job {
514	eval {	572	$DB \|\|= db_table "db";
515	$DB->set_flags (BDB::CHKSUM);
516
517	BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
518	BDB::CREATE \| BDB::AUTO_COMMIT, 0666;
519	cf::cleanup "db_open(db): $!" if $!;
520	};
521	cf::cleanup "db_open(db): $@" if $@;
522	};
523	}	573	};
524	}	574	}
525		575
526	sub db_get($$) {	576	sub db_get($$) {
527	my $key = "$_[0]/$_[1]";	577	my $key = "$_[0]/$_[1]";
528		578
…		…
632	attach callbacks/event handlers (a collection of which is called an "attachment")	682	attach callbacks/event handlers (a collection of which is called an "attachment")
633	to it. All such attachable objects support the following methods.	683	to it. All such attachable objects support the following methods.
634		684
635	In the following description, CLASS can be any of C<global>, C<object>	685	In the following description, CLASS can be any of C<global>, C<object>
636	C<player>, C<client> or C<map> (i.e. the attachable objects in	686	C<player>, C<client> or C<map> (i.e. the attachable objects in
637	Crossfire TRT).	687	Deliantra).
638		688
639	=over 4	689	=over 4
640		690
641	=item $attachable->attach ($attachment, key => $value...)	691	=item $attachable->attach ($attachment, key => $value...)
642		692
…		…
924	}	974	}
925		975
926	0	976	0
927	}	977	}
928		978
929	=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)	979	=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
930		980
931	=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)	981	=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
932		982
933	Generate an object-specific event with the given arguments.	983	Generate an object-specific event with the given arguments.
934		984
…		…
940		990
941	=cut	991	=cut
942		992
943	#############################################################################	993	#############################################################################
944	# object support	994	# object support
945	#
946		995
		996	sub _object_equal($$);
		997	sub _object_equal($$) {
		998	my ($a, $b) = @_;
		999
		1000	return 0 unless (ref $a) eq (ref $b);
		1001
		1002	if ("HASH" eq ref $a) {
		1003	my @ka = keys %$a;
		1004	my @kb = keys %$b;
		1005
		1006	return 0 if @ka != @kb;
		1007
		1008	for (0 .. $#ka) {
		1009	return 0 unless $ka[$_] eq $kb[$_];
		1010	return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
		1011	}
		1012
		1013	} elsif ("ARRAY" eq ref $a) {
		1014
		1015	return 0 if @$a != @$b;
		1016
		1017	for (0 .. $#$a) {
		1018	return 0 unless _object_equal $a->[$_], $b->[$_];
		1019	}
		1020
		1021	} elsif ($a ne $b) {
		1022	return 0;
		1023	}
		1024
		1025	1
		1026	}
		1027
		1028	our $SLOW_MERGES;#d#
947	sub _can_merge {	1029	sub _can_merge {
948	my ($ob1, $ob2) = @_;	1030	my ($ob1, $ob2) = @_;
949		1031
950	local $Storable::canonical = 1;	1032	++$SLOW_MERGES;#d#
951	my $fob1 = Storable::freeze $ob1;
952	my $fob2 = Storable::freeze $ob2;
953		1033
954	$fob1 eq $fob2	1034	# we do the slow way here
		1035	return _object_equal $ob1, $ob2
955	}	1036	}
956		1037
957	sub reattach {	1038	sub reattach {
958	# basically do the same as instantiate, without calling instantiate	1039	# basically do the same as instantiate, without calling instantiate
959	my ($obj) = @_;	1040	my ($obj) = @_;
…		…
981	cf::attachable->attach (	1062	cf::attachable->attach (
982	prio => -1000000,	1063	prio => -1000000,
983	on_instantiate => sub {	1064	on_instantiate => sub {
984	my ($obj, $data) = @_;	1065	my ($obj, $data) = @_;
985		1066
986	$data = from_json $data;	1067	$data = decode_json $data;
987		1068
988	for (@$data) {	1069	for (@$data) {
989	my ($name, $args) = @$_;	1070	my ($name, $args) = @$_;
990		1071
991	$obj->attach ($name, %{$args \|\| {} });	1072	$obj->attach ($name, %{$args \|\| {} });
…		…
1007	sub object_freezer_save {	1088	sub object_freezer_save {
1008	my ($filename, $rdata, $objs) = @_;	1089	my ($filename, $rdata, $objs) = @_;
1009		1090
1010	sync_job {	1091	sync_job {
1011	if (length $$rdata) {	1092	if (length $$rdata) {
		1093	utf8::decode (my $decname = $filename);
1012	warn sprintf "saving %s (%d,%d)\n",	1094	warn sprintf "saving %s (%d,%d)\n",
1013	$filename, length $$rdata, scalar @$objs;	1095	$decname, length $$rdata, scalar @$objs;
1014		1096
1015	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {	1097	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {
1016	chmod SAVE_MODE, $fh;	1098	chmod SAVE_MODE, $fh;
1017	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1099	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1018	aio_fsync $fh if $cf::USE_FSYNC;	1100	aio_fsync $fh if $cf::USE_FSYNC;
1019	close $fh;	1101	close $fh;
1020		1102
1021	if (@$objs) {	1103	if (@$objs) {
1022	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {	1104	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {
1023	chmod SAVE_MODE, $fh;	1105	chmod SAVE_MODE, $fh;
1024	my $data = Storable::nfreeze { version => 1, objs => $objs };	1106	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1025	aio_write $fh, 0, (length $data), $data, 0;	1107	aio_write $fh, 0, (length $data), $data, 0;
1026	aio_fsync $fh if $cf::USE_FSYNC;	1108	aio_fsync $fh if $cf::USE_FSYNC;
1027	close $fh;	1109	close $fh;
1028	aio_rename "$filename.pst~", "$filename.pst";	1110	aio_rename "$filename.pst~", "$filename.pst";
1029	}	1111	}
…		…
1037	}	1119	}
1038	} else {	1120	} else {
1039	aio_unlink $filename;	1121	aio_unlink $filename;
1040	aio_unlink "$filename.pst";	1122	aio_unlink "$filename.pst";
1041	}	1123	}
1042	}	1124	};
1043	}	1125	}
1044		1126
1045	sub object_freezer_as_string {	1127	sub object_freezer_as_string {
1046	my ($rdata, $objs) = @_;	1128	my ($rdata, $objs) = @_;
1047		1129
…		…
1059	or return;	1141	or return;
1060		1142
1061	unless (aio_stat "$filename.pst") {	1143	unless (aio_stat "$filename.pst") {
1062	(aio_load "$filename.pst", $av) >= 0	1144	(aio_load "$filename.pst", $av) >= 0
1063	or return;	1145	or return;
		1146
1064	$av = eval { (Storable::thaw $av)->{objs} };	1147	my $st = eval { Coro::Storable::thaw $av };
		1148	$av = $st->{objs};
1065	}	1149	}
1066		1150
		1151	utf8::decode (my $decname = $filename);
1067	warn sprintf "loading %s (%d)\n",	1152	warn sprintf "loading %s (%d,%d)\n",
1068	$filename, length $data, scalar @{$av \|\| []};	1153	$decname, length $data, scalar @{$av \|\| []};
		1154
1069	return ($data, $av);	1155	($data, $av)
1070	}	1156	}
1071		1157
1072	=head2 COMMAND CALLBACKS	1158	=head2 COMMAND CALLBACKS
1073		1159
1074	=over 4	1160	=over 4
…		…
1260		1346
1261	=head3 cf::player	1347	=head3 cf::player
1262		1348
1263	=over 4	1349	=over 4
1264		1350
		1351	=item cf::player::num_playing
		1352
		1353	Returns the official number of playing players, as per the Crossfire metaserver rules.
		1354
		1355	=cut
		1356
		1357	sub num_playing {
		1358	scalar grep
		1359	$_->ob->map
		1360	&& !$_->hidden
		1361	&& !$_->ob->flag (cf::FLAG_WIZ),
		1362	cf::player::list
		1363	}
		1364
1265	=item cf::player::find $login	1365	=item cf::player::find $login
1266		1366
1267	Returns the given player object, loading it if necessary (might block).	1367	Returns the given player object, loading it if necessary (might block).
1268		1368
1269	=cut	1369	=cut
…		…
1304	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";	1404	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1305	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";	1405	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1306	aio_unlink +(playerdir $login) . "/$login.pl.pst";	1406	aio_unlink +(playerdir $login) . "/$login.pl.pst";
1307	aio_unlink +(playerdir $login) . "/$login.pl";	1407	aio_unlink +(playerdir $login) . "/$login.pl";
1308		1408
1309	my $pl = load_pl path $login	1409	my $f = new_from_file cf::object::thawer path $login
1310	or return;	1410	or return;
		1411
		1412	my $pl = cf::player::load_pl $f
		1413	or return;
		1414	local $cf::PLAYER_LOADING{$login} = $pl;
		1415	$f->resolve_delayed_derefs;
1311	$cf::PLAYER{$login} = $pl	1416	$cf::PLAYER{$login} = $pl
1312	}	1417	}
1313	}	1418	}
1314	}	1419	}
1315		1420
…		…
1413	or return [];	1518	or return [];
1414		1519
1415	my @logins;	1520	my @logins;
1416		1521
1417	for my $login (@$dirs) {	1522	for my $login (@$dirs) {
		1523	my $path = path $login;
		1524
		1525	# a .pst is a dead give-away for a valid player
		1526	unless (-e "$path.pst") {
1418	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;	1527	my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1419	aio_read $fh, 0, 512, my $buf, 0 or next;	1528	aio_read $fh, 0, 512, my $buf, 0 or next;
1420	$buf !~ /^password -------------$/m or next; # official not-valid tag	1529	$buf !~ /^password -------------$/m or next; # official not-valid tag
		1530	}
1421		1531
1422	utf8::decode $login;	1532	utf8::decode $login;
1423	push @logins, $login;	1533	push @logins, $login;
1424	}	1534	}
1425		1535
…		…
1458		1568
1459	Expand crossfire pod fragments into protocol xml.	1569	Expand crossfire pod fragments into protocol xml.
1460		1570
1461	=cut	1571	=cut
1462		1572
		1573	use re 'eval';
		1574
		1575	my $group;
		1576	my $interior; $interior = qr{
		1577	# match a pod interior sequence sans C<< >>
		1578	(?:
		1579	\ (.*?)\ (?{ $group = $^N })
		1580	\| < (??{$interior}) >
		1581	)
		1582	}x;
		1583
1463	sub expand_cfpod {	1584	sub expand_cfpod {
1464	((my $self), (local $_)) = @_;	1585	my ($self, $pod) = @_;
1465		1586
1466	# escape & and <	1587	my $xml;
1467	s/&/&/g;
1468	s/(?<![BIUGH])</</g;
1469		1588
1470	# this is buggy, it needs to properly take care of nested <'s	1589	while () {
		1590	if ($pod =~ /\G( (?: [^BCGHITU]+ \| .(?!<) )+ )/xgcs) {
		1591	$group = $1;
1471		1592
1472	1 while	1593	$group =~ s/&/&/g;
1473	# replace B<>, I<>, U<> etc.	1594	$group =~ s/</</g;
1474	s/B<([^\>]*)>/<b>$1<\/b>/	1595
1475	\|\| s/I<([^\>]*)>/<i>$1<\/i>/	1596	$xml .= $group;
1476	\|\| s/U<([^\>]*)>/<u>$1<\/u>/	1597	} elsif ($pod =~ m%\G
1477	# replace G<male\|female> tags	1598	([BCGHITU])
1478	\|\| s{G<([^>\|])\\|([^>])>}{	1599	<
1479	$self->gender ? $2 : $1	1600	(?:
1480	}ge	1601	([^<>]*) (?{ $group = $^N })
1481	# replace H<hint text>	1602	\| < $interior >
1482	\|\| s{H<([^\>]*)>}	1603	)
		1604	>
		1605	%gcsx
1483	{	1606	) {
		1607	my ($code, $data) = ($1, $group);
		1608
		1609	if ($code eq "B") {
		1610	$xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
		1611	} elsif ($code eq "I") {
		1612	$xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
		1613	} elsif ($code eq "U") {
		1614	$xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
		1615	} elsif ($code eq "C") {
		1616	$xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
		1617	} elsif ($code eq "T") {
		1618	$xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
		1619	} elsif ($code eq "G") {
		1620	my ($male, $female) = split /\\|/, $data;
		1621	$data = $self->gender ? $female : $male;
		1622	$xml .= expand_cfpod ($self, $data);
		1623	} elsif ($code eq "H") {
1484	("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",	1624	$xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1485	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",	1625	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1486	"")	1626	"")
1487	[$self->{hintmode}]	1627	[$self->{hintmode}];
		1628	} else {
		1629	$xml .= "error processing '$code($data)' directive";
1488	}ge;	1630	}
		1631	} else {
		1632	if ($pod =~ /\G(.+)/) {
		1633	warn "parse error while expanding $pod (at $1)";
		1634	}
		1635	last;
		1636	}
		1637	}
1489		1638
		1639	for ($xml) {
1490	# create single paragraphs (very hackish)	1640	# create single paragraphs (very hackish)
1491	s/(?<=\S)\n(?=\w)/ /g;	1641	s/(?<=\S)\n(?=\w)/ /g;
1492		1642
1493	# compress some whitespace	1643	# compress some whitespace
1494	s/\s+\n/\n/g; # ws line-ends	1644	s/\s+\n/\n/g; # ws line-ends
1495	s/\n\n+/\n/g; # double lines	1645	s/\n\n+/\n/g; # double lines
1496	s/^\n+//; # beginning lines	1646	s/^\n+//; # beginning lines
1497	s/\n+$//; # ending lines	1647	s/\n+$//; # ending lines
		1648	}
1498		1649
1499	$_	1650	$xml
1500	}	1651	}
		1652
		1653	no re 'eval';
1501		1654
1502	sub hintmode {	1655	sub hintmode {
1503	$_[0]{hintmode} = $_[1] if @_ > 1;	1656	$_[0]{hintmode} = $_[1] if @_ > 1;
1504	$_[0]{hintmode}	1657	$_[0]{hintmode}
1505	}	1658	}
…		…
1749		1902
1750	sub load_header_from($) {	1903	sub load_header_from($) {
1751	my ($self, $path) = @_;	1904	my ($self, $path) = @_;
1752		1905
1753	utf8::encode $path;	1906	utf8::encode $path;
1754	#aio_open $path, O_RDONLY, 0	1907	my $f = new_from_file cf::object::thawer $path
1755	# or return;
1756
1757	$self->_load_header ($path)
1758	or return;	1908	or return;
		1909
		1910	$self->_load_header ($f)
		1911	or return;
		1912
		1913	local $MAP_LOADING{$self->{path}} = $self;
		1914	$f->resolve_delayed_derefs;
1759		1915
1760	$self->{load_path} = $path;	1916	$self->{load_path} = $path;
1761		1917
1762	1	1918	1
1763	}	1919	}
…		…
1817	sub find {	1973	sub find {
1818	my ($path, $origin) = @_;	1974	my ($path, $origin) = @_;
1819		1975
1820	$path = normalise $path, $origin && $origin->path;	1976	$path = normalise $path, $origin && $origin->path;
1821		1977
		1978	cf::lock_wait "map_data:$path";#d#remove
1822	cf::lock_wait "map_find:$path";	1979	cf::lock_wait "map_find:$path";
1823		1980
1824	$cf::MAP{$path} \|\| do {	1981	$cf::MAP{$path} \|\| do {
1825	my $guard = cf::lock_acquire "map_find:$path";	1982	my $guard1 = cf::lock_acquire "map_find:$path";
		1983	my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
		1984
1826	my $map = new_from_path cf::map $path	1985	my $map = new_from_path cf::map $path
1827	or return;	1986	or return;
1828		1987
1829	$map->{last_save} = $cf::RUNTIME;	1988	$map->{last_save} = $cf::RUNTIME;
1830		1989
…		…
1832	or return;	1991	or return;
1833		1992
1834	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)	1993	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1835	# doing this can freeze the server in a sync job, obviously	1994	# doing this can freeze the server in a sync job, obviously
1836	#$cf::WAIT_FOR_TICK->wait;	1995	#$cf::WAIT_FOR_TICK->wait;
		1996	undef $guard1;
		1997	undef $guard2;
1837	$map->reset;	1998	$map->reset;
1838	undef $guard;
1839	return find $path;	1999	return find $path;
1840	}	2000	}
1841		2001
1842	$cf::MAP{$path} = $map	2002	$cf::MAP{$path} = $map
1843	}	2003	}
…		…
1852	local $self->{deny_reset} = 1; # loading can take a long time	2012	local $self->{deny_reset} = 1; # loading can take a long time
1853		2013
1854	my $path = $self->{path};	2014	my $path = $self->{path};
1855		2015
1856	{	2016	{
1857	my $guard1 = cf::lock_acquire "map_data:$path";	2017	my $guard = cf::lock_acquire "map_data:$path";
1858	my $guard2 = cf::lock_acquire "map_load:$path";
1859		2018
		2019	return unless $self->valid;
1860	return if $self->in_memory != cf::MAP_SWAPPED;	2020	return unless $self->in_memory == cf::MAP_SWAPPED;
1861		2021
1862	$self->in_memory (cf::MAP_LOADING);	2022	$self->in_memory (cf::MAP_LOADING);
1863		2023
1864	$self->alloc;	2024	$self->alloc;
1865		2025
1866	$self->pre_load;	2026	$self->pre_load;
1867	cf::cede_to_tick;	2027	cf::cede_to_tick;
1868		2028
		2029	my $f = new_from_file cf::object::thawer $self->{load_path};
		2030	$f->skip_block;
1869	$self->_load_objects ($self->{load_path}, 1)	2031	$self->_load_objects ($f)
1870	or return;	2032	or return;
1871		2033
1872	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	2034	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1873	if delete $self->{load_original};	2035	if delete $self->{load_original};
1874		2036
1875	if (my $uniq = $self->uniq_path) {	2037	if (my $uniq = $self->uniq_path) {
1876	utf8::encode $uniq;	2038	utf8::encode $uniq;
1877	if (aio_open $uniq, O_RDONLY, 0) {	2039	unless (aio_stat $uniq) {
		2040	if (my $f = new_from_file cf::object::thawer $uniq) {
1878	$self->clear_unique_items;	2041	$self->clear_unique_items;
1879	$self->_load_objects ($uniq, 0);	2042	$self->_load_objects ($f);
		2043	$f->resolve_delayed_derefs;
		2044	}
1880	}	2045	}
1881	}	2046	}
		2047
		2048	$f->resolve_delayed_derefs;
1882		2049
1883	cf::cede_to_tick;	2050	cf::cede_to_tick;
1884	# now do the right thing for maps	2051	# now do the right thing for maps
1885	$self->link_multipart_objects;	2052	$self->link_multipart_objects;
1886	$self->difficulty ($self->estimate_difficulty)	2053	$self->difficulty ($self->estimate_difficulty)
…		…
1972	}	2139	}
1973		2140
1974	$MAP_PREFETCH{$path} \|= $load;	2141	$MAP_PREFETCH{$path} \|= $load;
1975		2142
1976	$MAP_PREFETCHER \|\|= cf::async {	2143	$MAP_PREFETCHER \|\|= cf::async {
		2144	$Coro::current->{desc} = "map prefetcher";
		2145
1977	while (%MAP_PREFETCH) {	2146	while (%MAP_PREFETCH) {
1978	while (my ($k, $v) = each %MAP_PREFETCH) {	2147	while (my ($k, $v) = each %MAP_PREFETCH) {
1979	if (my $map = find $k) {	2148	if (my $map = find $k) {
1980	$map->load if $v;	2149	$map->load if $v;
1981	}	2150	}
…		…
2007	return if $self->{deny_save};	2176	return if $self->{deny_save};
2008		2177
2009	local $self->{last_access} = $self->last_access;#d#	2178	local $self->{last_access} = $self->last_access;#d#
2010		2179
2011	cf::async {	2180	cf::async {
		2181	$Coro::current->{desc} = "map player save";
2012	$_->contr->save for $self->players;	2182	$_->contr->save for $self->players;
2013	};	2183	};
2014		2184
2015	if ($uniq) {	2185	if ($uniq) {
2016	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);	2186	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);
…		…
2030		2200
2031	return if $self->players;	2201	return if $self->players;
2032	return if $self->in_memory != cf::MAP_IN_MEMORY;	2202	return if $self->in_memory != cf::MAP_IN_MEMORY;
2033	return if $self->{deny_save};	2203	return if $self->{deny_save};
2034		2204
		2205	$self->in_memory (cf::MAP_SWAPPED);
		2206
		2207	$self->deactivate;
		2208	$_->clear_links_to ($self) for values %cf::MAP;
2035	$self->clear;	2209	$self->clear;
2036	$self->in_memory (cf::MAP_SWAPPED);
2037	}	2210	}
2038		2211
2039	sub reset_at {	2212	sub reset_at {
2040	my ($self) = @_;	2213	my ($self) = @_;
2041		2214
…		…
2073	if $uniq;	2246	if $uniq;
2074	}	2247	}
2075		2248
2076	delete $cf::MAP{$self->path};	2249	delete $cf::MAP{$self->path};
2077		2250
		2251	$self->deactivate;
		2252	$_->clear_links_to ($self) for values %cf::MAP;
2078	$self->clear;	2253	$self->clear;
2079
2080	$_->clear_links_to ($self) for values %cf::MAP;
2081		2254
2082	$self->unlink_save;	2255	$self->unlink_save;
2083	$self->destroy;	2256	$self->destroy;
2084	}	2257	}
2085		2258
…		…
2090		2263
2091	{	2264	{
2092	my $lock = cf::lock_acquire "map_data:$self->{path}";	2265	my $lock = cf::lock_acquire "map_data:$self->{path}";
2093		2266
2094	delete $cf::MAP{$self->path};	2267	delete $cf::MAP{$self->path};
		2268
		2269	$self->unlink_save;
2095		2270
2096	bless $self, "cf::map";	2271	bless $self, "cf::map";
2097	delete $self->{deny_reset};	2272	delete $self->{deny_reset};
2098	$self->{deny_save} = 1;	2273	$self->{deny_save} = 1;
2099	$self->reset_timeout (1);	2274	$self->reset_timeout (1);
2100	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2275	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2101
2102	$self->unlink_save;
2103		2276
2104	$cf::MAP{$self->path} = $self;	2277	$cf::MAP{$self->path} = $self;
2105	}	2278	}
2106		2279
2107	$self->reset; # polite request, might not happen	2280	$self->reset; # polite request, might not happen
…		…
2186		2359
2187	sub inv_recursive {	2360	sub inv_recursive {
2188	inv_recursive_ inv $_[0]	2361	inv_recursive_ inv $_[0]
2189	}	2362	}
2190		2363
		2364	=item $ref = $ob->ref
		2365
		2366	creates and returns a persistent reference to an objetc that can be stored as a string.
		2367
		2368	=item $ob = cf::object::deref ($refstring)
		2369
		2370	returns the objetc referenced by refstring. may return undef when it cnanot find the object,
		2371	even if the object actually exists. May block.
		2372
		2373	=cut
		2374
		2375	sub deref {
		2376	my ($ref) = @_;
		2377
		2378	if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
		2379	my ($uuid, $name) = ($1, $2);
		2380	my $pl = $cf::PLAYER_LOADING{$name} \|\| cf::player::find $name
		2381	or return;
		2382	$pl->ob->uuid eq $uuid
		2383	or return;
		2384
		2385	$pl->ob
		2386	} else {
		2387	warn "$ref: cannot resolve object reference\n";
		2388	undef
		2389	}
		2390	}
		2391
2191	package cf;	2392	package cf;
2192		2393
2193	=back	2394	=back
2194		2395
2195	=head3 cf::object::player	2396	=head3 cf::object::player
…		…
2353	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2554	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2354		2555
2355	$self->enter_link;	2556	$self->enter_link;
2356		2557
2357	(async {	2558	(async {
		2559	$Coro::current->{desc} = "player::goto $path $x $y";
		2560
		2561	# *tag paths override both path and x\|y
		2562	if ($path =~ /^\(.)$/) {
		2563	if (my @obs = grep $_->map, ext::map_tags::find $1) {
		2564	my $ob = $obs[rand @obs];
		2565
		2566	# see if we actually can go there
		2567	if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
		2568	$ob = $obs[rand @obs];
		2569	} else {
		2570	$self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE \| cf::NDI_RED);
		2571	}
		2572	# else put us there anyways for now #d#
		2573
		2574	($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
		2575	} else {
		2576	($path, $x, $y) = (undef, undef, undef);
		2577	}
		2578	}
		2579
2358	my $map = eval {	2580	my $map = eval {
2359	my $map = cf::map::find $path;	2581	my $map = defined $path ? cf::map::find $path : undef;
2360		2582
2361	if ($map) {	2583	if ($map) {
2362	$map = $map->customise_for ($self);	2584	$map = $map->customise_for ($self);
2363	$map = $check->($map) if $check && $map;	2585	$map = $check->($map) if $check && $map;
2364	} else {	2586	} else {
2365	$self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE \| cf::NDI_RED);	2587	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE \| cf::NDI_RED);
2366	}	2588	}
2367		2589
2368	$map	2590	$map
2369	};	2591	};
2370		2592
…		…
2423	$rmp->{origin_y} = $exit->y;	2645	$rmp->{origin_y} = $exit->y;
2424	}	2646	}
2425		2647
2426	$rmp->{random_seed} \|\|= $exit->random_seed;	2648	$rmp->{random_seed} \|\|= $exit->random_seed;
2427		2649
2428	my $data = cf::to_json $rmp;	2650	my $data = cf::encode_json $rmp;
2429	my $md5 = Digest::MD5::md5_hex $data;	2651	my $md5 = Digest::MD5::md5_hex $data;
2430	my $meta = "$RANDOMDIR/$md5.meta";	2652	my $meta = "$RANDOMDIR/$md5.meta";
2431		2653
2432	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {	2654	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {
2433	aio_write $fh, 0, (length $data), $data, 0;	2655	aio_write $fh, 0, (length $data), $data, 0;
…		…
2460	# if exit is damned, update players death & WoR home-position	2682	# if exit is damned, update players death & WoR home-position
2461	$self->contr->savebed ($slaying, $hp, $sp)	2683	$self->contr->savebed ($slaying, $hp, $sp)
2462	if $exit->flag (FLAG_DAMNED);	2684	if $exit->flag (FLAG_DAMNED);
2463		2685
2464	(async {	2686	(async {
		2687	$Coro::current->{desc} = "enter_exit $slaying $hp $sp";
		2688
2465	$self->deactivate_recursive; # just to be sure	2689	$self->deactivate_recursive; # just to be sure
2466	unless (eval {	2690	unless (eval {
2467	$self->goto ($slaying, $hp, $sp);	2691	$self->goto ($slaying, $hp, $sp);
2468		2692
2469	1;	2693	1;
…		…
2504	the message, with C<log> being the default. If C<$color> is negative, suppress	2728	the message, with C<log> being the default. If C<$color> is negative, suppress
2505	the message unless the client supports the msg packet.	2729	the message unless the client supports the msg packet.
2506		2730
2507	=cut	2731	=cut
2508		2732
		2733	# non-persistent channels (usually the info channel)
		2734	our %CHANNEL = (
		2735	"c/identify" => {
		2736	id => "infobox",
		2737	title => "Identify",
		2738	reply => undef,
		2739	tooltip => "Items recently identified",
		2740	},
		2741	"c/examine" => {
		2742	id => "infobox",
		2743	title => "Examine",
		2744	reply => undef,
		2745	tooltip => "Signs and other items you examined",
		2746	},
		2747	"c/book" => {
		2748	id => "infobox",
		2749	title => "Book",
		2750	reply => undef,
		2751	tooltip => "The contents of a note or book",
		2752	},
		2753	"c/lookat" => {
		2754	id => "infobox",
		2755	title => "Look",
		2756	reply => undef,
		2757	tooltip => "What you saw there",
		2758	},
		2759	"c/who" => {
		2760	id => "infobox",
		2761	title => "Players",
		2762	reply => undef,
		2763	tooltip => "Shows players who are currently online",
		2764	},
		2765	"c/body" => {
		2766	id => "infobox",
		2767	title => "Body Parts",
		2768	reply => undef,
		2769	tooltip => "Shows which body parts you posess and are available",
		2770	},
		2771	"c/uptime" => {
		2772	id => "infobox",
		2773	title => "Uptime",
		2774	reply => undef,
		2775	tooltip => "How long the server has been running since last restart",
		2776	},
		2777	"c/mapinfo" => {
		2778	id => "infobox",
		2779	title => "Map Info",
		2780	reply => undef,
		2781	tooltip => "Information related to the maps",
		2782	},
		2783	);
		2784
2509	sub cf::client::send_msg {	2785	sub cf::client::send_msg {
2510	my ($self, $channel, $msg, $color, @extra) = @_;	2786	my ($self, $channel, $msg, $color, @extra) = @_;
2511		2787
2512	$msg = $self->pl->expand_cfpod ($msg);	2788	$msg = $self->pl->expand_cfpod ($msg);
2513		2789
2514	$color &= cf::NDI_CLIENT_MASK; # just in case...	2790	$color &= cf::NDI_CLIENT_MASK; # just in case...
2515		2791
		2792	# check predefined channels, for the benefit of C
		2793	if ($CHANNEL{$channel}) {
		2794	$channel = $CHANNEL{$channel};
		2795
		2796	$self->ext_msg (channel_info => $channel)
		2797	if $self->can_msg;
		2798
		2799	$channel = $channel->{id};
		2800
2516	if (ref $channel) {	2801	} elsif (ref $channel) {
2517	# send meta info to client, if not yet sent	2802	# send meta info to client, if not yet sent
2518	unless (exists $self->{channel}{$channel->{id}}) {	2803	unless (exists $self->{channel}{$channel->{id}}) {
2519	$self->{channel}{$channel->{id}} = $channel;	2804	$self->{channel}{$channel->{id}} = $channel;
2520	$self->ext_msg (channel_info => $channel);	2805	$self->ext_msg (channel_info => $channel)
		2806	if $self->can_msg;
2521	}	2807	}
2522		2808
2523	$channel = $channel->{id};	2809	$channel = $channel->{id};
2524	}	2810	}
2525		2811
…		…
2737	=pod	3023	=pod
2738		3024
2739	The following functions and methods are available within a safe environment:	3025	The following functions and methods are available within a safe environment:
2740		3026
2741	cf::object	3027	cf::object
2742	contr pay_amount pay_player map x y force_find force_add	3028	contr pay_amount pay_player map x y force_find force_add destroy
2743	insert remove name archname title slaying race decrease_ob_nr	3029	insert remove name archname title slaying race decrease_ob_nr
2744		3030
2745	cf::object::player	3031	cf::object::player
2746	player	3032	player
2747		3033
…		…
2754	=cut	3040	=cut
2755		3041
2756	for (	3042	for (
2757	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	3043	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2758	insert remove inv name archname title slaying race	3044	insert remove inv name archname title slaying race
2759	decrease_ob_nr)],	3045	decrease_ob_nr destroy)],
2760	["cf::object::player" => qw(player)],	3046	["cf::object::player" => qw(player)],
2761	["cf::player" => qw(peaceful)],	3047	["cf::player" => qw(peaceful)],
2762	["cf::map" => qw(trigger)],	3048	["cf::map" => qw(trigger)],
2763	) {	3049	) {
2764	no strict 'refs';	3050	no strict 'refs';
…		…
2869	{	3155	{
2870	my $faces = $facedata->{faceinfo};	3156	my $faces = $facedata->{faceinfo};
2871		3157
2872	while (my ($face, $info) = each %$faces) {	3158	while (my ($face, $info) = each %$faces) {
2873	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	3159	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
		3160
2874	cf::face::set_visibility $idx, $info->{visibility};	3161	cf::face::set_visibility $idx, $info->{visibility};
2875	cf::face::set_magicmap $idx, $info->{magicmap};	3162	cf::face::set_magicmap $idx, $info->{magicmap};
2876	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};	3163	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2877	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};	3164	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2878		3165
2879	cf::cede_to_tick;	3166	cf::cede_to_tick;
2880	}	3167	}
2881		3168
2882	while (my ($face, $info) = each %$faces) {	3169	while (my ($face, $info) = each %$faces) {
2883	next unless $info->{smooth};	3170	next unless $info->{smooth};
		3171
2884	my $idx = cf::face::find $face	3172	my $idx = cf::face::find $face
2885	or next;	3173	or next;
		3174
2886	if (my $smooth = cf::face::find $info->{smooth}) {	3175	if (my $smooth = cf::face::find $info->{smooth}) {
2887	cf::face::set_smooth $idx, $smooth;	3176	cf::face::set_smooth $idx, $smooth;
2888	cf::face::set_smoothlevel $idx, $info->{smoothlevel};	3177	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2889	} else {	3178	} else {
2890	warn "smooth face '$info->{smooth}' not found for face '$face'";	3179	warn "smooth face '$info->{smooth}' not found for face '$face'";
…		…
2908	{	3197	{
2909	# TODO: for gcfclient pleasure, we should give resources	3198	# TODO: for gcfclient pleasure, we should give resources
2910	# that gcfclient doesn't grok a >10000 face index.	3199	# that gcfclient doesn't grok a >10000 face index.
2911	my $res = $facedata->{resource};	3200	my $res = $facedata->{resource};
2912		3201
2913	my $soundconf = delete $res->{"res/sound.conf"};
2914
2915	while (my ($name, $info) = each %$res) {	3202	while (my ($name, $info) = each %$res) {
		3203	if (defined $info->{type}) {
2916	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	3204	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
2917	my $data;	3205	my $data;
2918		3206
2919	if ($info->{type} & 1) {	3207	if ($info->{type} & 1) {
2920	# prepend meta info	3208	# prepend meta info
2921		3209
2922	my $meta = $enc->encode ({	3210	my $meta = $enc->encode ({
2923	name => $name,	3211	name => $name,
2924	%{ $info->{meta} \|\| {} },	3212	%{ $info->{meta} \|\| {} },
2925	});	3213	});
2926		3214
2927	$data = pack "(w/a)", $meta, $info->{data};	3215	$data = pack "(w/a)", $meta, $info->{data};
		3216	} else {
		3217	$data = $info->{data};
		3218	}
		3219
		3220	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
		3221	cf::face::set_type $idx, $info->{type};
2928	} else {	3222	} else {
2929	$data = $info->{data};	3223	$RESOURCE{$name} = $info;
2930	}	3224	}
2931		3225
2932	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2933	cf::face::set_type $idx, $info->{type};
2934
2935	cf::cede_to_tick;	3226	cf::cede_to_tick;
2936	}	3227	}
2937
2938	if ($soundconf) {
2939	$soundconf = $enc->decode (delete $soundconf->{data});
2940
2941	for (0 .. SOUND_CAST_SPELL_0 - 1) {
2942	my $sound = $soundconf->{compat}[$_]
2943	or next;
2944
2945	my $face = cf::face::find "sound/$sound->[1]";
2946	cf::sound::set $sound->[0] => $face;
2947	cf::sound::old_sound_index $_, $face; # gcfclient-compat
2948	}
2949
2950	while (my ($k, $v) = each %{$soundconf->{event}}) {
2951	my $face = cf::face::find "sound/$v";
2952	cf::sound::set $k => $face;
2953	}
2954	}
2955	}	3228	}
		3229
		3230	cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
2956		3231
2957	1	3232	1
2958	}	3233	}
		3234
		3235	cf::global->attach (on_resource_update => sub {
		3236	if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
		3237	$soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
		3238
		3239	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3240	my $sound = $soundconf->{compat}[$_]
		3241	or next;
		3242
		3243	my $face = cf::face::find "sound/$sound->[1]";
		3244	cf::sound::set $sound->[0] => $face;
		3245	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3246	}
		3247
		3248	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3249	my $face = cf::face::find "sound/$v";
		3250	cf::sound::set $k => $face;
		3251	}
		3252	}
		3253	});
2959		3254
2960	register_exticmd fx_want => sub {	3255	register_exticmd fx_want => sub {
2961	my ($ns, $want) = @_;	3256	my ($ns, $want) = @_;
2962		3257
2963	while (my ($k, $v) = each %$want) {	3258	while (my ($k, $v) = each %$want) {
…		…
3039	sub main {	3334	sub main {
3040	# we must not ever block the main coroutine	3335	# we must not ever block the main coroutine
3041	local $Coro::idle = sub {	3336	local $Coro::idle = sub {
3042	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#	3337	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3043	(async {	3338	(async {
3044	Event::one_event;	3339	$Coro::current->{desc} = "IDLE BUG HANDLER";
		3340	EV::loop EV::LOOP_ONESHOT;
3045	})->prio (Coro::PRIO_MAX);	3341	})->prio (Coro::PRIO_MAX);
3046	};	3342	};
3047		3343
3048	reload_config;	3344	reload_config;
3049	db_init;	3345	db_init;
3050	load_extensions;	3346	load_extensions;
3051		3347
3052	$TICK_WATCHER->start;	3348	$TICK_WATCHER->start;
		3349	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3053	Event::loop;	3350	EV::loop;
3054	}	3351	}
3055		3352
3056	#############################################################################	3353	#############################################################################
3057	# initialisation and cleanup	3354	# initialisation and cleanup
3058		3355
3059	# install some emergency cleanup handlers	3356	# install some emergency cleanup handlers
3060	BEGIN {	3357	BEGIN {
		3358	our %SIGWATCHER = ();
3061	for my $signal (qw(INT HUP TERM)) {	3359	for my $signal (qw(INT HUP TERM)) {
3062	Event->signal (	3360	$SIGWATCHER{$signal} = EV::signal $signal, sub {
3063	reentrant => 0,
3064	data => WF_AUTOCANCEL,
3065	signal => $signal,
3066	prio => 0,
3067	cb => sub {
3068	cf::cleanup "SIG$signal";	3361	cf::cleanup "SIG$signal";
3069	},
3070	);	3362	};
3071	}	3363	}
3072	}	3364	}
3073		3365
3074	sub write_runtime {	3366	sub write_runtime {
3075	my $runtime = "$LOCALDIR/runtime";	3367	my $runtime = "$LOCALDIR/runtime";
…		…
3120	# and maps saved/destroyed asynchronously.	3412	# and maps saved/destroyed asynchronously.
3121	warn "begin emergency player save\n";	3413	warn "begin emergency player save\n";
3122	for my $login (keys %cf::PLAYER) {	3414	for my $login (keys %cf::PLAYER) {
3123	my $pl = $cf::PLAYER{$login} or next;	3415	my $pl = $cf::PLAYER{$login} or next;
3124	$pl->valid or next;	3416	$pl->valid or next;
		3417	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3125	$pl->save;	3418	$pl->save;
3126	}	3419	}
3127	warn "end emergency player save\n";	3420	warn "end emergency player save\n";
3128		3421
3129	warn "begin emergency map save\n";	3422	warn "begin emergency map save\n";
…		…
3168	warn "syncing database to disk";	3461	warn "syncing database to disk";
3169	BDB::db_env_txn_checkpoint $DB_ENV;	3462	BDB::db_env_txn_checkpoint $DB_ENV;
3170		3463
3171	# if anything goes wrong in here, we should simply crash as we already saved	3464	# if anything goes wrong in here, we should simply crash as we already saved
3172		3465
3173	warn "cancelling all WF_AUTOCANCEL watchers";
3174	for (Event::all_watchers) {
3175	$_->cancel if $_->data & WF_AUTOCANCEL;
3176	}
3177
3178	warn "flushing outstanding aio requests";	3466	warn "flushing outstanding aio requests";
3179	for (;;) {	3467	for (;;) {
3180	BDB::flush;	3468	BDB::flush;
3181	IO::AIO::flush;	3469	IO::AIO::flush;
3182	Coro::cede;	3470	Coro::cede_notself;
3183	last unless IO::AIO::nreqs \|\| BDB::nreqs;	3471	last unless IO::AIO::nreqs \|\| BDB::nreqs;
3184	warn "iterate...";	3472	warn "iterate...";
3185	}	3473	}
3186		3474
3187	++$RELOAD;	3475	++$RELOAD;
…		…
3276		3564
3277	sub reload_perl() {	3565	sub reload_perl() {
3278	# doing reload synchronously and two reloads happen back-to-back,	3566	# doing reload synchronously and two reloads happen back-to-back,
3279	# coro crashes during coro_state_free->destroy here.	3567	# coro crashes during coro_state_free->destroy here.
3280		3568
3281	$RELOAD_WATCHER \|\|= Event->timer (	3569	$RELOAD_WATCHER \|\|= EV::timer 0, 0, sub {
3282	reentrant => 0,
3283	after => 0,
3284	data => WF_AUTOCANCEL,
3285	cb => sub {
3286	do_reload_perl;
3287	undef $RELOAD_WATCHER;	3570	undef $RELOAD_WATCHER;
3288	},	3571	do_reload_perl;
3289	);	3572	};
3290	}	3573	}
3291		3574
3292	register_command "reload" => sub {	3575	register_command "reload" => sub {
3293	my ($who, $arg) = @_;	3576	my ($who, $arg) = @_;
3294		3577
3295	if ($who->flag (FLAG_WIZ)) {	3578	if ($who->flag (FLAG_WIZ)) {
3296	$who->message ("reloading server.");	3579	$who->message ("reloading server.");
		3580	async {
		3581	$Coro::current->{desc} = "perl_reload";
3297	async { reload_perl };	3582	reload_perl;
		3583	};
3298	}	3584	}
3299	};	3585	};
3300		3586
3301	unshift @INC, $LIBDIR;	3587	unshift @INC, $LIBDIR;
3302		3588
…		…
3321	my $signal = new Coro::Signal;	3607	my $signal = new Coro::Signal;
3322	push @WAIT_FOR_TICK_BEGIN, $signal;	3608	push @WAIT_FOR_TICK_BEGIN, $signal;
3323	$signal->wait;	3609	$signal->wait;
3324	}	3610	}
3325		3611
3326	my $min = 1e6;#d#	3612	$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3327	my $avg = 10;
3328	$TICK_WATCHER = Event->timer (
3329	reentrant => 0,
3330	parked => 1,
3331	prio => 0,
3332	at => $NEXT_TICK \|\| $TICK,
3333	data => WF_AUTOCANCEL,
3334	cb => sub {
3335	if ($Coro::current != $Coro::main) {	3613	if ($Coro::current != $Coro::main) {
3336	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"	3614	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3337	unless ++$bug_warning > 10;	3615	unless ++$bug_warning > 10;
3338	return;	3616	return;
3339	}	3617	}
3340		3618
3341	$NOW = $tick_start = Event::time;	3619	$NOW = $tick_start = EV::now;
3342		3620
3343	cf::server_tick; # one server iteration	3621	cf::server_tick; # one server iteration
3344		3622
3345	0 && sync_job {#d#	3623	$RUNTIME += $TICK;
3346	for(1..10) {	3624	$NEXT_TICK = $_[0]->at;
3347	my $t = Event::time;
3348	my $map = my $map = new_from_path cf::map "/tmp/x.map"
3349	or die;
3350		3625
3351	$map->width (50);	3626	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3352	$map->height (50);	3627	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3353	$map->alloc;	3628	Coro::async_pool {
3354	$map->_load_objects ("/tmp/x.map", 1);	3629	$Coro::current->{desc} = "runtime saver";
3355	my $t = Event::time - $t;	3630	write_runtime
3356		3631	or warn "ERROR: unable to write runtime file: $!";
3357	#next unless $t < 0.0013;#d#
3358	if ($t < $min) {
3359	$min = $t;
3360	}
3361	$avg = $avg * 0.99 + $t * 0.01;
3362	}
3363	warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3364	exit 0;
3365	# 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3366	};	3632	};
		3633	}
3367		3634
3368	$RUNTIME += $TICK;
3369	$NEXT_TICK += $TICK;
3370
3371	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3372	$NEXT_RUNTIME_WRITE = $NOW + 10;
3373	Coro::async_pool {
3374	write_runtime
3375	or warn "ERROR: unable to write runtime file: $!";
3376	};
3377	}
3378
3379	# my $AFTER = Event::time;
3380	# warn $AFTER - $NOW;#d#
3381
3382	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3635	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3383	$sig->send;	3636	$sig->send;
3384	}	3637	}
3385	while (my $sig = shift @WAIT_FOR_TICK) {	3638	while (my $sig = shift @WAIT_FOR_TICK) {
3386	$sig->send;	3639	$sig->send;
3387	}	3640	}
3388		3641
3389	$NOW = Event::time;
3390
3391	# if we are delayed by four ticks or more, skip them all
3392	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3393
3394	$TICK_WATCHER->at ($NEXT_TICK);
3395	$TICK_WATCHER->start;
3396
3397	$LOAD = ($NOW - $tick_start) / $TICK;	3642	$LOAD = ($NOW - $tick_start) / $TICK;
3398	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	3643	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3399		3644
3400	_post_tick;	3645	_post_tick;
3401		3646	};
3402		3647	$TICK_WATCHER->priority (EV::MAXPRI);
3403	},
3404	);
3405		3648
3406	{	3649	{
3407	BDB::max_poll_time $TICK * 0.1;	3650	# configure BDB
3408	$BDB_POLL_WATCHER = Event->io (	3651
3409	reentrant => 0,
3410	fd => BDB::poll_fileno,
3411	poll => 'r',
3412	prio => 0,
3413	data => WF_AUTOCANCEL,
3414	cb => \&BDB::poll_cb,
3415	);
3416	BDB::min_parallel 8;	3652	BDB::min_parallel 8;
3417		3653	BDB::max_poll_reqs $TICK * 0.1;
3418	BDB::set_sync_prepare {	3654	$Coro::BDB::WATCHER->priority (1);
3419	my $status;
3420	my $current = $Coro::current;
3421	(
3422	sub {
3423	$status = $!;
3424	$current->ready; undef $current;
3425	},
3426	sub {
3427	Coro::schedule while defined $current;
3428	$! = $status;
3429	},
3430	)
3431	};
3432		3655
3433	unless ($DB_ENV) {	3656	unless ($DB_ENV) {
3434	$DB_ENV = BDB::db_env_create;	3657	$DB_ENV = BDB::db_env_create;
		3658	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC
		3659	\| BDB::LOG_AUTOREMOVE, 1);
		3660	$DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
		3661	$DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3435		3662
3436	cf::sync_job {	3663	cf::sync_job {
3437	eval {	3664	eval {
3438	BDB::db_env_open	3665	BDB::db_env_open
3439	$DB_ENV,	3666	$DB_ENV,
…		…
3441	BDB::INIT_LOCK \| BDB::INIT_LOG \| BDB::INIT_MPOOL \| BDB::INIT_TXN	3668	BDB::INIT_LOCK \| BDB::INIT_LOG \| BDB::INIT_MPOOL \| BDB::INIT_TXN
3442	\| BDB::RECOVER \| BDB::REGISTER \| BDB::USE_ENVIRON \| BDB::CREATE,	3669	\| BDB::RECOVER \| BDB::REGISTER \| BDB::USE_ENVIRON \| BDB::CREATE,
3443	0666;	3670	0666;
3444		3671
3445	cf::cleanup "db_env_open($BDBDIR): $!" if $!;	3672	cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3446
3447	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC, 1);
3448	$DB_ENV->set_lk_detect;
3449	};	3673	};
3450		3674
3451	cf::cleanup "db_env_open(db): $@" if $@;	3675	cf::cleanup "db_env_open(db): $@" if $@;
3452	};	3676	};
3453	}	3677	}
		3678
		3679	$BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
		3680	BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
		3681	};
		3682	$BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
		3683	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
		3684	};
		3685	$BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
		3686	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
		3687	};
3454	}	3688	}
3455		3689
3456	{	3690	{
		3691	# configure IO::AIO
		3692
3457	IO::AIO::min_parallel 8;	3693	IO::AIO::min_parallel 8;
3458
3459	undef $Coro::AIO::WATCHER;
3460	IO::AIO::max_poll_time $TICK * 0.1;	3694	IO::AIO::max_poll_time $TICK * 0.1;
3461	$AIO_POLL_WATCHER = Event->io (	3695	$Coro::AIO::WATCHER->priority (1);
3462	reentrant => 0,
3463	data => WF_AUTOCANCEL,
3464	fd => IO::AIO::poll_fileno,
3465	poll => 'r',
3466	prio => 6,
3467	cb => \&IO::AIO::poll_cb,
3468	);
3469	}	3696	}
3470		3697
3471	my $_log_backtrace;	3698	my $_log_backtrace;
3472		3699
3473	sub _log_backtrace {	3700	sub _log_backtrace {
…		…
3477		3704
3478	# limit the # of concurrent backtraces	3705	# limit the # of concurrent backtraces
3479	if ($_log_backtrace < 2) {	3706	if ($_log_backtrace < 2) {
3480	++$_log_backtrace;	3707	++$_log_backtrace;
3481	async {	3708	async {
		3709	$Coro::current->{desc} = "abt $msg";
		3710
3482	my @bt = fork_call {	3711	my @bt = fork_call {
3483	@addr = map { sprintf "%x", $_ } @addr;	3712	@addr = map { sprintf "%x", $_ } @addr;
3484	my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;	3713	my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3485	open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 \|"	3714	open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 \|"
3486	or die "addr2line: $!";	3715	or die "addr2line: $!";

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.349 by root, Fri Aug 31 04:10:43 2007 UTC vs. Revision 1.407 by root, Sun Jan 13 09:53:53 2008 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.349 by root, Fri Aug 31 04:10:43 2007 UTC vs.
Revision 1.407 by root, Sun Jan 13 09:53:53 2008 UTC