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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.387 by root, Mon Oct 15 23:49:10 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 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#
…		…
447		462
448	while ($busy) {	463	while ($busy) {
449	if (Coro::nready) {	464	if (Coro::nready) {
450	Coro::cede_notself;	465	Coro::cede_notself;
451	} else {	466	} else {
452	Event::one_event;	467	EV::loop EV::LOOP_ONESHOT;
453	}	468	}
454	}	469	}
455		470
456	$time = Event::time - $time;	471	$time = EV::time - $time;
457		472
458	LOG llevError \| logBacktrace, Carp::longmess "long sync job"	473	LOG llevError \| logBacktrace, Carp::longmess "long sync job"
459	if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;	474	if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
460		475
461	$tick_start += $time; # do not account sync jobs to server load	476	$tick_start += $time; # do not account sync jobs to server load
…		…
491	=item fork_call { }, $args	506	=item fork_call { }, $args
492		507
493	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
494	process, returning the results. Everything must be serialisable with	509	process, returning the results. Everything must be serialisable with
495	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
496	never block itself or use any form of Event handling.	511	never block itself or use any form of event handling.
497		512
498	=cut	513	=cut
499		514
500	sub fork_call(&@) {	515	sub fork_call(&@) {
501	my ($cb, @args) = @_;	516	my ($cb, @args) = @_;
…		…
662	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")
663	to it. All such attachable objects support the following methods.	678	to it. All such attachable objects support the following methods.
664		679
665	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>
666	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
667	Crossfire TRT).	682	Deliantra).
668		683
669	=over 4	684	=over 4
670		685
671	=item $attachable->attach ($attachment, key => $value...)	686	=item $attachable->attach ($attachment, key => $value...)
672		687
…		…
954	}	969	}
955		970
956	0	971	0
957	}	972	}
958		973
959	=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)	974	=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
960		975
961	=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)	976	=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
962		977
963	Generate an object-specific event with the given arguments.	978	Generate an object-specific event with the given arguments.
964		979
…		…
1042	cf::attachable->attach (	1057	cf::attachable->attach (
1043	prio => -1000000,	1058	prio => -1000000,
1044	on_instantiate => sub {	1059	on_instantiate => sub {
1045	my ($obj, $data) = @_;	1060	my ($obj, $data) = @_;
1046		1061
1047	$data = from_json $data;	1062	$data = decode_json $data;
1048		1063
1049	for (@$data) {	1064	for (@$data) {
1050	my ($name, $args) = @$_;	1065	my ($name, $args) = @$_;
1051		1066
1052	$obj->attach ($name, %{$args \|\| {} });	1067	$obj->attach ($name, %{$args \|\| {} });
…		…
1081	close $fh;	1096	close $fh;
1082		1097
1083	if (@$objs) {	1098	if (@$objs) {
1084	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) {
1085	chmod SAVE_MODE, $fh;	1100	chmod SAVE_MODE, $fh;
1086	my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs };	1101	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1087	aio_write $fh, 0, (length $data), $data, 0;	1102	aio_write $fh, 0, (length $data), $data, 0;
1088	aio_fsync $fh if $cf::USE_FSYNC;	1103	aio_fsync $fh if $cf::USE_FSYNC;
1089	close $fh;	1104	close $fh;
1090	aio_rename "$filename.pst~", "$filename.pst";	1105	aio_rename "$filename.pst~", "$filename.pst";
1091	}	1106	}
…		…
1122		1137
1123	unless (aio_stat "$filename.pst") {	1138	unless (aio_stat "$filename.pst") {
1124	(aio_load "$filename.pst", $av) >= 0	1139	(aio_load "$filename.pst", $av) >= 0
1125	or return;	1140	or return;
1126		1141
1127	my $st = eval { Coro::Storable::thaw $av }	1142	my $st = eval { Coro::Storable::thaw $av };
1128	\|\| eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1129	$av = $st->{objs};	1143	$av = $st->{objs};
1130	}	1144	}
1131		1145
1132	utf8::decode (my $decname = $filename);	1146	utf8::decode (my $decname = $filename);
1133	warn sprintf "loading %s (%d,%d)\n",	1147	warn sprintf "loading %s (%d,%d)\n",
…		…
1549		1563
1550	Expand crossfire pod fragments into protocol xml.	1564	Expand crossfire pod fragments into protocol xml.
1551		1565
1552	=cut	1566	=cut
1553		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
1554	sub expand_cfpod {	1579	sub expand_cfpod {
1555	((my $self), (local $_)) = @_;	1580	my ($self, $pod) = @_;
1556		1581
1557	# escape & and <	1582	my $xml;
1558	s/&/&/g;
1559	s/(?<![BIUGHT])</</g;
1560		1583
1561	# this is buggy, it needs to properly take care of nested <'s	1584	while () {
		1585	if ($pod =~ /\G( (?: [^BCGHITU]+ \| .(?!<) )+ )/xgcs) {
		1586	$group = $1;
1562		1587
1563	1 while	1588	$group =~ s/&/&/g;
1564	# replace B<>, I<>, U<> etc.	1589	$group =~ s/</</g;
1565	s/B<([^\>]*)>/<b>$1<\/b>/	1590
1566	\|\| s/I<([^\>]*)>/<i>$1<\/i>/	1591	$xml .= $group;
1567	\|\| s/U<([^\>]*)>/<u>$1<\/u>/	1592	} elsif ($pod =~ m%\G
1568	\|\| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/	1593	([BCGHITU])
1569	# replace G<male\|female> tags	1594	<
1570	\|\| s{G<([^>\|])\\|([^>])>}{	1595	(?:
1571	$self->gender ? $2 : $1	1596	([^<>]*) (?{ $group = $^N })
1572	}ge	1597	\| < $interior >
1573	# replace H<hint text>	1598	)
1574	\|\| s{H<([^\>]*)>}	1599	>
		1600	%gcsx
1575	{	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") {
1576	("<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>",
1577	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",	1620	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1578	"")	1621	"")
1579	[$self->{hintmode}]	1622	[$self->{hintmode}];
		1623	} else {
		1624	$xml .= "error processing '$code($data)' directive";
1580	}ge;	1625	}
		1626	} else {
		1627	if ($pod =~ /\G(.+)/) {
		1628	warn "parse error while expanding $pod (at $1)";
		1629	}
		1630	last;
		1631	}
		1632	}
1581		1633
		1634	for ($xml) {
1582	# create single paragraphs (very hackish)	1635	# create single paragraphs (very hackish)
1583	s/(?<=\S)\n(?=\w)/ /g;	1636	s/(?<=\S)\n(?=\w)/ /g;
1584		1637
1585	# compress some whitespace	1638	# compress some whitespace
1586	s/\s+\n/\n/g; # ws line-ends	1639	s/\s+\n/\n/g; # ws line-ends
1587	s/\n\n+/\n/g; # double lines	1640	s/\n\n+/\n/g; # double lines
1588	s/^\n+//; # beginning lines	1641	s/^\n+//; # beginning lines
1589	s/\n+$//; # ending lines	1642	s/\n+$//; # ending lines
		1643	}
1590		1644
1591	$_	1645	$xml
1592	}	1646	}
		1647
		1648	no re 'eval';
1593		1649
1594	sub hintmode {	1650	sub hintmode {
1595	$_[0]{hintmode} = $_[1] if @_ > 1;	1651	$_[0]{hintmode} = $_[1] if @_ > 1;
1596	$_[0]{hintmode}	1652	$_[0]{hintmode}
1597	}	1653	}
…		…
2584	$rmp->{origin_y} = $exit->y;	2640	$rmp->{origin_y} = $exit->y;
2585	}	2641	}
2586		2642
2587	$rmp->{random_seed} \|\|= $exit->random_seed;	2643	$rmp->{random_seed} \|\|= $exit->random_seed;
2588		2644
2589	my $data = cf::to_json $rmp;	2645	my $data = cf::encode_json $rmp;
2590	my $md5 = Digest::MD5::md5_hex $data;	2646	my $md5 = Digest::MD5::md5_hex $data;
2591	my $meta = "$RANDOMDIR/$md5.meta";	2647	my $meta = "$RANDOMDIR/$md5.meta";
2592		2648
2593	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {	2649	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {
2594	aio_write $fh, 0, (length $data), $data, 0;	2650	aio_write $fh, 0, (length $data), $data, 0;
…		…
2667	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
2668	the message unless the client supports the msg packet.	2724	the message unless the client supports the msg packet.
2669		2725
2670	=cut	2726	=cut
2671		2727
		2728	# non-persistent channels (usually the info channel)
2672	our %CHANNEL = (	2729	our %CHANNEL = (
2673	"c/identify" => {	2730	"c/identify" => {
2674	id => "infobox",	2731	id => "infobox",
2675	title => "Identify",	2732	title => "Identify",
2676	reply => undef,	2733	reply => undef,
…		…
2680	id => "infobox",	2737	id => "infobox",
2681	title => "Examine",	2738	title => "Examine",
2682	reply => undef,	2739	reply => undef,
2683	tooltip => "Signs and other items you examined",	2740	tooltip => "Signs and other items you examined",
2684	},	2741	},
		2742	"c/book" => {
		2743	id => "infobox",
		2744	title => "Book",
		2745	reply => undef,
		2746	tooltip => "The contents of a note or book",
		2747	},
2685	"c/lookat" => {	2748	"c/lookat" => {
2686	id => "infobox",	2749	id => "infobox",
2687	title => "Look",	2750	title => "Look",
2688	reply => undef,	2751	reply => undef,
2689	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",
2690	},	2777	},
2691	);	2778	);
2692		2779
2693	sub cf::client::send_msg {	2780	sub cf::client::send_msg {
2694	my ($self, $channel, $msg, $color, @extra) = @_;	2781	my ($self, $channel, $msg, $color, @extra) = @_;
…		…
3063	{	3150	{
3064	my $faces = $facedata->{faceinfo};	3151	my $faces = $facedata->{faceinfo};
3065		3152
3066	while (my ($face, $info) = each %$faces) {	3153	while (my ($face, $info) = each %$faces) {
3067	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	3154	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
		3155
3068	cf::face::set_visibility $idx, $info->{visibility};	3156	cf::face::set_visibility $idx, $info->{visibility};
3069	cf::face::set_magicmap $idx, $info->{magicmap};	3157	cf::face::set_magicmap $idx, $info->{magicmap};
3070	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};
3071	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};
3072		3160
3073	cf::cede_to_tick;	3161	cf::cede_to_tick;
3074	}	3162	}
3075		3163
3076	while (my ($face, $info) = each %$faces) {	3164	while (my ($face, $info) = each %$faces) {
3077	next unless $info->{smooth};	3165	next unless $info->{smooth};
		3166
3078	my $idx = cf::face::find $face	3167	my $idx = cf::face::find $face
3079	or next;	3168	or next;
		3169
3080	if (my $smooth = cf::face::find $info->{smooth}) {	3170	if (my $smooth = cf::face::find $info->{smooth}) {
3081	cf::face::set_smooth $idx, $smooth;	3171	cf::face::set_smooth $idx, $smooth;
3082	cf::face::set_smoothlevel $idx, $info->{smoothlevel};	3172	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3083	} else {	3173	} else {
3084	warn "smooth face '$info->{smooth}' not found for face '$face'";	3174	warn "smooth face '$info->{smooth}' not found for face '$face'";
…		…
3102	{	3192	{
3103	# TODO: for gcfclient pleasure, we should give resources	3193	# TODO: for gcfclient pleasure, we should give resources
3104	# that gcfclient doesn't grok a >10000 face index.	3194	# that gcfclient doesn't grok a >10000 face index.
3105	my $res = $facedata->{resource};	3195	my $res = $facedata->{resource};
3106		3196
3107	my $soundconf = delete $res->{"res/sound.conf"};
3108
3109	while (my ($name, $info) = each %$res) {	3197	while (my ($name, $info) = each %$res) {
		3198	if (defined $info->{type}) {
3110	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	3199	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
3111	my $data;	3200	my $data;
3112		3201
3113	if ($info->{type} & 1) {	3202	if ($info->{type} & 1) {
3114	# prepend meta info	3203	# prepend meta info
3115		3204
3116	my $meta = $enc->encode ({	3205	my $meta = $enc->encode ({
3117	name => $name,	3206	name => $name,
3118	%{ $info->{meta} \|\| {} },	3207	%{ $info->{meta} \|\| {} },
3119	});	3208	});
3120		3209
3121	$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};
3122	} else {	3217	} else {
3123	$data = $info->{data};	3218	$RESOURCE{$name} = $info;
3124	}	3219	}
3125		3220
3126	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3127	cf::face::set_type $idx, $info->{type};
3128
3129	cf::cede_to_tick;	3221	cf::cede_to_tick;
3130	}	3222	}
3131
3132	if ($soundconf) {
3133	$soundconf = $enc->decode (delete $soundconf->{data});
3134
3135	for (0 .. SOUND_CAST_SPELL_0 - 1) {
3136	my $sound = $soundconf->{compat}[$_]
3137	or next;
3138
3139	my $face = cf::face::find "sound/$sound->[1]";
3140	cf::sound::set $sound->[0] => $face;
3141	cf::sound::old_sound_index $_, $face; # gcfclient-compat
3142	}
3143
3144	while (my ($k, $v) = each %{$soundconf->{event}}) {
3145	my $face = cf::face::find "sound/$v";
3146	cf::sound::set $k => $face;
3147	}
3148	}
3149	}	3223	}
		3224
		3225	cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3150		3226
3151	1	3227	1
3152	}	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	});
3153		3249
3154	register_exticmd fx_want => sub {	3250	register_exticmd fx_want => sub {
3155	my ($ns, $want) = @_;	3251	my ($ns, $want) = @_;
3156		3252
3157	while (my ($k, $v) = each %$want) {	3253	while (my ($k, $v) = each %$want) {
…		…
3234	# we must not ever block the main coroutine	3330	# we must not ever block the main coroutine
3235	local $Coro::idle = sub {	3331	local $Coro::idle = sub {
3236	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#
3237	(async {	3333	(async {
3238	$Coro::current->{desc} = "IDLE BUG HANDLER";	3334	$Coro::current->{desc} = "IDLE BUG HANDLER";
3239	Event::one_event;	3335	EV::loop EV::LOOP_ONESHOT;
3240	})->prio (Coro::PRIO_MAX);	3336	})->prio (Coro::PRIO_MAX);
3241	};	3337	};
3242		3338
3243	reload_config;	3339	reload_config;
3244	db_init;	3340	db_init;
3245	load_extensions;	3341	load_extensions;
3246		3342
3247	$TICK_WATCHER->start;	3343	$TICK_WATCHER->start;
		3344	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3248	Event::loop;	3345	EV::loop;
3249	}	3346	}
3250		3347
3251	#############################################################################	3348	#############################################################################
3252	# initialisation and cleanup	3349	# initialisation and cleanup
3253		3350
3254	# install some emergency cleanup handlers	3351	# install some emergency cleanup handlers
3255	BEGIN {	3352	BEGIN {
		3353	our %SIGWATCHER = ();
3256	for my $signal (qw(INT HUP TERM)) {	3354	for my $signal (qw(INT HUP TERM)) {
3257	Event->signal (	3355	$SIGWATCHER{$signal} = EV::signal $signal, sub {
3258	reentrant => 0,
3259	data => WF_AUTOCANCEL,
3260	signal => $signal,
3261	prio => 0,
3262	cb => sub {
3263	cf::cleanup "SIG$signal";	3356	cf::cleanup "SIG$signal";
3264	},
3265	);	3357	};
3266	}	3358	}
3267	}	3359	}
3268		3360
3269	sub write_runtime {	3361	sub write_runtime {
3270	my $runtime = "$LOCALDIR/runtime";	3362	my $runtime = "$LOCALDIR/runtime";
…		…
3364	warn "syncing database to disk";	3456	warn "syncing database to disk";
3365	BDB::db_env_txn_checkpoint $DB_ENV;	3457	BDB::db_env_txn_checkpoint $DB_ENV;
3366		3458
3367	# 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
3368		3460
3369	warn "cancelling all WF_AUTOCANCEL watchers";
3370	for (Event::all_watchers) {
3371	$_->cancel if $_->data & WF_AUTOCANCEL;
3372	}
3373
3374	warn "flushing outstanding aio requests";	3461	warn "flushing outstanding aio requests";
3375	for (;;) {	3462	for (;;) {
3376	BDB::flush;	3463	BDB::flush;
3377	IO::AIO::flush;	3464	IO::AIO::flush;
3378	Coro::cede_notself;	3465	Coro::cede_notself;
…		…
3472		3559
3473	sub reload_perl() {	3560	sub reload_perl() {
3474	# doing reload synchronously and two reloads happen back-to-back,	3561	# doing reload synchronously and two reloads happen back-to-back,
3475	# coro crashes during coro_state_free->destroy here.	3562	# coro crashes during coro_state_free->destroy here.
3476		3563
3477	$RELOAD_WATCHER \|\|= Event->timer (	3564	$RELOAD_WATCHER \|\|= EV::timer 0, 0, sub {
3478	reentrant => 0,
3479	after => 0,
3480	data => WF_AUTOCANCEL,
3481	cb => sub {
3482	do_reload_perl;
3483	undef $RELOAD_WATCHER;	3565	undef $RELOAD_WATCHER;
3484	},	3566	do_reload_perl;
3485	);	3567	};
3486	}	3568	}
3487		3569
3488	register_command "reload" => sub {	3570	register_command "reload" => sub {
3489	my ($who, $arg) = @_;	3571	my ($who, $arg) = @_;
3490		3572
…		…
3520	my $signal = new Coro::Signal;	3602	my $signal = new Coro::Signal;
3521	push @WAIT_FOR_TICK_BEGIN, $signal;	3603	push @WAIT_FOR_TICK_BEGIN, $signal;
3522	$signal->wait;	3604	$signal->wait;
3523	}	3605	}
3524		3606
3525	$TICK_WATCHER = Event->timer (	3607	$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3526	reentrant => 0,
3527	parked => 1,
3528	prio => 0,
3529	at => $NEXT_TICK \|\| $TICK,
3530	data => WF_AUTOCANCEL,
3531	cb => sub {
3532	if ($Coro::current != $Coro::main) {	3608	if ($Coro::current != $Coro::main) {
3533	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"
3534	unless ++$bug_warning > 10;	3610	unless ++$bug_warning > 10;
3535	return;	3611	return;
3536	}	3612	}
3537		3613
3538	$NOW = $tick_start = Event::time;	3614	$NOW = $tick_start = EV::now;
3539		3615
3540	cf::server_tick; # one server iteration	3616	cf::server_tick; # one server iteration
3541		3617
3542	$RUNTIME += $TICK;	3618	$RUNTIME += $TICK;
3543	$NEXT_TICK += $TICK;	3619	$NEXT_TICK = $_[0]->at;
3544		3620
3545	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3621	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3546	$NEXT_RUNTIME_WRITE = $NOW + 10;	3622	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3547	Coro::async_pool {	3623	Coro::async_pool {
3548	$Coro::current->{desc} = "runtime saver";	3624	$Coro::current->{desc} = "runtime saver";
3549	write_runtime	3625	write_runtime
3550	or warn "ERROR: unable to write runtime file: $!";	3626	or warn "ERROR: unable to write runtime file: $!";
3551	};
3552	}	3627	};
		3628	}
3553		3629
3554	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3630	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3555	$sig->send;	3631	$sig->send;
3556	}	3632	}
3557	while (my $sig = shift @WAIT_FOR_TICK) {	3633	while (my $sig = shift @WAIT_FOR_TICK) {
3558	$sig->send;	3634	$sig->send;
3559	}	3635	}
3560		3636
3561	$NOW = Event::time;
3562
3563	# if we are delayed by four ticks or more, skip them all
3564	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3565
3566	$TICK_WATCHER->at ($NEXT_TICK);
3567	$TICK_WATCHER->start;
3568
3569	$LOAD = ($NOW - $tick_start) / $TICK;	3637	$LOAD = ($NOW - $tick_start) / $TICK;
3570	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	3638	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3571		3639
3572	_post_tick;	3640	_post_tick;
3573	},	3641	};
3574	);	3642	$TICK_WATCHER->priority (EV::MAXPRI);
3575		3643
3576	{	3644	{
		3645	# configure BDB
		3646
3577	BDB::min_parallel 8;	3647	BDB::min_parallel 8;
3578	BDB::max_poll_time $TICK * 0.1;	3648	BDB::max_poll_reqs $TICK * 0.1;
3579	$BDB_POLL_WATCHER = Event->io (	3649	$Coro::BDB::WATCHER->priority (1);
3580	reentrant => 0,
3581	fd => BDB::poll_fileno,
3582	poll => 'r',
3583	prio => 0,
3584	data => WF_AUTOCANCEL,
3585	cb => \&BDB::poll_cb,
3586	);
3587
3588	BDB::set_sync_prepare {
3589	my $status;
3590	my $current = $Coro::current;
3591	(
3592	sub {
3593	$status = $!;
3594	$current->ready; undef $current;
3595	},
3596	sub {
3597	Coro::schedule while defined $current;
3598	$! = $status;
3599	},
3600	)
3601	};
3602		3650
3603	unless ($DB_ENV) {	3651	unless ($DB_ENV) {
3604	$DB_ENV = BDB::db_env_create;	3652	$DB_ENV = BDB::db_env_create;
3605	$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
3606	\| BDB::LOG_AUTOREMOVE, 1);	3654	\| BDB::LOG_AUTOREMOVE, 1);
…		…
3621		3669
3622	cf::cleanup "db_env_open(db): $@" if $@;	3670	cf::cleanup "db_env_open(db): $@" if $@;
3623	};	3671	};
3624	}	3672	}
3625		3673
3626	$BDB_DEADLOCK_WATCHER = Event->timer (	3674	$BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3627	after => 3,
3628	interval => 1,
3629	hard => 1,
3630	prio => 0,
3631	data => WF_AUTOCANCEL,
3632	cb => sub {
3633	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 { };
3634	},
3635	);	3676	};
3636	$BDB_CHECKPOINT_WATCHER = Event->timer (	3677	$BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3637	after => 11,
3638	interval => 60,
3639	hard => 1,
3640	prio => 0,
3641	data => WF_AUTOCANCEL,
3642	cb => sub {
3643	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };	3678	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3644	},
3645	);	3679	};
3646	$BDB_TRICKLE_WATCHER = Event->timer (	3680	$BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3647	after => 5,
3648	interval => 10,
3649	hard => 1,
3650	prio => 0,
3651	data => WF_AUTOCANCEL,
3652	cb => sub {
3653	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };	3681	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3654	},
3655	);	3682	};
3656	}	3683	}
3657		3684
3658	{	3685	{
		3686	# configure IO::AIO
		3687
3659	IO::AIO::min_parallel 8;	3688	IO::AIO::min_parallel 8;
3660
3661	undef $Coro::AIO::WATCHER;
3662	IO::AIO::max_poll_time $TICK * 0.1;	3689	IO::AIO::max_poll_time $TICK * 0.1;
3663	$AIO_POLL_WATCHER = Event->io (	3690	$Coro::AIO::WATCHER->priority (1);
3664	reentrant => 0,
3665	data => WF_AUTOCANCEL,
3666	fd => IO::AIO::poll_fileno,
3667	poll => 'r',
3668	prio => 0,
3669	cb => \&IO::AIO::poll_cb,
3670	);
3671	}	3691	}
3672		3692
3673	my $_log_backtrace;	3693	my $_log_backtrace;
3674		3694
3675	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.387 by root, Mon Oct 15 23:49:10 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.387 by root, Mon Oct 15 23:49:10 2007 UTC vs.
Revision 1.406 by root, Mon Dec 17 08:27:44 2007 UTC