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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.385 by root, Fri Oct 12 19:13:26 2007 UTC vs.
Revision 1.405 by root, Mon Dec 17 08:03:22 2007 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 Event;	9	use EV 1.86;
10	use Opcode;	10	use Opcode;
11	use Safe;	11	use Safe;
12	use Safe::Hole;	12	use Safe::Hole;
13	use Storable ();	13	use Storable ();
14		14
15	use Coro 4.1 ();	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 ();
…		…
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;
85	our $BDB_DEADLOCK_WATCHER;	84	our $BDB_DEADLOCK_WATCHER;
86	our $BDB_CHECKPOINT_WATCHER;	85	our $BDB_CHECKPOINT_WATCHER;
…		…
89		88
90	our %CFG;	89	our %CFG;
91		90
92	our $UPTIME; $UPTIME \|\|= time;	91	our $UPTIME; $UPTIME \|\|= time;
93	our $RUNTIME;	92	our $RUNTIME;
		93	our $NOW;
94		94
95	our (%PLAYER, %PLAYER_LOADING); # all users	95	our (%PLAYER, %PLAYER_LOADING); # all users
96	our (%MAP, %MAP_LOADING ); # all maps	96	our (%MAP, %MAP_LOADING ); # all maps
97	our $LINK_MAP; # the special {link} map, which is always available	97	our $LINK_MAP; # the special {link} map, which is always available
98		98
…		…
162		162
163	The raw value load value from the last tick.	163	The raw value load value from the last tick.
164		164
165	=item %cf::CFG	165	=item %cf::CFG
166		166
167	Configuration for the server, loaded from C</etc/crossfire/config>, or	167	Configuration for the server, loaded from C</etc/deliantra-server/config>, or
168	from wherever your confdir points to.	168	from wherever your confdir points to.
169		169
170	=item cf::wait_for_tick, cf::wait_for_tick_begin	170	=item cf::wait_for_tick, cf::wait_for_tick_begin
171		171
172	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
…		…
215	)) {	215	)) {
216	no strict 'refs';	216	no strict 'refs';
217	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	217	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
218	}	218	}
219		219
220	$Event::DIED = sub {	220	$EV::DIED = sub {
221	warn "error in event callback: @_";	221	warn "error in event callback: @_";
222	};	222	};
223		223
224	#############################################################################	224	#############################################################################
225		225
…		…
248	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;	248	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
249	$d	249	$d
250	} \|\| "[unable to dump $_[0]: '$@']";	250	} \|\| "[unable to dump $_[0]: '$@']";
251	}	251	}
252		252
253	=item $ref = cf::from_json $json	253	=item $ref = cf::decode_json $json
254		254
255	Converts a JSON string into the corresponding perl data structure.	255	Converts a JSON string into the corresponding perl data structure.
256		256
257	=item $json = cf::to_json $ref	257	=item $json = cf::encode_json $ref
258		258
259	Converts a perl data structure into its JSON representation.	259	Converts a perl data structure into its JSON representation.
260		260
261	=cut	261	=cut
262		262
263	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max	263	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264		264
265	sub to_json ($) { $json_coder->encode ($_[0]) }	265	sub encode_json($) { $json_coder->encode ($_[0]) }
266	sub from_json ($) { $json_coder->decode ($_[0]) }	266	sub decode_json($) { $json_coder->decode ($_[0]) }
267		267
268	=item cf::lock_wait $string	268	=item cf::lock_wait $string
269		269
270	Wait until the given lock is available. See cf::lock_acquire.	270	Wait until the given lock is available. See cf::lock_acquire.
271		271
…		…
334	my $guard = Coro::guard {	334	my $guard = Coro::guard {
335	$TICK_WATCHER->start;	335	$TICK_WATCHER->start;
336	};	336	};
337	$TICK_WATCHER->stop;	337	$TICK_WATCHER->stop;
338	$guard	338	$guard
		339	}
		340
		341	=item cf::periodic $interval, $cb
		342
		343	Like EV::periodic, but randomly selects a starting point so that the actions
		344	get spread over timer.
		345
		346	=cut
		347
		348	sub periodic($$) {
		349	my ($interval, $cb) = @_;
		350
		351	my $start = rand List::Util::min 180, $interval;
		352
		353	EV::periodic $start, $interval, 0, $cb
339	}	354	}
340		355
341	=item cf::get_slot $time[, $priority[, $name]]	356	=item cf::get_slot $time[, $priority[, $name]]
342		357
343	Allocate $time seconds of blocking CPU time at priority C<$priority>:	358	Allocate $time seconds of blocking CPU time at priority C<$priority>:
…		…
406		421
407	BEGIN { *async = \&Coro::async_pool }	422	BEGIN { *async = \&Coro::async_pool }
408		423
409	=item cf::sync_job { BLOCK }	424	=item cf::sync_job { BLOCK }
410		425
411	The design of Crossfire TRT requires that the main coroutine ($Coro::main)	426	The design of Deliantra requires that the main coroutine ($Coro::main)
412	is always able to handle events or runnable, as Crossfire TRT is only	427	is always able to handle events or runnable, as Deliantra is only
413	partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not	428	partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
414	acceptable.	429	acceptable.
415		430
416	If it must be done, put the blocking parts into C<sync_job>. This will run	431	If it must be done, put the blocking parts into C<sync_job>. This will run
417	the given BLOCK in another coroutine while waiting for the result. The	432	the given BLOCK in another coroutine while waiting for the result. The
…		…
422		437
423	sub sync_job(&) {	438	sub sync_job(&) {
424	my ($job) = @_;	439	my ($job) = @_;
425		440
426	if ($Coro::current == $Coro::main) {	441	if ($Coro::current == $Coro::main) {
427	my $time = Event::time;	442	my $time = EV::time;
428		443
429	# this is the main coro, too bad, we have to block	444	# this is the main coro, too bad, we have to block
430	# till the operation succeeds, freezing the server :/	445	# till the operation succeeds, freezing the server :/
431		446
432	LOG llevError, Carp::longmess "sync job";#d#	447	LOG llevError, Carp::longmess "sync job";#d#
…		…
444	warn $@ if $@;	459	warn $@ if $@;
445	undef $busy;	460	undef $busy;
446	})->prio (Coro::PRIO_MAX);	461	})->prio (Coro::PRIO_MAX);
447		462
448	while ($busy) {	463	while ($busy) {
449	Coro::cede or Event::one_event;	464	if (Coro::nready) {
		465	Coro::cede_notself;
		466	} else {
		467	EV::loop EV::LOOP_ONESHOT;
450	}	468	}
		469	}
451		470
452	$time = Event::time - $time;	471	$time = EV::time - $time;
453		472
454	LOG llevError \| logBacktrace, Carp::longmess "long sync job"	473	LOG llevError \| logBacktrace, Carp::longmess "long sync job"
455	if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;	474	if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
456		475
457	$tick_start += $time; # do not account sync jobs to server load	476	$tick_start += $time; # do not account sync jobs to server load
…		…
487	=item fork_call { }, $args	506	=item fork_call { }, $args
488		507
489	Executes the given code block with the given arguments in a seperate	508	Executes the given code block with the given arguments in a seperate
490	process, returning the results. Everything must be serialisable with	509	process, returning the results. Everything must be serialisable with
491	Coro::Storable. May, of course, block. Note that the executed sub may	510	Coro::Storable. May, of course, block. Note that the executed sub may
492	never block itself or use any form of Event handling.	511	never block itself or use any form of event handling.
493		512
494	=cut	513	=cut
495		514
496	sub fork_call(&@) {	515	sub fork_call(&@) {
497	my ($cb, @args) = @_;	516	my ($cb, @args) = @_;
…		…
658	attach callbacks/event handlers (a collection of which is called an "attachment")	677	attach callbacks/event handlers (a collection of which is called an "attachment")
659	to it. All such attachable objects support the following methods.	678	to it. All such attachable objects support the following methods.
660		679
661	In the following description, CLASS can be any of C<global>, C<object>	680	In the following description, CLASS can be any of C<global>, C<object>
662	C<player>, C<client> or C<map> (i.e. the attachable objects in	681	C<player>, C<client> or C<map> (i.e. the attachable objects in
663	Crossfire TRT).	682	Deliantra).
664		683
665	=over 4	684	=over 4
666		685
667	=item $attachable->attach ($attachment, key => $value...)	686	=item $attachable->attach ($attachment, key => $value...)
668		687
…		…
966		985
967	=cut	986	=cut
968		987
969	#############################################################################	988	#############################################################################
970	# object support	989	# object support
971	#
972		990
		991	sub _object_equal($$);
		992	sub _object_equal($$) {
		993	my ($a, $b) = @_;
		994
		995	return 0 unless (ref $a) eq (ref $b);
		996
		997	if ("HASH" eq ref $a) {
		998	my @ka = keys %$a;
		999	my @kb = keys %$b;
		1000
		1001	return 0 if @ka != @kb;
		1002
		1003	for (0 .. $#ka) {
		1004	return 0 unless $ka[$_] eq $kb[$_];
		1005	return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
		1006	}
		1007
		1008	} elsif ("ARRAY" eq ref $a) {
		1009
		1010	return 0 if @$a != @$b;
		1011
		1012	for (0 .. $#$a) {
		1013	return 0 unless _object_equal $a->[$_], $b->[$_];
		1014	}
		1015
		1016	} elsif ($a ne $b) {
		1017	return 0;
		1018	}
		1019
		1020	1
		1021	}
		1022
		1023	our $SLOW_MERGES;#d#
973	sub _can_merge {	1024	sub _can_merge {
974	my ($ob1, $ob2) = @_;	1025	my ($ob1, $ob2) = @_;
975		1026
976	return 1;#d#	1027	++$SLOW_MERGES;#d#
977		1028
978	#todo#d# kill yourself and do some recursive checking manually without storable	1029	# we do the slow way here
979	sync_job {	1030	return _object_equal $ob1, $ob2
980	my $guard = Coro::Storable::guard;
981	local $Storable::canonical = 1;
982	my $fob1 = Storable::freeze $ob1;
983	my $fob2 = Storable::freeze $ob2;
984	$fob1 eq $fob2
985	}
986	}	1031	}
987		1032
988	sub reattach {	1033	sub reattach {
989	# basically do the same as instantiate, without calling instantiate	1034	# basically do the same as instantiate, without calling instantiate
990	my ($obj) = @_;	1035	my ($obj) = @_;
…		…
1012	cf::attachable->attach (	1057	cf::attachable->attach (
1013	prio => -1000000,	1058	prio => -1000000,
1014	on_instantiate => sub {	1059	on_instantiate => sub {
1015	my ($obj, $data) = @_;	1060	my ($obj, $data) = @_;
1016		1061
1017	$data = from_json $data;	1062	$data = decode_json $data;
1018		1063
1019	for (@$data) {	1064	for (@$data) {
1020	my ($name, $args) = @$_;	1065	my ($name, $args) = @$_;
1021		1066
1022	$obj->attach ($name, %{$args \|\| {} });	1067	$obj->attach ($name, %{$args \|\| {} });
…		…
1051	close $fh;	1096	close $fh;
1052		1097
1053	if (@$objs) {	1098	if (@$objs) {
1054	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {	1099	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {
1055	chmod SAVE_MODE, $fh;	1100	chmod SAVE_MODE, $fh;
1056	my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs };	1101	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1057	aio_write $fh, 0, (length $data), $data, 0;	1102	aio_write $fh, 0, (length $data), $data, 0;
1058	aio_fsync $fh if $cf::USE_FSYNC;	1103	aio_fsync $fh if $cf::USE_FSYNC;
1059	close $fh;	1104	close $fh;
1060	aio_rename "$filename.pst~", "$filename.pst";	1105	aio_rename "$filename.pst~", "$filename.pst";
1061	}	1106	}
…		…
1092		1137
1093	unless (aio_stat "$filename.pst") {	1138	unless (aio_stat "$filename.pst") {
1094	(aio_load "$filename.pst", $av) >= 0	1139	(aio_load "$filename.pst", $av) >= 0
1095	or return;	1140	or return;
1096		1141
1097	my $st = eval { Coro::Storable::thaw $av }	1142	my $st = eval { Coro::Storable::thaw $av };
1098	\|\| eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1099	$av = $st->{objs};	1143	$av = $st->{objs};
1100	}	1144	}
1101		1145
1102	utf8::decode (my $decname = $filename);	1146	utf8::decode (my $decname = $filename);
1103	warn sprintf "loading %s (%d,%d)\n",	1147	warn sprintf "loading %s (%d,%d)\n",
…		…
1519		1563
1520	Expand crossfire pod fragments into protocol xml.	1564	Expand crossfire pod fragments into protocol xml.
1521		1565
1522	=cut	1566	=cut
1523		1567
		1568	use re 'eval';
		1569
		1570	my $group;
		1571	my $interior; $interior = qr{
		1572	# match a pod interior sequence sans C<< >>
		1573	(?:
		1574	\ (.*?)\ (?{ $group = $^N })
		1575	\| < (??{$interior}) >
		1576	)
		1577	}x;
		1578
1524	sub expand_cfpod {	1579	sub expand_cfpod {
1525	((my $self), (local $_)) = @_;	1580	my ($self, $pod) = @_;
1526		1581
1527	# escape & and <	1582	my $xml;
1528	s/&/&/g;
1529	s/(?<![BIUGHT])</</g;
1530		1583
1531	# this is buggy, it needs to properly take care of nested <'s	1584	while () {
		1585	if ($pod =~ /\G( (?: [^BCGHITU]+ \| .(?!<) )+ )/xgcs) {
		1586	$group = $1;
1532		1587
1533	1 while	1588	$group =~ s/&/&/g;
1534	# replace B<>, I<>, U<> etc.	1589	$group =~ s/</</g;
1535	s/B<([^\>]*)>/<b>$1<\/b>/	1590
1536	\|\| s/I<([^\>]*)>/<i>$1<\/i>/	1591	$xml .= $group;
1537	\|\| s/U<([^\>]*)>/<u>$1<\/u>/	1592	} elsif ($pod =~ m%\G
1538	\|\| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/	1593	([BCGHITU])
1539	# replace G<male\|female> tags	1594	<
1540	\|\| s{G<([^>\|])\\|([^>])>}{	1595	(?:
1541	$self->gender ? $2 : $1	1596	([^<>]*) (?{ $group = $^N })
1542	}ge	1597	\| < $interior >
1543	# replace H<hint text>	1598	)
1544	\|\| s{H<([^\>]*)>}	1599	>
		1600	%gcsx
1545	{	1601	) {
		1602	my ($code, $data) = ($1, $group);
		1603
		1604	if ($code eq "B") {
		1605	$xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
		1606	} elsif ($code eq "I") {
		1607	$xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
		1608	} elsif ($code eq "U") {
		1609	$xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
		1610	} elsif ($code eq "C") {
		1611	$xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
		1612	} elsif ($code eq "T") {
		1613	$xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
		1614	} elsif ($code eq "G") {
		1615	my ($male, $female) = split /\\|/, $data;
		1616	$data = $self->gender ? $female : $male;
		1617	$xml .= expand_cfpod ($self, $data);
		1618	} elsif ($code eq "H") {
1546	("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",	1619	$xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1547	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",	1620	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1548	"")	1621	"")
1549	[$self->{hintmode}]	1622	[$self->{hintmode}];
		1623	} else {
		1624	$xml .= "error processing '$code($data)' directive";
1550	}ge;	1625	}
		1626	} else {
		1627	if ($pod =~ /\G(.+)/) {
		1628	warn "parse error while expanding $pod (at $1)";
		1629	}
		1630	last;
		1631	}
		1632	}
1551		1633
		1634	for ($xml) {
1552	# create single paragraphs (very hackish)	1635	# create single paragraphs (very hackish)
1553	s/(?<=\S)\n(?=\w)/ /g;	1636	s/(?<=\S)\n(?=\w)/ /g;
1554		1637
1555	# compress some whitespace	1638	# compress some whitespace
1556	s/\s+\n/\n/g; # ws line-ends	1639	s/\s+\n/\n/g; # ws line-ends
1557	s/\n\n+/\n/g; # double lines	1640	s/\n\n+/\n/g; # double lines
1558	s/^\n+//; # beginning lines	1641	s/^\n+//; # beginning lines
1559	s/\n+$//; # ending lines	1642	s/\n+$//; # ending lines
		1643	}
1560		1644
1561	$_	1645	$xml
1562	}	1646	}
		1647
		1648	no re 'eval';
1563		1649
1564	sub hintmode {	1650	sub hintmode {
1565	$_[0]{hintmode} = $_[1] if @_ > 1;	1651	$_[0]{hintmode} = $_[1] if @_ > 1;
1566	$_[0]{hintmode}	1652	$_[0]{hintmode}
1567	}	1653	}
…		…
2554	$rmp->{origin_y} = $exit->y;	2640	$rmp->{origin_y} = $exit->y;
2555	}	2641	}
2556		2642
2557	$rmp->{random_seed} \|\|= $exit->random_seed;	2643	$rmp->{random_seed} \|\|= $exit->random_seed;
2558		2644
2559	my $data = cf::to_json $rmp;	2645	my $data = cf::encode_json $rmp;
2560	my $md5 = Digest::MD5::md5_hex $data;	2646	my $md5 = Digest::MD5::md5_hex $data;
2561	my $meta = "$RANDOMDIR/$md5.meta";	2647	my $meta = "$RANDOMDIR/$md5.meta";
2562		2648
2563	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {	2649	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {
2564	aio_write $fh, 0, (length $data), $data, 0;	2650	aio_write $fh, 0, (length $data), $data, 0;
…		…
2637	the message, with C<log> being the default. If C<$color> is negative, suppress	2723	the message, with C<log> being the default. If C<$color> is negative, suppress
2638	the message unless the client supports the msg packet.	2724	the message unless the client supports the msg packet.
2639		2725
2640	=cut	2726	=cut
2641		2727
		2728	# non-persistent channels (usually the info channel)
2642	our %CHANNEL = (	2729	our %CHANNEL = (
2643	"c/identify" => {	2730	"c/identify" => {
2644	id => "infobox",	2731	id => "infobox",
2645	title => "Identify",	2732	title => "Identify",
2646	reply => undef,	2733	reply => undef,
…		…
2650	id => "infobox",	2737	id => "infobox",
2651	title => "Examine",	2738	title => "Examine",
2652	reply => undef,	2739	reply => undef,
2653	tooltip => "Signs and other items you examined",	2740	tooltip => "Signs and other items you examined",
2654	},	2741	},
		2742	"c/book" => {
		2743	id => "infobox",
		2744	title => "Book",
		2745	reply => undef,
		2746	tooltip => "The contents of a note or book",
		2747	},
2655	"c/lookat" => {	2748	"c/lookat" => {
2656	id => "infobox",	2749	id => "infobox",
2657	title => "Look",	2750	title => "Look",
2658	reply => undef,	2751	reply => undef,
2659	tooltip => "What you saw there",	2752	tooltip => "What you saw there",
		2753	},
		2754	"c/who" => {
		2755	id => "infobox",
		2756	title => "Players",
		2757	reply => undef,
		2758	tooltip => "Shows players who are currently online",
		2759	},
		2760	"c/body" => {
		2761	id => "infobox",
		2762	title => "Body Parts",
		2763	reply => undef,
		2764	tooltip => "Shows which body parts you posess and are available",
		2765	},
		2766	"c/uptime" => {
		2767	id => "infobox",
		2768	title => "Uptime",
		2769	reply => undef,
		2770	tooltip => "How long the server has been running since last restart",
		2771	},
		2772	"c/mapinfo" => {
		2773	id => "infobox",
		2774	title => "Map Info",
		2775	reply => undef,
		2776	tooltip => "Information related to the maps",
2660	},	2777	},
2661	);	2778	);
2662		2779
2663	sub cf::client::send_msg {	2780	sub cf::client::send_msg {
2664	my ($self, $channel, $msg, $color, @extra) = @_;	2781	my ($self, $channel, $msg, $color, @extra) = @_;
…		…
3033	{	3150	{
3034	my $faces = $facedata->{faceinfo};	3151	my $faces = $facedata->{faceinfo};
3035		3152
3036	while (my ($face, $info) = each %$faces) {	3153	while (my ($face, $info) = each %$faces) {
3037	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	3154	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
		3155
3038	cf::face::set_visibility $idx, $info->{visibility};	3156	cf::face::set_visibility $idx, $info->{visibility};
3039	cf::face::set_magicmap $idx, $info->{magicmap};	3157	cf::face::set_magicmap $idx, $info->{magicmap};
3040	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};	3158	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3041	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};	3159	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3042		3160
3043	cf::cede_to_tick;	3161	cf::cede_to_tick;
3044	}	3162	}
3045		3163
3046	while (my ($face, $info) = each %$faces) {	3164	while (my ($face, $info) = each %$faces) {
3047	next unless $info->{smooth};	3165	next unless $info->{smooth};
		3166
3048	my $idx = cf::face::find $face	3167	my $idx = cf::face::find $face
3049	or next;	3168	or next;
		3169
3050	if (my $smooth = cf::face::find $info->{smooth}) {	3170	if (my $smooth = cf::face::find $info->{smooth}) {
3051	cf::face::set_smooth $idx, $smooth;	3171	cf::face::set_smooth $idx, $smooth;
3052	cf::face::set_smoothlevel $idx, $info->{smoothlevel};	3172	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3053	} else {	3173	} else {
3054	warn "smooth face '$info->{smooth}' not found for face '$face'";	3174	warn "smooth face '$info->{smooth}' not found for face '$face'";
…		…
3072	{	3192	{
3073	# TODO: for gcfclient pleasure, we should give resources	3193	# TODO: for gcfclient pleasure, we should give resources
3074	# that gcfclient doesn't grok a >10000 face index.	3194	# that gcfclient doesn't grok a >10000 face index.
3075	my $res = $facedata->{resource};	3195	my $res = $facedata->{resource};
3076		3196
3077	my $soundconf = delete $res->{"res/sound.conf"};
3078
3079	while (my ($name, $info) = each %$res) {	3197	while (my ($name, $info) = each %$res) {
		3198	if (defined $info->{type}) {
3080	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	3199	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
3081	my $data;	3200	my $data;
3082		3201
3083	if ($info->{type} & 1) {	3202	if ($info->{type} & 1) {
3084	# prepend meta info	3203	# prepend meta info
3085		3204
3086	my $meta = $enc->encode ({	3205	my $meta = $enc->encode ({
3087	name => $name,	3206	name => $name,
3088	%{ $info->{meta} \|\| {} },	3207	%{ $info->{meta} \|\| {} },
3089	});	3208	});
3090		3209
3091	$data = pack "(w/a)", $meta, $info->{data};	3210	$data = pack "(w/a)", $meta, $info->{data};
		3211	} else {
		3212	$data = $info->{data};
		3213	}
		3214
		3215	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
		3216	cf::face::set_type $idx, $info->{type};
3092	} else {	3217	} else {
3093	$data = $info->{data};	3218	$RESOURCE{$name} = $info;
3094	}	3219	}
3095		3220
3096	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3097	cf::face::set_type $idx, $info->{type};
3098
3099	cf::cede_to_tick;	3221	cf::cede_to_tick;
3100	}	3222	}
3101		3223
3102	if ($soundconf) {	3224	if (my $soundconf = delete $res->{"res/sound.conf"}) {
3103	$soundconf = $enc->decode (delete $soundconf->{data});	3225	$soundconf = $enc->decode (delete $soundconf->{data});
3104		3226
3105	for (0 .. SOUND_CAST_SPELL_0 - 1) {	3227	for (0 .. SOUND_CAST_SPELL_0 - 1) {
3106	my $sound = $soundconf->{compat}[$_]	3228	my $sound = $soundconf->{compat}[$_]
3107	or next;	3229	or next;
…		…
3204	# we must not ever block the main coroutine	3326	# we must not ever block the main coroutine
3205	local $Coro::idle = sub {	3327	local $Coro::idle = sub {
3206	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#	3328	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3207	(async {	3329	(async {
3208	$Coro::current->{desc} = "IDLE BUG HANDLER";	3330	$Coro::current->{desc} = "IDLE BUG HANDLER";
3209	Event::one_event;	3331	EV::loop EV::LOOP_ONESHOT;
3210	})->prio (Coro::PRIO_MAX);	3332	})->prio (Coro::PRIO_MAX);
3211	};	3333	};
3212		3334
3213	reload_config;	3335	reload_config;
3214	db_init;	3336	db_init;
3215	load_extensions;	3337	load_extensions;
3216		3338
3217	$TICK_WATCHER->start;	3339	$TICK_WATCHER->start;
		3340	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3218	Event::loop;	3341	EV::loop;
3219	}	3342	}
3220		3343
3221	#############################################################################	3344	#############################################################################
3222	# initialisation and cleanup	3345	# initialisation and cleanup
3223		3346
3224	# install some emergency cleanup handlers	3347	# install some emergency cleanup handlers
3225	BEGIN {	3348	BEGIN {
		3349	our %SIGWATCHER = ();
3226	for my $signal (qw(INT HUP TERM)) {	3350	for my $signal (qw(INT HUP TERM)) {
3227	Event->signal (	3351	$SIGWATCHER{$signal} = EV::signal $signal, sub {
3228	reentrant => 0,
3229	data => WF_AUTOCANCEL,
3230	signal => $signal,
3231	prio => 0,
3232	cb => sub {
3233	cf::cleanup "SIG$signal";	3352	cf::cleanup "SIG$signal";
3234	},
3235	);	3353	};
3236	}	3354	}
3237	}	3355	}
3238		3356
3239	sub write_runtime {	3357	sub write_runtime {
3240	my $runtime = "$LOCALDIR/runtime";	3358	my $runtime = "$LOCALDIR/runtime";
…		…
3334	warn "syncing database to disk";	3452	warn "syncing database to disk";
3335	BDB::db_env_txn_checkpoint $DB_ENV;	3453	BDB::db_env_txn_checkpoint $DB_ENV;
3336		3454
3337	# if anything goes wrong in here, we should simply crash as we already saved	3455	# if anything goes wrong in here, we should simply crash as we already saved
3338		3456
3339	warn "cancelling all WF_AUTOCANCEL watchers";
3340	for (Event::all_watchers) {
3341	$_->cancel if $_->data & WF_AUTOCANCEL;
3342	}
3343
3344	warn "flushing outstanding aio requests";	3457	warn "flushing outstanding aio requests";
3345	for (;;) {	3458	for (;;) {
3346	BDB::flush;	3459	BDB::flush;
3347	IO::AIO::flush;	3460	IO::AIO::flush;
3348	Coro::cede;	3461	Coro::cede_notself;
3349	last unless IO::AIO::nreqs \|\| BDB::nreqs;	3462	last unless IO::AIO::nreqs \|\| BDB::nreqs;
3350	warn "iterate...";	3463	warn "iterate...";
3351	}	3464	}
3352		3465
3353	++$RELOAD;	3466	++$RELOAD;
…		…
3442		3555
3443	sub reload_perl() {	3556	sub reload_perl() {
3444	# doing reload synchronously and two reloads happen back-to-back,	3557	# doing reload synchronously and two reloads happen back-to-back,
3445	# coro crashes during coro_state_free->destroy here.	3558	# coro crashes during coro_state_free->destroy here.
3446		3559
3447	$RELOAD_WATCHER \|\|= Event->timer (	3560	$RELOAD_WATCHER \|\|= EV::timer 0, 0, sub {
3448	reentrant => 0,
3449	after => 0,
3450	data => WF_AUTOCANCEL,
3451	cb => sub {
3452	do_reload_perl;
3453	undef $RELOAD_WATCHER;	3561	undef $RELOAD_WATCHER;
3454	},	3562	do_reload_perl;
3455	);	3563	};
3456	}	3564	}
3457		3565
3458	register_command "reload" => sub {	3566	register_command "reload" => sub {
3459	my ($who, $arg) = @_;	3567	my ($who, $arg) = @_;
3460		3568
…		…
3490	my $signal = new Coro::Signal;	3598	my $signal = new Coro::Signal;
3491	push @WAIT_FOR_TICK_BEGIN, $signal;	3599	push @WAIT_FOR_TICK_BEGIN, $signal;
3492	$signal->wait;	3600	$signal->wait;
3493	}	3601	}
3494		3602
3495	$TICK_WATCHER = Event->timer (	3603	$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3496	reentrant => 0,
3497	parked => 1,
3498	prio => 0,
3499	at => $NEXT_TICK \|\| $TICK,
3500	data => WF_AUTOCANCEL,
3501	cb => sub {
3502	if ($Coro::current != $Coro::main) {	3604	if ($Coro::current != $Coro::main) {
3503	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"	3605	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3504	unless ++$bug_warning > 10;	3606	unless ++$bug_warning > 10;
3505	return;	3607	return;
3506	}	3608	}
3507		3609
3508	$NOW = $tick_start = Event::time;	3610	$NOW = $tick_start = EV::now;
3509		3611
3510	cf::server_tick; # one server iteration	3612	cf::server_tick; # one server iteration
3511		3613
3512	$RUNTIME += $TICK;	3614	$RUNTIME += $TICK;
3513	$NEXT_TICK += $TICK;	3615	$NEXT_TICK = $_[0]->at;
3514		3616
3515	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3617	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3516	$NEXT_RUNTIME_WRITE = $NOW + 10;	3618	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3517	Coro::async_pool {	3619	Coro::async_pool {
3518	$Coro::current->{desc} = "runtime saver";	3620	$Coro::current->{desc} = "runtime saver";
3519	write_runtime	3621	write_runtime
3520	or warn "ERROR: unable to write runtime file: $!";	3622	or warn "ERROR: unable to write runtime file: $!";
3521	};
3522	}	3623	};
		3624	}
3523		3625
3524	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3626	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3525	$sig->send;	3627	$sig->send;
3526	}	3628	}
3527	while (my $sig = shift @WAIT_FOR_TICK) {	3629	while (my $sig = shift @WAIT_FOR_TICK) {
3528	$sig->send;	3630	$sig->send;
3529	}	3631	}
3530		3632
3531	$NOW = Event::time;
3532
3533	# if we are delayed by four ticks or more, skip them all
3534	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3535
3536	$TICK_WATCHER->at ($NEXT_TICK);
3537	$TICK_WATCHER->start;
3538
3539	$LOAD = ($NOW - $tick_start) / $TICK;	3633	$LOAD = ($NOW - $tick_start) / $TICK;
3540	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	3634	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3541		3635
3542	_post_tick;	3636	_post_tick;
3543	},	3637	};
3544	);	3638	$TICK_WATCHER->priority (EV::MAXPRI);
3545		3639
3546	{	3640	{
		3641	# configure BDB
		3642
3547	BDB::min_parallel 8;	3643	BDB::min_parallel 8;
3548	BDB::max_poll_time $TICK * 0.1;	3644	BDB::max_poll_reqs $TICK * 0.1;
3549	$BDB_POLL_WATCHER = Event->io (	3645	$Coro::BDB::WATCHER->priority (1);
3550	reentrant => 0,
3551	fd => BDB::poll_fileno,
3552	poll => 'r',
3553	prio => 0,
3554	data => WF_AUTOCANCEL,
3555	cb => \&BDB::poll_cb,
3556	);
3557
3558	BDB::set_sync_prepare {
3559	my $status;
3560	my $current = $Coro::current;
3561	(
3562	sub {
3563	$status = $!;
3564	$current->ready; undef $current;
3565	},
3566	sub {
3567	Coro::schedule while defined $current;
3568	$! = $status;
3569	},
3570	)
3571	};
3572		3646
3573	unless ($DB_ENV) {	3647	unless ($DB_ENV) {
3574	$DB_ENV = BDB::db_env_create;	3648	$DB_ENV = BDB::db_env_create;
3575	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC	3649	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC
3576	\| BDB::LOG_AUTOREMOVE, 1);	3650	\| BDB::LOG_AUTOREMOVE, 1);
…		…
3591		3665
3592	cf::cleanup "db_env_open(db): $@" if $@;	3666	cf::cleanup "db_env_open(db): $@" if $@;
3593	};	3667	};
3594	}	3668	}
3595		3669
3596	$BDB_DEADLOCK_WATCHER = Event->timer (	3670	$BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3597	after => 3,
3598	interval => 1,
3599	hard => 1,
3600	prio => 0,
3601	data => WF_AUTOCANCEL,
3602	cb => sub {
3603	BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };	3671	BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3604	},
3605	);	3672	};
3606	$BDB_CHECKPOINT_WATCHER = Event->timer (	3673	$BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3607	after => 11,
3608	interval => 60,
3609	hard => 1,
3610	prio => 0,
3611	data => WF_AUTOCANCEL,
3612	cb => sub {
3613	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };	3674	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3614	},
3615	);	3675	};
3616	$BDB_TRICKLE_WATCHER = Event->timer (	3676	$BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3617	after => 5,
3618	interval => 10,
3619	hard => 1,
3620	prio => 0,
3621	data => WF_AUTOCANCEL,
3622	cb => sub {
3623	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };	3677	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3624	},
3625	);	3678	};
3626	}	3679	}
3627		3680
3628	{	3681	{
		3682	# configure IO::AIO
		3683
3629	IO::AIO::min_parallel 8;	3684	IO::AIO::min_parallel 8;
3630
3631	undef $Coro::AIO::WATCHER;
3632	IO::AIO::max_poll_time $TICK * 0.1;	3685	IO::AIO::max_poll_time $TICK * 0.1;
3633	$AIO_POLL_WATCHER = Event->io (	3686	$Coro::AIO::WATCHER->priority (1);
3634	reentrant => 0,
3635	data => WF_AUTOCANCEL,
3636	fd => IO::AIO::poll_fileno,
3637	poll => 'r',
3638	prio => 0,
3639	cb => \&IO::AIO::poll_cb,
3640	);
3641	}	3687	}
3642		3688
3643	my $_log_backtrace;	3689	my $_log_backtrace;
3644		3690
3645	sub _log_backtrace {	3691	sub _log_backtrace {

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.385 by root, Fri Oct 12 19:13:26 2007 UTC vs. Revision 1.405 by root, Mon Dec 17 08:03:22 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.385 by root, Fri Oct 12 19:13:26 2007 UTC vs.
Revision 1.405 by root, Mon Dec 17 08:03:22 2007 UTC