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

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