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

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

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.385 by root, Fri Oct 12 19:13:26 2007 UTC vs. Revision 1.408 by root, Mon Jan 14 10:12:12 2008 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.385 by root, Fri Oct 12 19:13:26 2007 UTC vs.
Revision 1.408 by root, Mon Jan 14 10:12:12 2008 UTC