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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.380 by root, Mon Oct 8 13:58:07 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 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
…		…
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 \|\| {} });
…		…
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) = @_;
…		…
2896	=pod	3018	=pod
2897		3019
2898	The following functions and methods are available within a safe environment:	3020	The following functions and methods are available within a safe environment:
2899		3021
2900	cf::object	3022	cf::object
2901	contr pay_amount pay_player map x y force_find force_add	3023	contr pay_amount pay_player map x y force_find force_add destroy
2902	insert remove name archname title slaying race decrease_ob_nr	3024	insert remove name archname title slaying race decrease_ob_nr
2903		3025
2904	cf::object::player	3026	cf::object::player
2905	player	3027	player
2906		3028
…		…
2913	=cut	3035	=cut
2914		3036
2915	for (	3037	for (
2916	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	3038	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2917	insert remove inv name archname title slaying race	3039	insert remove inv name archname title slaying race
2918	decrease_ob_nr)],	3040	decrease_ob_nr destroy)],
2919	["cf::object::player" => qw(player)],	3041	["cf::object::player" => qw(player)],
2920	["cf::player" => qw(peaceful)],	3042	["cf::player" => qw(peaceful)],
2921	["cf::map" => qw(trigger)],	3043	["cf::map" => qw(trigger)],
2922	) {	3044	) {
2923	no strict 'refs';	3045	no strict 'refs';
…		…
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		3223
3097	if ($soundconf) {	3224	if (my $soundconf = delete $res->{"res/sound.conf"}) {
3098	$soundconf = $enc->decode (delete $soundconf->{data});	3225	$soundconf = $enc->decode (delete $soundconf->{data});
3099		3226
3100	for (0 .. SOUND_CAST_SPELL_0 - 1) {	3227	for (0 .. SOUND_CAST_SPELL_0 - 1) {
3101	my $sound = $soundconf->{compat}[$_]	3228	my $sound = $soundconf->{compat}[$_]
3102	or next;	3229	or next;
…		…
3199	# we must not ever block the main coroutine	3326	# we must not ever block the main coroutine
3200	local $Coro::idle = sub {	3327	local $Coro::idle = sub {
3201	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#
3202	(async {	3329	(async {
3203	$Coro::current->{desc} = "IDLE BUG HANDLER";	3330	$Coro::current->{desc} = "IDLE BUG HANDLER";
3204	Event::one_event;	3331	EV::loop EV::LOOP_ONESHOT;
3205	})->prio (Coro::PRIO_MAX);	3332	})->prio (Coro::PRIO_MAX);
3206	};	3333	};
3207		3334
3208	reload_config;	3335	reload_config;
3209	db_init;	3336	db_init;
3210	load_extensions;	3337	load_extensions;
3211		3338
3212	$TICK_WATCHER->start;	3339	$TICK_WATCHER->start;
		3340	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3213	Event::loop;	3341	EV::loop;
3214	}	3342	}
3215		3343
3216	#############################################################################	3344	#############################################################################
3217	# initialisation and cleanup	3345	# initialisation and cleanup
3218		3346
3219	# install some emergency cleanup handlers	3347	# install some emergency cleanup handlers
3220	BEGIN {	3348	BEGIN {
		3349	our %SIGWATCHER = ();
3221	for my $signal (qw(INT HUP TERM)) {	3350	for my $signal (qw(INT HUP TERM)) {
3222	Event->signal (	3351	$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";	3352	cf::cleanup "SIG$signal";
3229	},
3230	);	3353	};
3231	}	3354	}
3232	}	3355	}
3233		3356
3234	sub write_runtime {	3357	sub write_runtime {
3235	my $runtime = "$LOCALDIR/runtime";	3358	my $runtime = "$LOCALDIR/runtime";
…		…
3280	# and maps saved/destroyed asynchronously.	3403	# and maps saved/destroyed asynchronously.
3281	warn "begin emergency player save\n";	3404	warn "begin emergency player save\n";
3282	for my $login (keys %cf::PLAYER) {	3405	for my $login (keys %cf::PLAYER) {
3283	my $pl = $cf::PLAYER{$login} or next;	3406	my $pl = $cf::PLAYER{$login} or next;
3284	$pl->valid or next;	3407	$pl->valid or next;
		3408	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3285	$pl->save;	3409	$pl->save;
3286	}	3410	}
3287	warn "end emergency player save\n";	3411	warn "end emergency player save\n";
3288		3412
3289	warn "begin emergency map save\n";	3413	warn "begin emergency map save\n";
…		…
3328	warn "syncing database to disk";	3452	warn "syncing database to disk";
3329	BDB::db_env_txn_checkpoint $DB_ENV;	3453	BDB::db_env_txn_checkpoint $DB_ENV;
3330		3454
3331	# 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
3332		3456
3333	warn "cancelling all WF_AUTOCANCEL watchers";
3334	for (Event::all_watchers) {
3335	$_->cancel if $_->data & WF_AUTOCANCEL;
3336	}
3337
3338	warn "flushing outstanding aio requests";	3457	warn "flushing outstanding aio requests";
3339	for (;;) {	3458	for (;;) {
3340	BDB::flush;	3459	BDB::flush;
3341	IO::AIO::flush;	3460	IO::AIO::flush;
3342	Coro::cede;	3461	Coro::cede_notself;
3343	last unless IO::AIO::nreqs \|\| BDB::nreqs;	3462	last unless IO::AIO::nreqs \|\| BDB::nreqs;
3344	warn "iterate...";	3463	warn "iterate...";
3345	}	3464	}
3346		3465
3347	++$RELOAD;	3466	++$RELOAD;
…		…
3436		3555
3437	sub reload_perl() {	3556	sub reload_perl() {
3438	# doing reload synchronously and two reloads happen back-to-back,	3557	# doing reload synchronously and two reloads happen back-to-back,
3439	# coro crashes during coro_state_free->destroy here.	3558	# coro crashes during coro_state_free->destroy here.
3440		3559
3441	$RELOAD_WATCHER \|\|= Event->timer (	3560	$RELOAD_WATCHER \|\|= EV::timer 0, 0, sub {
3442	reentrant => 0,
3443	after => 0,
3444	data => WF_AUTOCANCEL,
3445	cb => sub {
3446	do_reload_perl;
3447	undef $RELOAD_WATCHER;	3561	undef $RELOAD_WATCHER;
3448	},	3562	do_reload_perl;
3449	);	3563	};
3450	}	3564	}
3451		3565
3452	register_command "reload" => sub {	3566	register_command "reload" => sub {
3453	my ($who, $arg) = @_;	3567	my ($who, $arg) = @_;
3454		3568
…		…
3484	my $signal = new Coro::Signal;	3598	my $signal = new Coro::Signal;
3485	push @WAIT_FOR_TICK_BEGIN, $signal;	3599	push @WAIT_FOR_TICK_BEGIN, $signal;
3486	$signal->wait;	3600	$signal->wait;
3487	}	3601	}
3488		3602
3489	$TICK_WATCHER = Event->timer (	3603	$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3490	reentrant => 0,
3491	parked => 1,
3492	prio => 0,
3493	at => $NEXT_TICK \|\| $TICK,
3494	data => WF_AUTOCANCEL,
3495	cb => sub {
3496	if ($Coro::current != $Coro::main) {	3604	if ($Coro::current != $Coro::main) {
3497	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"
3498	unless ++$bug_warning > 10;	3606	unless ++$bug_warning > 10;
3499	return;	3607	return;
3500	}	3608	}
3501		3609
3502	$NOW = $tick_start = Event::time;	3610	$NOW = $tick_start = EV::now;
3503		3611
3504	cf::server_tick; # one server iteration	3612	cf::server_tick; # one server iteration
3505		3613
3506	$RUNTIME += $TICK;	3614	$RUNTIME += $TICK;
3507	$NEXT_TICK += $TICK;	3615	$NEXT_TICK = $_[0]->at;
3508		3616
3509	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3617	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3510	$NEXT_RUNTIME_WRITE = $NOW + 10;	3618	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3511	Coro::async_pool {	3619	Coro::async_pool {
3512	$Coro::current->{desc} = "runtime saver";	3620	$Coro::current->{desc} = "runtime saver";
3513	write_runtime	3621	write_runtime
3514	or warn "ERROR: unable to write runtime file: $!";	3622	or warn "ERROR: unable to write runtime file: $!";
3515	};
3516	}	3623	};
		3624	}
3517		3625
3518	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3626	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3519	$sig->send;	3627	$sig->send;
3520	}	3628	}
3521	while (my $sig = shift @WAIT_FOR_TICK) {	3629	while (my $sig = shift @WAIT_FOR_TICK) {
3522	$sig->send;	3630	$sig->send;
3523	}	3631	}
3524		3632
3525	$NOW = Event::time;
3526
3527	# if we are delayed by four ticks or more, skip them all
3528	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3529
3530	$TICK_WATCHER->at ($NEXT_TICK);
3531	$TICK_WATCHER->start;
3532
3533	$LOAD = ($NOW - $tick_start) / $TICK;	3633	$LOAD = ($NOW - $tick_start) / $TICK;
3534	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	3634	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3535		3635
3536	_post_tick;	3636	_post_tick;
3537	},	3637	};
3538	);	3638	$TICK_WATCHER->priority (EV::MAXPRI);
3539		3639
3540	{	3640	{
		3641	# configure BDB
		3642
3541	BDB::min_parallel 8;	3643	BDB::min_parallel 8;
3542	BDB::max_poll_time $TICK * 0.1;	3644	BDB::max_poll_reqs $TICK * 0.1;
3543	$BDB_POLL_WATCHER = Event->io (	3645	$Coro::BDB::WATCHER->priority (1);
3544	reentrant => 0,
3545	fd => BDB::poll_fileno,
3546	poll => 'r',
3547	prio => 0,
3548	data => WF_AUTOCANCEL,
3549	cb => \&BDB::poll_cb,
3550	);
3551
3552	BDB::set_sync_prepare {
3553	my $status;
3554	my $current = $Coro::current;
3555	(
3556	sub {
3557	$status = $!;
3558	$current->ready; undef $current;
3559	},
3560	sub {
3561	Coro::schedule while defined $current;
3562	$! = $status;
3563	},
3564	)
3565	};
3566		3646
3567	unless ($DB_ENV) {	3647	unless ($DB_ENV) {
3568	$DB_ENV = BDB::db_env_create;	3648	$DB_ENV = BDB::db_env_create;
3569	$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
3570	\| BDB::LOG_AUTOREMOVE, 1);	3650	\| BDB::LOG_AUTOREMOVE, 1);
…		…
3585		3665
3586	cf::cleanup "db_env_open(db): $@" if $@;	3666	cf::cleanup "db_env_open(db): $@" if $@;
3587	};	3667	};
3588	}	3668	}
3589		3669
3590	$BDB_DEADLOCK_WATCHER = Event->timer (	3670	$BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3591	after => 3,
3592	interval => 1,
3593	hard => 1,
3594	prio => 0,
3595	data => WF_AUTOCANCEL,
3596	cb => sub {
3597	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 { };
3598	},
3599	);	3672	};
3600	$BDB_CHECKPOINT_WATCHER = Event->timer (	3673	$BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3601	after => 11,
3602	interval => 60,
3603	hard => 1,
3604	prio => 0,
3605	data => WF_AUTOCANCEL,
3606	cb => sub {
3607	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };	3674	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3608	},
3609	);	3675	};
3610	$BDB_TRICKLE_WATCHER = Event->timer (	3676	$BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3611	after => 5,
3612	interval => 10,
3613	hard => 1,
3614	prio => 0,
3615	data => WF_AUTOCANCEL,
3616	cb => sub {
3617	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };	3677	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3618	},
3619	);	3678	};
3620	}	3679	}
3621		3680
3622	{	3681	{
		3682	# configure IO::AIO
		3683
3623	IO::AIO::min_parallel 8;	3684	IO::AIO::min_parallel 8;
3624
3625	undef $Coro::AIO::WATCHER;
3626	IO::AIO::max_poll_time $TICK * 0.1;	3685	IO::AIO::max_poll_time $TICK * 0.1;
3627	$AIO_POLL_WATCHER = Event->io (	3686	$Coro::AIO::WATCHER->priority (1);
3628	reentrant => 0,
3629	data => WF_AUTOCANCEL,
3630	fd => IO::AIO::poll_fileno,
3631	poll => 'r',
3632	prio => 0,
3633	cb => \&IO::AIO::poll_cb,
3634	);
3635	}	3687	}
3636		3688
3637	my $_log_backtrace;	3689	my $_log_backtrace;
3638		3690
3639	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.380 by root, Mon Oct 8 13:58:07 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.380 by root, Mon Oct 8 13:58:07 2007 UTC vs.
Revision 1.405 by root, Mon Dec 17 08:03:22 2007 UTC