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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.386 by root, Mon Oct 15 17:50:27 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
…		…
1038	cf::attachable->attach (	1057	cf::attachable->attach (
1039	prio => -1000000,	1058	prio => -1000000,
1040	on_instantiate => sub {	1059	on_instantiate => sub {
1041	my ($obj, $data) = @_;	1060	my ($obj, $data) = @_;
1042		1061
1043	$data = from_json $data;	1062	$data = decode_json $data;
1044		1063
1045	for (@$data) {	1064	for (@$data) {
1046	my ($name, $args) = @$_;	1065	my ($name, $args) = @$_;
1047		1066
1048	$obj->attach ($name, %{$args \|\| {} });	1067	$obj->attach ($name, %{$args \|\| {} });
…		…
1077	close $fh;	1096	close $fh;
1078		1097
1079	if (@$objs) {	1098	if (@$objs) {
1080	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) {
1081	chmod SAVE_MODE, $fh;	1100	chmod SAVE_MODE, $fh;
1082	my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs };	1101	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1083	aio_write $fh, 0, (length $data), $data, 0;	1102	aio_write $fh, 0, (length $data), $data, 0;
1084	aio_fsync $fh if $cf::USE_FSYNC;	1103	aio_fsync $fh if $cf::USE_FSYNC;
1085	close $fh;	1104	close $fh;
1086	aio_rename "$filename.pst~", "$filename.pst";	1105	aio_rename "$filename.pst~", "$filename.pst";
1087	}	1106	}
…		…
1118		1137
1119	unless (aio_stat "$filename.pst") {	1138	unless (aio_stat "$filename.pst") {
1120	(aio_load "$filename.pst", $av) >= 0	1139	(aio_load "$filename.pst", $av) >= 0
1121	or return;	1140	or return;
1122		1141
1123	my $st = eval { Coro::Storable::thaw $av }	1142	my $st = eval { Coro::Storable::thaw $av };
1124	\|\| eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1125	$av = $st->{objs};	1143	$av = $st->{objs};
1126	}	1144	}
1127		1145
1128	utf8::decode (my $decname = $filename);	1146	utf8::decode (my $decname = $filename);
1129	warn sprintf "loading %s (%d,%d)\n",	1147	warn sprintf "loading %s (%d,%d)\n",
…		…
1545		1563
1546	Expand crossfire pod fragments into protocol xml.	1564	Expand crossfire pod fragments into protocol xml.
1547		1565
1548	=cut	1566	=cut
1549		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
1550	sub expand_cfpod {	1579	sub expand_cfpod {
1551	((my $self), (local $_)) = @_;	1580	my ($self, $pod) = @_;
1552		1581
1553	# escape & and <	1582	my $xml;
1554	s/&/&/g;
1555	s/(?<![BIUGHT])</</g;
1556		1583
1557	# this is buggy, it needs to properly take care of nested <'s	1584	while () {
		1585	if ($pod =~ /\G( (?: [^BCGHITU]+ \| .(?!<) )+ )/xgcs) {
		1586	$group = $1;
1558		1587
1559	1 while	1588	$group =~ s/&/&/g;
1560	# replace B<>, I<>, U<> etc.	1589	$group =~ s/</</g;
1561	s/B<([^\>]*)>/<b>$1<\/b>/	1590
1562	\|\| s/I<([^\>]*)>/<i>$1<\/i>/	1591	$xml .= $group;
1563	\|\| s/U<([^\>]*)>/<u>$1<\/u>/	1592	} elsif ($pod =~ m%\G
1564	\|\| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/	1593	([BCGHITU])
1565	# replace G<male\|female> tags	1594	<
1566	\|\| s{G<([^>\|])\\|([^>])>}{	1595	(?:
1567	$self->gender ? $2 : $1	1596	([^<>]*) (?{ $group = $^N })
1568	}ge	1597	\| < $interior >
1569	# replace H<hint text>	1598	)
1570	\|\| s{H<([^\>]*)>}	1599	>
		1600	%gcsx
1571	{	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") {
1572	("<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>",
1573	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",	1620	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1574	"")	1621	"")
1575	[$self->{hintmode}]	1622	[$self->{hintmode}];
		1623	} else {
		1624	$xml .= "error processing '$code($data)' directive";
1576	}ge;	1625	}
		1626	} else {
		1627	if ($pod =~ /\G(.+)/) {
		1628	warn "parse error while expanding $pod (at $1)";
		1629	}
		1630	last;
		1631	}
		1632	}
1577		1633
		1634	for ($xml) {
1578	# create single paragraphs (very hackish)	1635	# create single paragraphs (very hackish)
1579	s/(?<=\S)\n(?=\w)/ /g;	1636	s/(?<=\S)\n(?=\w)/ /g;
1580		1637
1581	# compress some whitespace	1638	# compress some whitespace
1582	s/\s+\n/\n/g; # ws line-ends	1639	s/\s+\n/\n/g; # ws line-ends
1583	s/\n\n+/\n/g; # double lines	1640	s/\n\n+/\n/g; # double lines
1584	s/^\n+//; # beginning lines	1641	s/^\n+//; # beginning lines
1585	s/\n+$//; # ending lines	1642	s/\n+$//; # ending lines
		1643	}
1586		1644
1587	$_	1645	$xml
1588	}	1646	}
		1647
		1648	no re 'eval';
1589		1649
1590	sub hintmode {	1650	sub hintmode {
1591	$_[0]{hintmode} = $_[1] if @_ > 1;	1651	$_[0]{hintmode} = $_[1] if @_ > 1;
1592	$_[0]{hintmode}	1652	$_[0]{hintmode}
1593	}	1653	}
…		…
2580	$rmp->{origin_y} = $exit->y;	2640	$rmp->{origin_y} = $exit->y;
2581	}	2641	}
2582		2642
2583	$rmp->{random_seed} \|\|= $exit->random_seed;	2643	$rmp->{random_seed} \|\|= $exit->random_seed;
2584		2644
2585	my $data = cf::to_json $rmp;	2645	my $data = cf::encode_json $rmp;
2586	my $md5 = Digest::MD5::md5_hex $data;	2646	my $md5 = Digest::MD5::md5_hex $data;
2587	my $meta = "$RANDOMDIR/$md5.meta";	2647	my $meta = "$RANDOMDIR/$md5.meta";
2588		2648
2589	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {	2649	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {
2590	aio_write $fh, 0, (length $data), $data, 0;	2650	aio_write $fh, 0, (length $data), $data, 0;
…		…
2663	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
2664	the message unless the client supports the msg packet.	2724	the message unless the client supports the msg packet.
2665		2725
2666	=cut	2726	=cut
2667		2727
		2728	# non-persistent channels (usually the info channel)
2668	our %CHANNEL = (	2729	our %CHANNEL = (
2669	"c/identify" => {	2730	"c/identify" => {
2670	id => "infobox",	2731	id => "infobox",
2671	title => "Identify",	2732	title => "Identify",
2672	reply => undef,	2733	reply => undef,
…		…
2676	id => "infobox",	2737	id => "infobox",
2677	title => "Examine",	2738	title => "Examine",
2678	reply => undef,	2739	reply => undef,
2679	tooltip => "Signs and other items you examined",	2740	tooltip => "Signs and other items you examined",
2680	},	2741	},
		2742	"c/book" => {
		2743	id => "infobox",
		2744	title => "Book",
		2745	reply => undef,
		2746	tooltip => "The contents of a note or book",
		2747	},
2681	"c/lookat" => {	2748	"c/lookat" => {
2682	id => "infobox",	2749	id => "infobox",
2683	title => "Look",	2750	title => "Look",
2684	reply => undef,	2751	reply => undef,
2685	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",
2686	},	2777	},
2687	);	2778	);
2688		2779
2689	sub cf::client::send_msg {	2780	sub cf::client::send_msg {
2690	my ($self, $channel, $msg, $color, @extra) = @_;	2781	my ($self, $channel, $msg, $color, @extra) = @_;
…		…
3059	{	3150	{
3060	my $faces = $facedata->{faceinfo};	3151	my $faces = $facedata->{faceinfo};
3061		3152
3062	while (my ($face, $info) = each %$faces) {	3153	while (my ($face, $info) = each %$faces) {
3063	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	3154	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
		3155
3064	cf::face::set_visibility $idx, $info->{visibility};	3156	cf::face::set_visibility $idx, $info->{visibility};
3065	cf::face::set_magicmap $idx, $info->{magicmap};	3157	cf::face::set_magicmap $idx, $info->{magicmap};
3066	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};
3067	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};
3068		3160
3069	cf::cede_to_tick;	3161	cf::cede_to_tick;
3070	}	3162	}
3071		3163
3072	while (my ($face, $info) = each %$faces) {	3164	while (my ($face, $info) = each %$faces) {
3073	next unless $info->{smooth};	3165	next unless $info->{smooth};
		3166
3074	my $idx = cf::face::find $face	3167	my $idx = cf::face::find $face
3075	or next;	3168	or next;
		3169
3076	if (my $smooth = cf::face::find $info->{smooth}) {	3170	if (my $smooth = cf::face::find $info->{smooth}) {
3077	cf::face::set_smooth $idx, $smooth;	3171	cf::face::set_smooth $idx, $smooth;
3078	cf::face::set_smoothlevel $idx, $info->{smoothlevel};	3172	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3079	} else {	3173	} else {
3080	warn "smooth face '$info->{smooth}' not found for face '$face'";	3174	warn "smooth face '$info->{smooth}' not found for face '$face'";
…		…
3098	{	3192	{
3099	# TODO: for gcfclient pleasure, we should give resources	3193	# TODO: for gcfclient pleasure, we should give resources
3100	# that gcfclient doesn't grok a >10000 face index.	3194	# that gcfclient doesn't grok a >10000 face index.
3101	my $res = $facedata->{resource};	3195	my $res = $facedata->{resource};
3102		3196
3103	my $soundconf = delete $res->{"res/sound.conf"};
3104
3105	while (my ($name, $info) = each %$res) {	3197	while (my ($name, $info) = each %$res) {
		3198	if (defined $info->{type}) {
3106	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	3199	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
3107	my $data;	3200	my $data;
3108		3201
3109	if ($info->{type} & 1) {	3202	if ($info->{type} & 1) {
3110	# prepend meta info	3203	# prepend meta info
3111		3204
3112	my $meta = $enc->encode ({	3205	my $meta = $enc->encode ({
3113	name => $name,	3206	name => $name,
3114	%{ $info->{meta} \|\| {} },	3207	%{ $info->{meta} \|\| {} },
3115	});	3208	});
3116		3209
3117	$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};
3118	} else {	3217	} else {
3119	$data = $info->{data};	3218	$RESOURCE{$name} = $info;
3120	}	3219	}
3121		3220
3122	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3123	cf::face::set_type $idx, $info->{type};
3124
3125	cf::cede_to_tick;	3221	cf::cede_to_tick;
3126	}	3222	}
3127		3223
3128	if ($soundconf) {	3224	if (my $soundconf = delete $res->{"res/sound.conf"}) {
3129	$soundconf = $enc->decode (delete $soundconf->{data});	3225	$soundconf = $enc->decode (delete $soundconf->{data});
3130		3226
3131	for (0 .. SOUND_CAST_SPELL_0 - 1) {	3227	for (0 .. SOUND_CAST_SPELL_0 - 1) {
3132	my $sound = $soundconf->{compat}[$_]	3228	my $sound = $soundconf->{compat}[$_]
3133	or next;	3229	or next;
…		…
3230	# we must not ever block the main coroutine	3326	# we must not ever block the main coroutine
3231	local $Coro::idle = sub {	3327	local $Coro::idle = sub {
3232	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#
3233	(async {	3329	(async {
3234	$Coro::current->{desc} = "IDLE BUG HANDLER";	3330	$Coro::current->{desc} = "IDLE BUG HANDLER";
3235	Event::one_event;	3331	EV::loop EV::LOOP_ONESHOT;
3236	})->prio (Coro::PRIO_MAX);	3332	})->prio (Coro::PRIO_MAX);
3237	};	3333	};
3238		3334
3239	reload_config;	3335	reload_config;
3240	db_init;	3336	db_init;
3241	load_extensions;	3337	load_extensions;
3242		3338
3243	$TICK_WATCHER->start;	3339	$TICK_WATCHER->start;
		3340	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3244	Event::loop;	3341	EV::loop;
3245	}	3342	}
3246		3343
3247	#############################################################################	3344	#############################################################################
3248	# initialisation and cleanup	3345	# initialisation and cleanup
3249		3346
3250	# install some emergency cleanup handlers	3347	# install some emergency cleanup handlers
3251	BEGIN {	3348	BEGIN {
		3349	our %SIGWATCHER = ();
3252	for my $signal (qw(INT HUP TERM)) {	3350	for my $signal (qw(INT HUP TERM)) {
3253	Event->signal (	3351	$SIGWATCHER{$signal} = EV::signal $signal, sub {
3254	reentrant => 0,
3255	data => WF_AUTOCANCEL,
3256	signal => $signal,
3257	prio => 0,
3258	cb => sub {
3259	cf::cleanup "SIG$signal";	3352	cf::cleanup "SIG$signal";
3260	},
3261	);	3353	};
3262	}	3354	}
3263	}	3355	}
3264		3356
3265	sub write_runtime {	3357	sub write_runtime {
3266	my $runtime = "$LOCALDIR/runtime";	3358	my $runtime = "$LOCALDIR/runtime";
…		…
3360	warn "syncing database to disk";	3452	warn "syncing database to disk";
3361	BDB::db_env_txn_checkpoint $DB_ENV;	3453	BDB::db_env_txn_checkpoint $DB_ENV;
3362		3454
3363	# 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
3364		3456
3365	warn "cancelling all WF_AUTOCANCEL watchers";
3366	for (Event::all_watchers) {
3367	$_->cancel if $_->data & WF_AUTOCANCEL;
3368	}
3369
3370	warn "flushing outstanding aio requests";	3457	warn "flushing outstanding aio requests";
3371	for (;;) {	3458	for (;;) {
3372	BDB::flush;	3459	BDB::flush;
3373	IO::AIO::flush;	3460	IO::AIO::flush;
3374	Coro::cede;	3461	Coro::cede_notself;
3375	last unless IO::AIO::nreqs \|\| BDB::nreqs;	3462	last unless IO::AIO::nreqs \|\| BDB::nreqs;
3376	warn "iterate...";	3463	warn "iterate...";
3377	}	3464	}
3378		3465
3379	++$RELOAD;	3466	++$RELOAD;
…		…
3468		3555
3469	sub reload_perl() {	3556	sub reload_perl() {
3470	# doing reload synchronously and two reloads happen back-to-back,	3557	# doing reload synchronously and two reloads happen back-to-back,
3471	# coro crashes during coro_state_free->destroy here.	3558	# coro crashes during coro_state_free->destroy here.
3472		3559
3473	$RELOAD_WATCHER \|\|= Event->timer (	3560	$RELOAD_WATCHER \|\|= EV::timer 0, 0, sub {
3474	reentrant => 0,
3475	after => 0,
3476	data => WF_AUTOCANCEL,
3477	cb => sub {
3478	do_reload_perl;
3479	undef $RELOAD_WATCHER;	3561	undef $RELOAD_WATCHER;
3480	},	3562	do_reload_perl;
3481	);	3563	};
3482	}	3564	}
3483		3565
3484	register_command "reload" => sub {	3566	register_command "reload" => sub {
3485	my ($who, $arg) = @_;	3567	my ($who, $arg) = @_;
3486		3568
…		…
3516	my $signal = new Coro::Signal;	3598	my $signal = new Coro::Signal;
3517	push @WAIT_FOR_TICK_BEGIN, $signal;	3599	push @WAIT_FOR_TICK_BEGIN, $signal;
3518	$signal->wait;	3600	$signal->wait;
3519	}	3601	}
3520		3602
3521	$TICK_WATCHER = Event->timer (	3603	$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3522	reentrant => 0,
3523	parked => 1,
3524	prio => 0,
3525	at => $NEXT_TICK \|\| $TICK,
3526	data => WF_AUTOCANCEL,
3527	cb => sub {
3528	if ($Coro::current != $Coro::main) {	3604	if ($Coro::current != $Coro::main) {
3529	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"
3530	unless ++$bug_warning > 10;	3606	unless ++$bug_warning > 10;
3531	return;	3607	return;
3532	}	3608	}
3533		3609
3534	$NOW = $tick_start = Event::time;	3610	$NOW = $tick_start = EV::now;
3535		3611
3536	cf::server_tick; # one server iteration	3612	cf::server_tick; # one server iteration
3537		3613
3538	$RUNTIME += $TICK;	3614	$RUNTIME += $TICK;
3539	$NEXT_TICK += $TICK;	3615	$NEXT_TICK = $_[0]->at;
3540		3616
3541	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3617	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3542	$NEXT_RUNTIME_WRITE = $NOW + 10;	3618	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3543	Coro::async_pool {	3619	Coro::async_pool {
3544	$Coro::current->{desc} = "runtime saver";	3620	$Coro::current->{desc} = "runtime saver";
3545	write_runtime	3621	write_runtime
3546	or warn "ERROR: unable to write runtime file: $!";	3622	or warn "ERROR: unable to write runtime file: $!";
3547	};
3548	}	3623	};
		3624	}
3549		3625
3550	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3626	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3551	$sig->send;	3627	$sig->send;
3552	}	3628	}
3553	while (my $sig = shift @WAIT_FOR_TICK) {	3629	while (my $sig = shift @WAIT_FOR_TICK) {
3554	$sig->send;	3630	$sig->send;
3555	}	3631	}
3556		3632
3557	$NOW = Event::time;
3558
3559	# if we are delayed by four ticks or more, skip them all
3560	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3561
3562	$TICK_WATCHER->at ($NEXT_TICK);
3563	$TICK_WATCHER->start;
3564
3565	$LOAD = ($NOW - $tick_start) / $TICK;	3633	$LOAD = ($NOW - $tick_start) / $TICK;
3566	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	3634	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3567		3635
3568	_post_tick;	3636	_post_tick;
3569	},	3637	};
3570	);	3638	$TICK_WATCHER->priority (EV::MAXPRI);
3571		3639
3572	{	3640	{
		3641	# configure BDB
		3642
3573	BDB::min_parallel 8;	3643	BDB::min_parallel 8;
3574	BDB::max_poll_time $TICK * 0.1;	3644	BDB::max_poll_reqs $TICK * 0.1;
3575	$BDB_POLL_WATCHER = Event->io (	3645	$Coro::BDB::WATCHER->priority (1);
3576	reentrant => 0,
3577	fd => BDB::poll_fileno,
3578	poll => 'r',
3579	prio => 0,
3580	data => WF_AUTOCANCEL,
3581	cb => \&BDB::poll_cb,
3582	);
3583
3584	BDB::set_sync_prepare {
3585	my $status;
3586	my $current = $Coro::current;
3587	(
3588	sub {
3589	$status = $!;
3590	$current->ready; undef $current;
3591	},
3592	sub {
3593	Coro::schedule while defined $current;
3594	$! = $status;
3595	},
3596	)
3597	};
3598		3646
3599	unless ($DB_ENV) {	3647	unless ($DB_ENV) {
3600	$DB_ENV = BDB::db_env_create;	3648	$DB_ENV = BDB::db_env_create;
3601	$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
3602	\| BDB::LOG_AUTOREMOVE, 1);	3650	\| BDB::LOG_AUTOREMOVE, 1);
…		…
3617		3665
3618	cf::cleanup "db_env_open(db): $@" if $@;	3666	cf::cleanup "db_env_open(db): $@" if $@;
3619	};	3667	};
3620	}	3668	}
3621		3669
3622	$BDB_DEADLOCK_WATCHER = Event->timer (	3670	$BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3623	after => 3,
3624	interval => 1,
3625	hard => 1,
3626	prio => 0,
3627	data => WF_AUTOCANCEL,
3628	cb => sub {
3629	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 { };
3630	},
3631	);	3672	};
3632	$BDB_CHECKPOINT_WATCHER = Event->timer (	3673	$BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3633	after => 11,
3634	interval => 60,
3635	hard => 1,
3636	prio => 0,
3637	data => WF_AUTOCANCEL,
3638	cb => sub {
3639	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };	3674	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3640	},
3641	);	3675	};
3642	$BDB_TRICKLE_WATCHER = Event->timer (	3676	$BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3643	after => 5,
3644	interval => 10,
3645	hard => 1,
3646	prio => 0,
3647	data => WF_AUTOCANCEL,
3648	cb => sub {
3649	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };	3677	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3650	},
3651	);	3678	};
3652	}	3679	}
3653		3680
3654	{	3681	{
		3682	# configure IO::AIO
		3683
3655	IO::AIO::min_parallel 8;	3684	IO::AIO::min_parallel 8;
3656
3657	undef $Coro::AIO::WATCHER;
3658	IO::AIO::max_poll_time $TICK * 0.1;	3685	IO::AIO::max_poll_time $TICK * 0.1;
3659	$AIO_POLL_WATCHER = Event->io (	3686	$Coro::AIO::WATCHER->priority (1);
3660	reentrant => 0,
3661	data => WF_AUTOCANCEL,
3662	fd => IO::AIO::poll_fileno,
3663	poll => 'r',
3664	prio => 0,
3665	cb => \&IO::AIO::poll_cb,
3666	);
3667	}	3687	}
3668		3688
3669	my $_log_backtrace;	3689	my $_log_backtrace;
3670		3690
3671	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.386 by root, Mon Oct 15 17:50:27 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.386 by root, Mon Oct 15 17:50:27 2007 UTC vs.
Revision 1.405 by root, Mon Dec 17 08:03:22 2007 UTC