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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.353 by root, Sun Sep 2 08:43:46 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/(?<![BIUGHT])</</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	\|\| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/	1598	([BCGHITU])
1478	# replace G<male\|female> tags	1599	<
1479	\|\| s{G<([^>\|])\\|([^>])>}{	1600	(?:
1480	$self->gender ? $2 : $1	1601	([^<>]*) (?{ $group = $^N })
1481	}ge	1602	\| < $interior >
1482	# replace H<hint text>	1603	)
1483	\|\| s{H<([^\>]*)>}	1604	>
		1605	%gcsx
1484	{	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") {
1485	("<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>",
1486	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",	1625	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1487	"")	1626	"")
1488	[$self->{hintmode}]	1627	[$self->{hintmode}];
		1628	} else {
		1629	$xml .= "error processing '$code($data)' directive";
1489	}ge;	1630	}
		1631	} else {
		1632	if ($pod =~ /\G(.+)/) {
		1633	warn "parse error while expanding $pod (at $1)";
		1634	}
		1635	last;
		1636	}
		1637	}
1490		1638
		1639	for ($xml) {
1491	# create single paragraphs (very hackish)	1640	# create single paragraphs (very hackish)
1492	s/(?<=\S)\n(?=\w)/ /g;	1641	s/(?<=\S)\n(?=\w)/ /g;
1493		1642
1494	# compress some whitespace	1643	# compress some whitespace
1495	s/\s+\n/\n/g; # ws line-ends	1644	s/\s+\n/\n/g; # ws line-ends
1496	s/\n\n+/\n/g; # double lines	1645	s/\n\n+/\n/g; # double lines
1497	s/^\n+//; # beginning lines	1646	s/^\n+//; # beginning lines
1498	s/\n+$//; # ending lines	1647	s/\n+$//; # ending lines
		1648	}
1499		1649
1500	$_	1650	$xml
1501	}	1651	}
		1652
		1653	no re 'eval';
1502		1654
1503	sub hintmode {	1655	sub hintmode {
1504	$_[0]{hintmode} = $_[1] if @_ > 1;	1656	$_[0]{hintmode} = $_[1] if @_ > 1;
1505	$_[0]{hintmode}	1657	$_[0]{hintmode}
1506	}	1658	}
…		…
1750		1902
1751	sub load_header_from($) {	1903	sub load_header_from($) {
1752	my ($self, $path) = @_;	1904	my ($self, $path) = @_;
1753		1905
1754	utf8::encode $path;	1906	utf8::encode $path;
1755	#aio_open $path, O_RDONLY, 0	1907	my $f = new_from_file cf::object::thawer $path
1756	# or return;
1757
1758	$self->_load_header ($path)
1759	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;
1760		1915
1761	$self->{load_path} = $path;	1916	$self->{load_path} = $path;
1762		1917
1763	1	1918	1
1764	}	1919	}
…		…
1818	sub find {	1973	sub find {
1819	my ($path, $origin) = @_;	1974	my ($path, $origin) = @_;
1820		1975
1821	$path = normalise $path, $origin && $origin->path;	1976	$path = normalise $path, $origin && $origin->path;
1822		1977
		1978	cf::lock_wait "map_data:$path";#d#remove
1823	cf::lock_wait "map_find:$path";	1979	cf::lock_wait "map_find:$path";
1824		1980
1825	$cf::MAP{$path} \|\| do {	1981	$cf::MAP{$path} \|\| do {
1826	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
1827	my $map = new_from_path cf::map $path	1985	my $map = new_from_path cf::map $path
1828	or return;	1986	or return;
1829		1987
1830	$map->{last_save} = $cf::RUNTIME;	1988	$map->{last_save} = $cf::RUNTIME;
1831		1989
…		…
1833	or return;	1991	or return;
1834		1992
1835	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)	1993	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1836	# doing this can freeze the server in a sync job, obviously	1994	# doing this can freeze the server in a sync job, obviously
1837	#$cf::WAIT_FOR_TICK->wait;	1995	#$cf::WAIT_FOR_TICK->wait;
		1996	undef $guard1;
		1997	undef $guard2;
1838	$map->reset;	1998	$map->reset;
1839	undef $guard;
1840	return find $path;	1999	return find $path;
1841	}	2000	}
1842		2001
1843	$cf::MAP{$path} = $map	2002	$cf::MAP{$path} = $map
1844	}	2003	}
…		…
1853	local $self->{deny_reset} = 1; # loading can take a long time	2012	local $self->{deny_reset} = 1; # loading can take a long time
1854		2013
1855	my $path = $self->{path};	2014	my $path = $self->{path};
1856		2015
1857	{	2016	{
1858	my $guard1 = cf::lock_acquire "map_data:$path";	2017	my $guard = cf::lock_acquire "map_data:$path";
1859	my $guard2 = cf::lock_acquire "map_load:$path";
1860		2018
		2019	return unless $self->valid;
1861	return if $self->in_memory != cf::MAP_SWAPPED;	2020	return unless $self->in_memory == cf::MAP_SWAPPED;
1862		2021
1863	$self->in_memory (cf::MAP_LOADING);	2022	$self->in_memory (cf::MAP_LOADING);
1864		2023
1865	$self->alloc;	2024	$self->alloc;
1866		2025
1867	$self->pre_load;	2026	$self->pre_load;
1868	cf::cede_to_tick;	2027	cf::cede_to_tick;
1869		2028
		2029	my $f = new_from_file cf::object::thawer $self->{load_path};
		2030	$f->skip_block;
1870	$self->_load_objects ($self->{load_path}, 1)	2031	$self->_load_objects ($f)
1871	or return;	2032	or return;
1872		2033
1873	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	2034	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1874	if delete $self->{load_original};	2035	if delete $self->{load_original};
1875		2036
1876	if (my $uniq = $self->uniq_path) {	2037	if (my $uniq = $self->uniq_path) {
1877	utf8::encode $uniq;	2038	utf8::encode $uniq;
1878	if (aio_open $uniq, O_RDONLY, 0) {	2039	unless (aio_stat $uniq) {
		2040	if (my $f = new_from_file cf::object::thawer $uniq) {
1879	$self->clear_unique_items;	2041	$self->clear_unique_items;
1880	$self->_load_objects ($uniq, 0);	2042	$self->_load_objects ($f);
		2043	$f->resolve_delayed_derefs;
		2044	}
1881	}	2045	}
1882	}	2046	}
		2047
		2048	$f->resolve_delayed_derefs;
1883		2049
1884	cf::cede_to_tick;	2050	cf::cede_to_tick;
1885	# now do the right thing for maps	2051	# now do the right thing for maps
1886	$self->link_multipart_objects;	2052	$self->link_multipart_objects;
1887	$self->difficulty ($self->estimate_difficulty)	2053	$self->difficulty ($self->estimate_difficulty)
…		…
1973	}	2139	}
1974		2140
1975	$MAP_PREFETCH{$path} \|= $load;	2141	$MAP_PREFETCH{$path} \|= $load;
1976		2142
1977	$MAP_PREFETCHER \|\|= cf::async {	2143	$MAP_PREFETCHER \|\|= cf::async {
		2144	$Coro::current->{desc} = "map prefetcher";
		2145
1978	while (%MAP_PREFETCH) {	2146	while (%MAP_PREFETCH) {
1979	while (my ($k, $v) = each %MAP_PREFETCH) {	2147	while (my ($k, $v) = each %MAP_PREFETCH) {
1980	if (my $map = find $k) {	2148	if (my $map = find $k) {
1981	$map->load if $v;	2149	$map->load if $v;
1982	}	2150	}
…		…
2008	return if $self->{deny_save};	2176	return if $self->{deny_save};
2009		2177
2010	local $self->{last_access} = $self->last_access;#d#	2178	local $self->{last_access} = $self->last_access;#d#
2011		2179
2012	cf::async {	2180	cf::async {
		2181	$Coro::current->{desc} = "map player save";
2013	$_->contr->save for $self->players;	2182	$_->contr->save for $self->players;
2014	};	2183	};
2015		2184
2016	if ($uniq) {	2185	if ($uniq) {
2017	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);	2186	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);
…		…
2031		2200
2032	return if $self->players;	2201	return if $self->players;
2033	return if $self->in_memory != cf::MAP_IN_MEMORY;	2202	return if $self->in_memory != cf::MAP_IN_MEMORY;
2034	return if $self->{deny_save};	2203	return if $self->{deny_save};
2035		2204
		2205	$self->in_memory (cf::MAP_SWAPPED);
		2206
		2207	$self->deactivate;
		2208	$_->clear_links_to ($self) for values %cf::MAP;
2036	$self->clear;	2209	$self->clear;
2037	$self->in_memory (cf::MAP_SWAPPED);
2038	}	2210	}
2039		2211
2040	sub reset_at {	2212	sub reset_at {
2041	my ($self) = @_;	2213	my ($self) = @_;
2042		2214
…		…
2074	if $uniq;	2246	if $uniq;
2075	}	2247	}
2076		2248
2077	delete $cf::MAP{$self->path};	2249	delete $cf::MAP{$self->path};
2078		2250
		2251	$self->deactivate;
		2252	$_->clear_links_to ($self) for values %cf::MAP;
2079	$self->clear;	2253	$self->clear;
2080
2081	$_->clear_links_to ($self) for values %cf::MAP;
2082		2254
2083	$self->unlink_save;	2255	$self->unlink_save;
2084	$self->destroy;	2256	$self->destroy;
2085	}	2257	}
2086		2258
…		…
2187		2359
2188	sub inv_recursive {	2360	sub inv_recursive {
2189	inv_recursive_ inv $_[0]	2361	inv_recursive_ inv $_[0]
2190	}	2362	}
2191		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
2192	package cf;	2392	package cf;
2193		2393
2194	=back	2394	=back
2195		2395
2196	=head3 cf::object::player	2396	=head3 cf::object::player
…		…
2354	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2554	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2355		2555
2356	$self->enter_link;	2556	$self->enter_link;
2357		2557
2358	(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
2359	my $map = eval {	2580	my $map = eval {
2360	my $map = cf::map::find $path;	2581	my $map = defined $path ? cf::map::find $path : undef;
2361		2582
2362	if ($map) {	2583	if ($map) {
2363	$map = $map->customise_for ($self);	2584	$map = $map->customise_for ($self);
2364	$map = $check->($map) if $check && $map;	2585	$map = $check->($map) if $check && $map;
2365	} else {	2586	} else {
2366	$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);
2367	}	2588	}
2368		2589
2369	$map	2590	$map
2370	};	2591	};
2371		2592
…		…
2424	$rmp->{origin_y} = $exit->y;	2645	$rmp->{origin_y} = $exit->y;
2425	}	2646	}
2426		2647
2427	$rmp->{random_seed} \|\|= $exit->random_seed;	2648	$rmp->{random_seed} \|\|= $exit->random_seed;
2428		2649
2429	my $data = cf::to_json $rmp;	2650	my $data = cf::encode_json $rmp;
2430	my $md5 = Digest::MD5::md5_hex $data;	2651	my $md5 = Digest::MD5::md5_hex $data;
2431	my $meta = "$RANDOMDIR/$md5.meta";	2652	my $meta = "$RANDOMDIR/$md5.meta";
2432		2653
2433	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {	2654	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {
2434	aio_write $fh, 0, (length $data), $data, 0;	2655	aio_write $fh, 0, (length $data), $data, 0;
…		…
2461	# if exit is damned, update players death & WoR home-position	2682	# if exit is damned, update players death & WoR home-position
2462	$self->contr->savebed ($slaying, $hp, $sp)	2683	$self->contr->savebed ($slaying, $hp, $sp)
2463	if $exit->flag (FLAG_DAMNED);	2684	if $exit->flag (FLAG_DAMNED);
2464		2685
2465	(async {	2686	(async {
		2687	$Coro::current->{desc} = "enter_exit $slaying $hp $sp";
		2688
2466	$self->deactivate_recursive; # just to be sure	2689	$self->deactivate_recursive; # just to be sure
2467	unless (eval {	2690	unless (eval {
2468	$self->goto ($slaying, $hp, $sp);	2691	$self->goto ($slaying, $hp, $sp);
2469		2692
2470	1;	2693	1;
…		…
2505	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
2506	the message unless the client supports the msg packet.	2729	the message unless the client supports the msg packet.
2507		2730
2508	=cut	2731	=cut
2509		2732
		2733	# non-persistent channels (usually the info channel)
2510	our %CHANNEL = (	2734	our %CHANNEL = (
2511	"c/identify" => {	2735	"c/identify" => {
2512	id => "identify",	2736	id => "infobox",
2513	title => "Identify",	2737	title => "Identify",
2514	reply => undef,	2738	reply => undef,
2515	tooltip => "Items recently identified",	2739	tooltip => "Items recently identified",
2516	},	2740	},
2517	"c/examine" => {	2741	"c/examine" => {
2518	id => "examine",	2742	id => "infobox",
2519	title => "Examine",	2743	title => "Examine",
2520	reply => undef,	2744	reply => undef,
2521	tooltip => "Signs and other items you examined",	2745	tooltip => "Signs and other items you examined",
2522	},	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	},
2523	);	2783	);
2524		2784
2525	sub cf::client::send_msg {	2785	sub cf::client::send_msg {
2526	my ($self, $channel, $msg, $color, @extra) = @_;	2786	my ($self, $channel, $msg, $color, @extra) = @_;
2527		2787
2528	$msg = $self->pl->expand_cfpod ($msg);	2788	$msg = $self->pl->expand_cfpod ($msg);
2529		2789
2530	$color &= cf::NDI_CLIENT_MASK; # just in case...	2790	$color &= cf::NDI_CLIENT_MASK; # just in case...
2531		2791
2532	# check predefined channels, for the benefit of C	2792	# check predefined channels, for the benefit of C
2533	$channel = $CHANNEL{$channel} if $CHANNEL{$channel};	2793	if ($CHANNEL{$channel}) {
		2794	$channel = $CHANNEL{$channel};
2534		2795
		2796	$self->ext_msg (channel_info => $channel)
		2797	if $self->can_msg;
		2798
		2799	$channel = $channel->{id};
		2800
2535	if (ref $channel) {	2801	} elsif (ref $channel) {
2536	# send meta info to client, if not yet sent	2802	# send meta info to client, if not yet sent
2537	unless (exists $self->{channel}{$channel->{id}}) {	2803	unless (exists $self->{channel}{$channel->{id}}) {
2538	$self->{channel}{$channel->{id}} = $channel;	2804	$self->{channel}{$channel->{id}} = $channel;
2539	$self->ext_msg (channel_info => $channel)	2805	$self->ext_msg (channel_info => $channel)
2540	if $self->can_msg;	2806	if $self->can_msg;
…		…
2757	=pod	3023	=pod
2758		3024
2759	The following functions and methods are available within a safe environment:	3025	The following functions and methods are available within a safe environment:
2760		3026
2761	cf::object	3027	cf::object
2762	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
2763	insert remove name archname title slaying race decrease_ob_nr	3029	insert remove name archname title slaying race decrease_ob_nr
2764		3030
2765	cf::object::player	3031	cf::object::player
2766	player	3032	player
2767		3033
…		…
2774	=cut	3040	=cut
2775		3041
2776	for (	3042	for (
2777	["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
2778	insert remove inv name archname title slaying race	3044	insert remove inv name archname title slaying race
2779	decrease_ob_nr)],	3045	decrease_ob_nr destroy)],
2780	["cf::object::player" => qw(player)],	3046	["cf::object::player" => qw(player)],
2781	["cf::player" => qw(peaceful)],	3047	["cf::player" => qw(peaceful)],
2782	["cf::map" => qw(trigger)],	3048	["cf::map" => qw(trigger)],
2783	) {	3049	) {
2784	no strict 'refs';	3050	no strict 'refs';
…		…
2889	{	3155	{
2890	my $faces = $facedata->{faceinfo};	3156	my $faces = $facedata->{faceinfo};
2891		3157
2892	while (my ($face, $info) = each %$faces) {	3158	while (my ($face, $info) = each %$faces) {
2893	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	3159	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
		3160
2894	cf::face::set_visibility $idx, $info->{visibility};	3161	cf::face::set_visibility $idx, $info->{visibility};
2895	cf::face::set_magicmap $idx, $info->{magicmap};	3162	cf::face::set_magicmap $idx, $info->{magicmap};
2896	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};
2897	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};
2898		3165
2899	cf::cede_to_tick;	3166	cf::cede_to_tick;
2900	}	3167	}
2901		3168
2902	while (my ($face, $info) = each %$faces) {	3169	while (my ($face, $info) = each %$faces) {
2903	next unless $info->{smooth};	3170	next unless $info->{smooth};
		3171
2904	my $idx = cf::face::find $face	3172	my $idx = cf::face::find $face
2905	or next;	3173	or next;
		3174
2906	if (my $smooth = cf::face::find $info->{smooth}) {	3175	if (my $smooth = cf::face::find $info->{smooth}) {
2907	cf::face::set_smooth $idx, $smooth;	3176	cf::face::set_smooth $idx, $smooth;
2908	cf::face::set_smoothlevel $idx, $info->{smoothlevel};	3177	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2909	} else {	3178	} else {
2910	warn "smooth face '$info->{smooth}' not found for face '$face'";	3179	warn "smooth face '$info->{smooth}' not found for face '$face'";
…		…
2928	{	3197	{
2929	# TODO: for gcfclient pleasure, we should give resources	3198	# TODO: for gcfclient pleasure, we should give resources
2930	# that gcfclient doesn't grok a >10000 face index.	3199	# that gcfclient doesn't grok a >10000 face index.
2931	my $res = $facedata->{resource};	3200	my $res = $facedata->{resource};
2932		3201
2933	my $soundconf = delete $res->{"res/sound.conf"};
2934
2935	while (my ($name, $info) = each %$res) {	3202	while (my ($name, $info) = each %$res) {
		3203	if (defined $info->{type}) {
2936	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	3204	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
2937	my $data;	3205	my $data;
2938		3206
2939	if ($info->{type} & 1) {	3207	if ($info->{type} & 1) {
2940	# prepend meta info	3208	# prepend meta info
2941		3209
2942	my $meta = $enc->encode ({	3210	my $meta = $enc->encode ({
2943	name => $name,	3211	name => $name,
2944	%{ $info->{meta} \|\| {} },	3212	%{ $info->{meta} \|\| {} },
2945	});	3213	});
2946		3214
2947	$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};
2948	} else {	3222	} else {
2949	$data = $info->{data};	3223	$RESOURCE{$name} = $info;
2950	}	3224	}
2951		3225
2952	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2953	cf::face::set_type $idx, $info->{type};
2954
2955	cf::cede_to_tick;	3226	cf::cede_to_tick;
2956	}	3227	}
2957
2958	if ($soundconf) {
2959	$soundconf = $enc->decode (delete $soundconf->{data});
2960
2961	for (0 .. SOUND_CAST_SPELL_0 - 1) {
2962	my $sound = $soundconf->{compat}[$_]
2963	or next;
2964
2965	my $face = cf::face::find "sound/$sound->[1]";
2966	cf::sound::set $sound->[0] => $face;
2967	cf::sound::old_sound_index $_, $face; # gcfclient-compat
2968	}
2969
2970	while (my ($k, $v) = each %{$soundconf->{event}}) {
2971	my $face = cf::face::find "sound/$v";
2972	cf::sound::set $k => $face;
2973	}
2974	}
2975	}	3228	}
		3229
		3230	cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
2976		3231
2977	1	3232	1
2978	}	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	});
2979		3254
2980	register_exticmd fx_want => sub {	3255	register_exticmd fx_want => sub {
2981	my ($ns, $want) = @_;	3256	my ($ns, $want) = @_;
2982		3257
2983	while (my ($k, $v) = each %$want) {	3258	while (my ($k, $v) = each %$want) {
…		…
3059	sub main {	3334	sub main {
3060	# we must not ever block the main coroutine	3335	# we must not ever block the main coroutine
3061	local $Coro::idle = sub {	3336	local $Coro::idle = sub {
3062	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#
3063	(async {	3338	(async {
3064	Event::one_event;	3339	$Coro::current->{desc} = "IDLE BUG HANDLER";
		3340	EV::loop EV::LOOP_ONESHOT;
3065	})->prio (Coro::PRIO_MAX);	3341	})->prio (Coro::PRIO_MAX);
3066	};	3342	};
3067		3343
3068	reload_config;	3344	reload_config;
3069	db_init;	3345	db_init;
3070	load_extensions;	3346	load_extensions;
3071		3347
3072	$TICK_WATCHER->start;	3348	$TICK_WATCHER->start;
		3349	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3073	Event::loop;	3350	EV::loop;
3074	}	3351	}
3075		3352
3076	#############################################################################	3353	#############################################################################
3077	# initialisation and cleanup	3354	# initialisation and cleanup
3078		3355
3079	# install some emergency cleanup handlers	3356	# install some emergency cleanup handlers
3080	BEGIN {	3357	BEGIN {
		3358	our %SIGWATCHER = ();
3081	for my $signal (qw(INT HUP TERM)) {	3359	for my $signal (qw(INT HUP TERM)) {
3082	Event->signal (	3360	$SIGWATCHER{$signal} = EV::signal $signal, sub {
3083	reentrant => 0,
3084	data => WF_AUTOCANCEL,
3085	signal => $signal,
3086	prio => 0,
3087	cb => sub {
3088	cf::cleanup "SIG$signal";	3361	cf::cleanup "SIG$signal";
3089	},
3090	);	3362	};
3091	}	3363	}
3092	}	3364	}
3093		3365
3094	sub write_runtime {	3366	sub write_runtime {
3095	my $runtime = "$LOCALDIR/runtime";	3367	my $runtime = "$LOCALDIR/runtime";
…		…
3140	# and maps saved/destroyed asynchronously.	3412	# and maps saved/destroyed asynchronously.
3141	warn "begin emergency player save\n";	3413	warn "begin emergency player save\n";
3142	for my $login (keys %cf::PLAYER) {	3414	for my $login (keys %cf::PLAYER) {
3143	my $pl = $cf::PLAYER{$login} or next;	3415	my $pl = $cf::PLAYER{$login} or next;
3144	$pl->valid or next;	3416	$pl->valid or next;
		3417	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3145	$pl->save;	3418	$pl->save;
3146	}	3419	}
3147	warn "end emergency player save\n";	3420	warn "end emergency player save\n";
3148		3421
3149	warn "begin emergency map save\n";	3422	warn "begin emergency map save\n";
…		…
3188	warn "syncing database to disk";	3461	warn "syncing database to disk";
3189	BDB::db_env_txn_checkpoint $DB_ENV;	3462	BDB::db_env_txn_checkpoint $DB_ENV;
3190		3463
3191	# 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
3192		3465
3193	warn "cancelling all WF_AUTOCANCEL watchers";
3194	for (Event::all_watchers) {
3195	$_->cancel if $_->data & WF_AUTOCANCEL;
3196	}
3197
3198	warn "flushing outstanding aio requests";	3466	warn "flushing outstanding aio requests";
3199	for (;;) {	3467	for (;;) {
3200	BDB::flush;	3468	BDB::flush;
3201	IO::AIO::flush;	3469	IO::AIO::flush;
3202	Coro::cede;	3470	Coro::cede_notself;
3203	last unless IO::AIO::nreqs \|\| BDB::nreqs;	3471	last unless IO::AIO::nreqs \|\| BDB::nreqs;
3204	warn "iterate...";	3472	warn "iterate...";
3205	}	3473	}
3206		3474
3207	++$RELOAD;	3475	++$RELOAD;
…		…
3296		3564
3297	sub reload_perl() {	3565	sub reload_perl() {
3298	# doing reload synchronously and two reloads happen back-to-back,	3566	# doing reload synchronously and two reloads happen back-to-back,
3299	# coro crashes during coro_state_free->destroy here.	3567	# coro crashes during coro_state_free->destroy here.
3300		3568
3301	$RELOAD_WATCHER \|\|= Event->timer (	3569	$RELOAD_WATCHER \|\|= EV::timer 0, 0, sub {
3302	reentrant => 0,
3303	after => 0,
3304	data => WF_AUTOCANCEL,
3305	cb => sub {
3306	do_reload_perl;
3307	undef $RELOAD_WATCHER;	3570	undef $RELOAD_WATCHER;
3308	},	3571	do_reload_perl;
3309	);	3572	};
3310	}	3573	}
3311		3574
3312	register_command "reload" => sub {	3575	register_command "reload" => sub {
3313	my ($who, $arg) = @_;	3576	my ($who, $arg) = @_;
3314		3577
3315	if ($who->flag (FLAG_WIZ)) {	3578	if ($who->flag (FLAG_WIZ)) {
3316	$who->message ("reloading server.");	3579	$who->message ("reloading server.");
		3580	async {
		3581	$Coro::current->{desc} = "perl_reload";
3317	async { reload_perl };	3582	reload_perl;
		3583	};
3318	}	3584	}
3319	};	3585	};
3320		3586
3321	unshift @INC, $LIBDIR;	3587	unshift @INC, $LIBDIR;
3322		3588
…		…
3341	my $signal = new Coro::Signal;	3607	my $signal = new Coro::Signal;
3342	push @WAIT_FOR_TICK_BEGIN, $signal;	3608	push @WAIT_FOR_TICK_BEGIN, $signal;
3343	$signal->wait;	3609	$signal->wait;
3344	}	3610	}
3345		3611
3346	my $min = 1e6;#d#	3612	$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3347	my $avg = 10;
3348	$TICK_WATCHER = Event->timer (
3349	reentrant => 0,
3350	parked => 1,
3351	prio => 0,
3352	at => $NEXT_TICK \|\| $TICK,
3353	data => WF_AUTOCANCEL,
3354	cb => sub {
3355	if ($Coro::current != $Coro::main) {	3613	if ($Coro::current != $Coro::main) {
3356	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"
3357	unless ++$bug_warning > 10;	3615	unless ++$bug_warning > 10;
3358	return;	3616	return;
3359	}	3617	}
3360		3618
3361	$NOW = $tick_start = Event::time;	3619	$NOW = $tick_start = EV::now;
3362		3620
3363	cf::server_tick; # one server iteration	3621	cf::server_tick; # one server iteration
3364		3622
3365	0 && sync_job {#d#	3623	$RUNTIME += $TICK;
3366	for(1..10) {	3624	$NEXT_TICK = $_[0]->at;
3367	my $t = Event::time;
3368	my $map = my $map = new_from_path cf::map "/tmp/x.map"
3369	or die;
3370		3625
3371	$map->width (50);	3626	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3372	$map->height (50);	3627	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3373	$map->alloc;	3628	Coro::async_pool {
3374	$map->_load_objects ("/tmp/x.map", 1);	3629	$Coro::current->{desc} = "runtime saver";
3375	my $t = Event::time - $t;	3630	write_runtime
3376		3631	or warn "ERROR: unable to write runtime file: $!";
3377	#next unless $t < 0.0013;#d#
3378	if ($t < $min) {
3379	$min = $t;
3380	}
3381	$avg = $avg * 0.99 + $t * 0.01;
3382	}
3383	warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3384	exit 0;
3385	# 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3386	};	3632	};
		3633	}
3387		3634
3388	$RUNTIME += $TICK;
3389	$NEXT_TICK += $TICK;
3390
3391	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3392	$NEXT_RUNTIME_WRITE = $NOW + 10;
3393	Coro::async_pool {
3394	write_runtime
3395	or warn "ERROR: unable to write runtime file: $!";
3396	};
3397	}
3398
3399	# my $AFTER = Event::time;
3400	# warn $AFTER - $NOW;#d#
3401
3402	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3635	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3403	$sig->send;	3636	$sig->send;
3404	}	3637	}
3405	while (my $sig = shift @WAIT_FOR_TICK) {	3638	while (my $sig = shift @WAIT_FOR_TICK) {
3406	$sig->send;	3639	$sig->send;
3407	}	3640	}
3408		3641
3409	$NOW = Event::time;
3410
3411	# if we are delayed by four ticks or more, skip them all
3412	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3413
3414	$TICK_WATCHER->at ($NEXT_TICK);
3415	$TICK_WATCHER->start;
3416
3417	$LOAD = ($NOW - $tick_start) / $TICK;	3642	$LOAD = ($NOW - $tick_start) / $TICK;
3418	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	3643	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3419		3644
3420	_post_tick;	3645	_post_tick;
3421		3646	};
3422		3647	$TICK_WATCHER->priority (EV::MAXPRI);
3423	},
3424	);
3425		3648
3426	{	3649	{
3427	BDB::max_poll_time $TICK * 0.1;	3650	# configure BDB
3428	$BDB_POLL_WATCHER = Event->io (	3651
3429	reentrant => 0,
3430	fd => BDB::poll_fileno,
3431	poll => 'r',
3432	prio => 0,
3433	data => WF_AUTOCANCEL,
3434	cb => \&BDB::poll_cb,
3435	);
3436	BDB::min_parallel 8;	3652	BDB::min_parallel 8;
3437		3653	BDB::max_poll_reqs $TICK * 0.1;
3438	BDB::set_sync_prepare {	3654	$Coro::BDB::WATCHER->priority (1);
3439	my $status;
3440	my $current = $Coro::current;
3441	(
3442	sub {
3443	$status = $!;
3444	$current->ready; undef $current;
3445	},
3446	sub {
3447	Coro::schedule while defined $current;
3448	$! = $status;
3449	},
3450	)
3451	};
3452		3655
3453	unless ($DB_ENV) {	3656	unless ($DB_ENV) {
3454	$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);
3455		3662
3456	cf::sync_job {	3663	cf::sync_job {
3457	eval {	3664	eval {
3458	BDB::db_env_open	3665	BDB::db_env_open
3459	$DB_ENV,	3666	$DB_ENV,
…		…
3461	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
3462	\| BDB::RECOVER \| BDB::REGISTER \| BDB::USE_ENVIRON \| BDB::CREATE,	3669	\| BDB::RECOVER \| BDB::REGISTER \| BDB::USE_ENVIRON \| BDB::CREATE,
3463	0666;	3670	0666;
3464		3671
3465	cf::cleanup "db_env_open($BDBDIR): $!" if $!;	3672	cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3466
3467	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC, 1);
3468	$DB_ENV->set_lk_detect;
3469	};	3673	};
3470		3674
3471	cf::cleanup "db_env_open(db): $@" if $@;	3675	cf::cleanup "db_env_open(db): $@" if $@;
3472	};	3676	};
3473	}	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	};
3474	}	3688	}
3475		3689
3476	{	3690	{
		3691	# configure IO::AIO
		3692
3477	IO::AIO::min_parallel 8;	3693	IO::AIO::min_parallel 8;
3478
3479	undef $Coro::AIO::WATCHER;
3480	IO::AIO::max_poll_time $TICK * 0.1;	3694	IO::AIO::max_poll_time $TICK * 0.1;
3481	$AIO_POLL_WATCHER = Event->io (	3695	$Coro::AIO::WATCHER->priority (1);
3482	reentrant => 0,
3483	data => WF_AUTOCANCEL,
3484	fd => IO::AIO::poll_fileno,
3485	poll => 'r',
3486	prio => 6,
3487	cb => \&IO::AIO::poll_cb,
3488	);
3489	}	3696	}
3490		3697
3491	my $_log_backtrace;	3698	my $_log_backtrace;
3492		3699
3493	sub _log_backtrace {	3700	sub _log_backtrace {
…		…
3497		3704
3498	# limit the # of concurrent backtraces	3705	# limit the # of concurrent backtraces
3499	if ($_log_backtrace < 2) {	3706	if ($_log_backtrace < 2) {
3500	++$_log_backtrace;	3707	++$_log_backtrace;
3501	async {	3708	async {
		3709	$Coro::current->{desc} = "abt $msg";
		3710
3502	my @bt = fork_call {	3711	my @bt = fork_call {
3503	@addr = map { sprintf "%x", $_ } @addr;	3712	@addr = map { sprintf "%x", $_ } @addr;
3504	my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;	3713	my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3505	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 \|"
3506	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.353 by root, Sun Sep 2 08:43:46 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.353 by root, Sun Sep 2 08:43:46 2007 UTC vs.
Revision 1.407 by root, Sun Jan 13 09:53:53 2008 UTC