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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.384 by root, Fri Oct 12 18:17:16 2007 UTC vs.
Revision 1.406 by root, Mon Dec 17 08:27:44 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 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 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 \| logBacktrace, Carp::longmess "sync job";#d#	447	LOG llevError, Carp::longmess "sync job";#d#
433		448
434	# TODO: use suspend/resume instead	449	# TODO: use suspend/resume instead
435	# (but this is cancel-safe)	450	# (but this is cancel-safe)
436	my $freeze_guard = freeze_mainloop;	451	my $freeze_guard = freeze_mainloop;
437		452
…		…
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
…		…
950	}	969	}
951		970
952	0	971	0
953	}	972	}
954		973
955	=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)	974	=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
956		975
957	=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)	976	=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
958		977
959	Generate an object-specific event with the given arguments.	978	Generate an object-specific event with the given arguments.
960		979
…		…
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	local $Storable::canonical = 1;	1027	++$SLOW_MERGES;#d#
977	my $fob1 = Storable::freeze $ob1;
978	my $fob2 = Storable::freeze $ob2;
979		1028
980	$fob1 eq $fob2	1029	# we do the slow way here
		1030	return _object_equal $ob1, $ob2
981	}	1031	}
982		1032
983	sub reattach {	1033	sub reattach {
984	# basically do the same as instantiate, without calling instantiate	1034	# basically do the same as instantiate, without calling instantiate
985	my ($obj) = @_;	1035	my ($obj) = @_;
…		…
1007	cf::attachable->attach (	1057	cf::attachable->attach (
1008	prio => -1000000,	1058	prio => -1000000,
1009	on_instantiate => sub {	1059	on_instantiate => sub {
1010	my ($obj, $data) = @_;	1060	my ($obj, $data) = @_;
1011		1061
1012	$data = from_json $data;	1062	$data = decode_json $data;
1013		1063
1014	for (@$data) {	1064	for (@$data) {
1015	my ($name, $args) = @$_;	1065	my ($name, $args) = @$_;
1016		1066
1017	$obj->attach ($name, %{$args \|\| {} });	1067	$obj->attach ($name, %{$args \|\| {} });
…		…
1046	close $fh;	1096	close $fh;
1047		1097
1048	if (@$objs) {	1098	if (@$objs) {
1049	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) {
1050	chmod SAVE_MODE, $fh;	1100	chmod SAVE_MODE, $fh;
1051	my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs };	1101	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1052	aio_write $fh, 0, (length $data), $data, 0;	1102	aio_write $fh, 0, (length $data), $data, 0;
1053	aio_fsync $fh if $cf::USE_FSYNC;	1103	aio_fsync $fh if $cf::USE_FSYNC;
1054	close $fh;	1104	close $fh;
1055	aio_rename "$filename.pst~", "$filename.pst";	1105	aio_rename "$filename.pst~", "$filename.pst";
1056	}	1106	}
…		…
1087		1137
1088	unless (aio_stat "$filename.pst") {	1138	unless (aio_stat "$filename.pst") {
1089	(aio_load "$filename.pst", $av) >= 0	1139	(aio_load "$filename.pst", $av) >= 0
1090	or return;	1140	or return;
1091		1141
1092	my $st = eval { Coro::Storable::thaw $av }	1142	my $st = eval { Coro::Storable::thaw $av };
1093	\|\| eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1094	$av = $st->{objs};	1143	$av = $st->{objs};
1095	}	1144	}
1096		1145
1097	utf8::decode (my $decname = $filename);	1146	utf8::decode (my $decname = $filename);
1098	warn sprintf "loading %s (%d,%d)\n",	1147	warn sprintf "loading %s (%d,%d)\n",
…		…
1514		1563
1515	Expand crossfire pod fragments into protocol xml.	1564	Expand crossfire pod fragments into protocol xml.
1516		1565
1517	=cut	1566	=cut
1518		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
1519	sub expand_cfpod {	1579	sub expand_cfpod {
1520	((my $self), (local $_)) = @_;	1580	my ($self, $pod) = @_;
1521		1581
1522	# escape & and <	1582	my $xml;
1523	s/&/&/g;
1524	s/(?<![BIUGHT])</</g;
1525		1583
1526	# this is buggy, it needs to properly take care of nested <'s	1584	while () {
		1585	if ($pod =~ /\G( (?: [^BCGHITU]+ \| .(?!<) )+ )/xgcs) {
		1586	$group = $1;
1527		1587
1528	1 while	1588	$group =~ s/&/&/g;
1529	# replace B<>, I<>, U<> etc.	1589	$group =~ s/</</g;
1530	s/B<([^\>]*)>/<b>$1<\/b>/	1590
1531	\|\| s/I<([^\>]*)>/<i>$1<\/i>/	1591	$xml .= $group;
1532	\|\| s/U<([^\>]*)>/<u>$1<\/u>/	1592	} elsif ($pod =~ m%\G
1533	\|\| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/	1593	([BCGHITU])
1534	# replace G<male\|female> tags	1594	<
1535	\|\| s{G<([^>\|])\\|([^>])>}{	1595	(?:
1536	$self->gender ? $2 : $1	1596	([^<>]*) (?{ $group = $^N })
1537	}ge	1597	\| < $interior >
1538	# replace H<hint text>	1598	)
1539	\|\| s{H<([^\>]*)>}	1599	>
		1600	%gcsx
1540	{	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") {
1541	("<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>",
1542	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",	1620	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1543	"")	1621	"")
1544	[$self->{hintmode}]	1622	[$self->{hintmode}];
		1623	} else {
		1624	$xml .= "error processing '$code($data)' directive";
1545	}ge;	1625	}
		1626	} else {
		1627	if ($pod =~ /\G(.+)/) {
		1628	warn "parse error while expanding $pod (at $1)";
		1629	}
		1630	last;
		1631	}
		1632	}
1546		1633
		1634	for ($xml) {
1547	# create single paragraphs (very hackish)	1635	# create single paragraphs (very hackish)
1548	s/(?<=\S)\n(?=\w)/ /g;	1636	s/(?<=\S)\n(?=\w)/ /g;
1549		1637
1550	# compress some whitespace	1638	# compress some whitespace
1551	s/\s+\n/\n/g; # ws line-ends	1639	s/\s+\n/\n/g; # ws line-ends
1552	s/\n\n+/\n/g; # double lines	1640	s/\n\n+/\n/g; # double lines
1553	s/^\n+//; # beginning lines	1641	s/^\n+//; # beginning lines
1554	s/\n+$//; # ending lines	1642	s/\n+$//; # ending lines
		1643	}
1555		1644
1556	$_	1645	$xml
1557	}	1646	}
		1647
		1648	no re 'eval';
1558		1649
1559	sub hintmode {	1650	sub hintmode {
1560	$_[0]{hintmode} = $_[1] if @_ > 1;	1651	$_[0]{hintmode} = $_[1] if @_ > 1;
1561	$_[0]{hintmode}	1652	$_[0]{hintmode}
1562	}	1653	}
…		…
2549	$rmp->{origin_y} = $exit->y;	2640	$rmp->{origin_y} = $exit->y;
2550	}	2641	}
2551		2642
2552	$rmp->{random_seed} \|\|= $exit->random_seed;	2643	$rmp->{random_seed} \|\|= $exit->random_seed;
2553		2644
2554	my $data = cf::to_json $rmp;	2645	my $data = cf::encode_json $rmp;
2555	my $md5 = Digest::MD5::md5_hex $data;	2646	my $md5 = Digest::MD5::md5_hex $data;
2556	my $meta = "$RANDOMDIR/$md5.meta";	2647	my $meta = "$RANDOMDIR/$md5.meta";
2557		2648
2558	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {	2649	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {
2559	aio_write $fh, 0, (length $data), $data, 0;	2650	aio_write $fh, 0, (length $data), $data, 0;
…		…
2632	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
2633	the message unless the client supports the msg packet.	2724	the message unless the client supports the msg packet.
2634		2725
2635	=cut	2726	=cut
2636		2727
		2728	# non-persistent channels (usually the info channel)
2637	our %CHANNEL = (	2729	our %CHANNEL = (
2638	"c/identify" => {	2730	"c/identify" => {
2639	id => "infobox",	2731	id => "infobox",
2640	title => "Identify",	2732	title => "Identify",
2641	reply => undef,	2733	reply => undef,
…		…
2645	id => "infobox",	2737	id => "infobox",
2646	title => "Examine",	2738	title => "Examine",
2647	reply => undef,	2739	reply => undef,
2648	tooltip => "Signs and other items you examined",	2740	tooltip => "Signs and other items you examined",
2649	},	2741	},
		2742	"c/book" => {
		2743	id => "infobox",
		2744	title => "Book",
		2745	reply => undef,
		2746	tooltip => "The contents of a note or book",
		2747	},
2650	"c/lookat" => {	2748	"c/lookat" => {
2651	id => "infobox",	2749	id => "infobox",
2652	title => "Look",	2750	title => "Look",
2653	reply => undef,	2751	reply => undef,
2654	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",
2655	},	2777	},
2656	);	2778	);
2657		2779
2658	sub cf::client::send_msg {	2780	sub cf::client::send_msg {
2659	my ($self, $channel, $msg, $color, @extra) = @_;	2781	my ($self, $channel, $msg, $color, @extra) = @_;
…		…
3028	{	3150	{
3029	my $faces = $facedata->{faceinfo};	3151	my $faces = $facedata->{faceinfo};
3030		3152
3031	while (my ($face, $info) = each %$faces) {	3153	while (my ($face, $info) = each %$faces) {
3032	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	3154	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
		3155
3033	cf::face::set_visibility $idx, $info->{visibility};	3156	cf::face::set_visibility $idx, $info->{visibility};
3034	cf::face::set_magicmap $idx, $info->{magicmap};	3157	cf::face::set_magicmap $idx, $info->{magicmap};
3035	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};
3036	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};
3037		3160
3038	cf::cede_to_tick;	3161	cf::cede_to_tick;
3039	}	3162	}
3040		3163
3041	while (my ($face, $info) = each %$faces) {	3164	while (my ($face, $info) = each %$faces) {
3042	next unless $info->{smooth};	3165	next unless $info->{smooth};
		3166
3043	my $idx = cf::face::find $face	3167	my $idx = cf::face::find $face
3044	or next;	3168	or next;
		3169
3045	if (my $smooth = cf::face::find $info->{smooth}) {	3170	if (my $smooth = cf::face::find $info->{smooth}) {
3046	cf::face::set_smooth $idx, $smooth;	3171	cf::face::set_smooth $idx, $smooth;
3047	cf::face::set_smoothlevel $idx, $info->{smoothlevel};	3172	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3048	} else {	3173	} else {
3049	warn "smooth face '$info->{smooth}' not found for face '$face'";	3174	warn "smooth face '$info->{smooth}' not found for face '$face'";
…		…
3067	{	3192	{
3068	# TODO: for gcfclient pleasure, we should give resources	3193	# TODO: for gcfclient pleasure, we should give resources
3069	# that gcfclient doesn't grok a >10000 face index.	3194	# that gcfclient doesn't grok a >10000 face index.
3070	my $res = $facedata->{resource};	3195	my $res = $facedata->{resource};
3071		3196
3072	my $soundconf = delete $res->{"res/sound.conf"};
3073
3074	while (my ($name, $info) = each %$res) {	3197	while (my ($name, $info) = each %$res) {
		3198	if (defined $info->{type}) {
3075	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	3199	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
3076	my $data;	3200	my $data;
3077		3201
3078	if ($info->{type} & 1) {	3202	if ($info->{type} & 1) {
3079	# prepend meta info	3203	# prepend meta info
3080		3204
3081	my $meta = $enc->encode ({	3205	my $meta = $enc->encode ({
3082	name => $name,	3206	name => $name,
3083	%{ $info->{meta} \|\| {} },	3207	%{ $info->{meta} \|\| {} },
3084	});	3208	});
3085		3209
3086	$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};
3087	} else {	3217	} else {
3088	$data = $info->{data};	3218	$RESOURCE{$name} = $info;
3089	}	3219	}
3090		3220
3091	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3092	cf::face::set_type $idx, $info->{type};
3093
3094	cf::cede_to_tick;	3221	cf::cede_to_tick;
3095	}	3222	}
3096
3097	if ($soundconf) {
3098	$soundconf = $enc->decode (delete $soundconf->{data});
3099
3100	for (0 .. SOUND_CAST_SPELL_0 - 1) {
3101	my $sound = $soundconf->{compat}[$_]
3102	or next;
3103
3104	my $face = cf::face::find "sound/$sound->[1]";
3105	cf::sound::set $sound->[0] => $face;
3106	cf::sound::old_sound_index $_, $face; # gcfclient-compat
3107	}
3108
3109	while (my ($k, $v) = each %{$soundconf->{event}}) {
3110	my $face = cf::face::find "sound/$v";
3111	cf::sound::set $k => $face;
3112	}
3113	}
3114	}	3223	}
		3224
		3225	cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3115		3226
3116	1	3227	1
3117	}	3228	}
		3229
		3230	cf::global->attach (on_resource_update => sub {
		3231	if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
		3232	$soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
		3233
		3234	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3235	my $sound = $soundconf->{compat}[$_]
		3236	or next;
		3237
		3238	my $face = cf::face::find "sound/$sound->[1]";
		3239	cf::sound::set $sound->[0] => $face;
		3240	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3241	}
		3242
		3243	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3244	my $face = cf::face::find "sound/$v";
		3245	cf::sound::set $k => $face;
		3246	}
		3247	}
		3248	});
3118		3249
3119	register_exticmd fx_want => sub {	3250	register_exticmd fx_want => sub {
3120	my ($ns, $want) = @_;	3251	my ($ns, $want) = @_;
3121		3252
3122	while (my ($k, $v) = each %$want) {	3253	while (my ($k, $v) = each %$want) {
…		…
3199	# we must not ever block the main coroutine	3330	# we must not ever block the main coroutine
3200	local $Coro::idle = sub {	3331	local $Coro::idle = sub {
3201	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#	3332	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3202	(async {	3333	(async {
3203	$Coro::current->{desc} = "IDLE BUG HANDLER";	3334	$Coro::current->{desc} = "IDLE BUG HANDLER";
3204	Event::one_event;	3335	EV::loop EV::LOOP_ONESHOT;
3205	})->prio (Coro::PRIO_MAX);	3336	})->prio (Coro::PRIO_MAX);
3206	};	3337	};
3207		3338
3208	reload_config;	3339	reload_config;
3209	db_init;	3340	db_init;
3210	load_extensions;	3341	load_extensions;
3211		3342
3212	$TICK_WATCHER->start;	3343	$TICK_WATCHER->start;
		3344	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3213	Event::loop;	3345	EV::loop;
3214	}	3346	}
3215		3347
3216	#############################################################################	3348	#############################################################################
3217	# initialisation and cleanup	3349	# initialisation and cleanup
3218		3350
3219	# install some emergency cleanup handlers	3351	# install some emergency cleanup handlers
3220	BEGIN {	3352	BEGIN {
		3353	our %SIGWATCHER = ();
3221	for my $signal (qw(INT HUP TERM)) {	3354	for my $signal (qw(INT HUP TERM)) {
3222	Event->signal (	3355	$SIGWATCHER{$signal} = EV::signal $signal, sub {
3223	reentrant => 0,
3224	data => WF_AUTOCANCEL,
3225	signal => $signal,
3226	prio => 0,
3227	cb => sub {
3228	cf::cleanup "SIG$signal";	3356	cf::cleanup "SIG$signal";
3229	},
3230	);	3357	};
3231	}	3358	}
3232	}	3359	}
3233		3360
3234	sub write_runtime {	3361	sub write_runtime {
3235	my $runtime = "$LOCALDIR/runtime";	3362	my $runtime = "$LOCALDIR/runtime";
…		…
3329	warn "syncing database to disk";	3456	warn "syncing database to disk";
3330	BDB::db_env_txn_checkpoint $DB_ENV;	3457	BDB::db_env_txn_checkpoint $DB_ENV;
3331		3458
3332	# if anything goes wrong in here, we should simply crash as we already saved	3459	# if anything goes wrong in here, we should simply crash as we already saved
3333		3460
3334	warn "cancelling all WF_AUTOCANCEL watchers";
3335	for (Event::all_watchers) {
3336	$_->cancel if $_->data & WF_AUTOCANCEL;
3337	}
3338
3339	warn "flushing outstanding aio requests";	3461	warn "flushing outstanding aio requests";
3340	for (;;) {	3462	for (;;) {
3341	BDB::flush;	3463	BDB::flush;
3342	IO::AIO::flush;	3464	IO::AIO::flush;
3343	Coro::cede;	3465	Coro::cede_notself;
3344	last unless IO::AIO::nreqs \|\| BDB::nreqs;	3466	last unless IO::AIO::nreqs \|\| BDB::nreqs;
3345	warn "iterate...";	3467	warn "iterate...";
3346	}	3468	}
3347		3469
3348	++$RELOAD;	3470	++$RELOAD;
…		…
3437		3559
3438	sub reload_perl() {	3560	sub reload_perl() {
3439	# doing reload synchronously and two reloads happen back-to-back,	3561	# doing reload synchronously and two reloads happen back-to-back,
3440	# coro crashes during coro_state_free->destroy here.	3562	# coro crashes during coro_state_free->destroy here.
3441		3563
3442	$RELOAD_WATCHER \|\|= Event->timer (	3564	$RELOAD_WATCHER \|\|= EV::timer 0, 0, sub {
3443	reentrant => 0,
3444	after => 0,
3445	data => WF_AUTOCANCEL,
3446	cb => sub {
3447	do_reload_perl;
3448	undef $RELOAD_WATCHER;	3565	undef $RELOAD_WATCHER;
3449	},	3566	do_reload_perl;
3450	);	3567	};
3451	}	3568	}
3452		3569
3453	register_command "reload" => sub {	3570	register_command "reload" => sub {
3454	my ($who, $arg) = @_;	3571	my ($who, $arg) = @_;
3455		3572
…		…
3485	my $signal = new Coro::Signal;	3602	my $signal = new Coro::Signal;
3486	push @WAIT_FOR_TICK_BEGIN, $signal;	3603	push @WAIT_FOR_TICK_BEGIN, $signal;
3487	$signal->wait;	3604	$signal->wait;
3488	}	3605	}
3489		3606
3490	$TICK_WATCHER = Event->timer (	3607	$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3491	reentrant => 0,
3492	parked => 1,
3493	prio => 0,
3494	at => $NEXT_TICK \|\| $TICK,
3495	data => WF_AUTOCANCEL,
3496	cb => sub {
3497	if ($Coro::current != $Coro::main) {	3608	if ($Coro::current != $Coro::main) {
3498	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"	3609	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3499	unless ++$bug_warning > 10;	3610	unless ++$bug_warning > 10;
3500	return;	3611	return;
3501	}	3612	}
3502		3613
3503	$NOW = $tick_start = Event::time;	3614	$NOW = $tick_start = EV::now;
3504		3615
3505	cf::server_tick; # one server iteration	3616	cf::server_tick; # one server iteration
3506		3617
3507	$RUNTIME += $TICK;	3618	$RUNTIME += $TICK;
3508	$NEXT_TICK += $TICK;	3619	$NEXT_TICK = $_[0]->at;
3509		3620
3510	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3621	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3511	$NEXT_RUNTIME_WRITE = $NOW + 10;	3622	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3512	Coro::async_pool {	3623	Coro::async_pool {
3513	$Coro::current->{desc} = "runtime saver";	3624	$Coro::current->{desc} = "runtime saver";
3514	write_runtime	3625	write_runtime
3515	or warn "ERROR: unable to write runtime file: $!";	3626	or warn "ERROR: unable to write runtime file: $!";
3516	};
3517	}	3627	};
		3628	}
3518		3629
3519	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3630	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3520	$sig->send;	3631	$sig->send;
3521	}	3632	}
3522	while (my $sig = shift @WAIT_FOR_TICK) {	3633	while (my $sig = shift @WAIT_FOR_TICK) {
3523	$sig->send;	3634	$sig->send;
3524	}	3635	}
3525		3636
3526	$NOW = Event::time;
3527
3528	# if we are delayed by four ticks or more, skip them all
3529	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3530
3531	$TICK_WATCHER->at ($NEXT_TICK);
3532	$TICK_WATCHER->start;
3533
3534	$LOAD = ($NOW - $tick_start) / $TICK;	3637	$LOAD = ($NOW - $tick_start) / $TICK;
3535	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	3638	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3536		3639
3537	_post_tick;	3640	_post_tick;
3538	},	3641	};
3539	);	3642	$TICK_WATCHER->priority (EV::MAXPRI);
3540		3643
3541	{	3644	{
		3645	# configure BDB
		3646
3542	BDB::min_parallel 8;	3647	BDB::min_parallel 8;
3543	BDB::max_poll_time $TICK * 0.1;	3648	BDB::max_poll_reqs $TICK * 0.1;
3544	$BDB_POLL_WATCHER = Event->io (	3649	$Coro::BDB::WATCHER->priority (1);
3545	reentrant => 0,
3546	fd => BDB::poll_fileno,
3547	poll => 'r',
3548	prio => 0,
3549	data => WF_AUTOCANCEL,
3550	cb => \&BDB::poll_cb,
3551	);
3552
3553	BDB::set_sync_prepare {
3554	my $status;
3555	my $current = $Coro::current;
3556	(
3557	sub {
3558	$status = $!;
3559	$current->ready; undef $current;
3560	},
3561	sub {
3562	Coro::schedule while defined $current;
3563	$! = $status;
3564	},
3565	)
3566	};
3567		3650
3568	unless ($DB_ENV) {	3651	unless ($DB_ENV) {
3569	$DB_ENV = BDB::db_env_create;	3652	$DB_ENV = BDB::db_env_create;
3570	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC	3653	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC
3571	\| BDB::LOG_AUTOREMOVE, 1);	3654	\| BDB::LOG_AUTOREMOVE, 1);
…		…
3586		3669
3587	cf::cleanup "db_env_open(db): $@" if $@;	3670	cf::cleanup "db_env_open(db): $@" if $@;
3588	};	3671	};
3589	}	3672	}
3590		3673
3591	$BDB_DEADLOCK_WATCHER = Event->timer (	3674	$BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3592	after => 3,
3593	interval => 1,
3594	hard => 1,
3595	prio => 0,
3596	data => WF_AUTOCANCEL,
3597	cb => sub {
3598	BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };	3675	BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3599	},
3600	);	3676	};
3601	$BDB_CHECKPOINT_WATCHER = Event->timer (	3677	$BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3602	after => 11,
3603	interval => 60,
3604	hard => 1,
3605	prio => 0,
3606	data => WF_AUTOCANCEL,
3607	cb => sub {
3608	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };	3678	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3609	},
3610	);	3679	};
3611	$BDB_TRICKLE_WATCHER = Event->timer (	3680	$BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3612	after => 5,
3613	interval => 10,
3614	hard => 1,
3615	prio => 0,
3616	data => WF_AUTOCANCEL,
3617	cb => sub {
3618	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };	3681	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3619	},
3620	);	3682	};
3621	}	3683	}
3622		3684
3623	{	3685	{
		3686	# configure IO::AIO
		3687
3624	IO::AIO::min_parallel 8;	3688	IO::AIO::min_parallel 8;
3625
3626	undef $Coro::AIO::WATCHER;
3627	IO::AIO::max_poll_time $TICK * 0.1;	3689	IO::AIO::max_poll_time $TICK * 0.1;
3628	$AIO_POLL_WATCHER = Event->io (	3690	$Coro::AIO::WATCHER->priority (1);
3629	reentrant => 0,
3630	data => WF_AUTOCANCEL,
3631	fd => IO::AIO::poll_fileno,
3632	poll => 'r',
3633	prio => 0,
3634	cb => \&IO::AIO::poll_cb,
3635	);
3636	}	3691	}
3637		3692
3638	my $_log_backtrace;	3693	my $_log_backtrace;
3639		3694
3640	sub _log_backtrace {	3695	sub _log_backtrace {

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.384 by root, Fri Oct 12 18:17:16 2007 UTC vs. Revision 1.406 by root, Mon Dec 17 08:27:44 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.384 by root, Fri Oct 12 18:17:16 2007 UTC vs.
Revision 1.406 by root, Mon Dec 17 08:27:44 2007 UTC