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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.386 by root, Mon Oct 15 17:50:27 2007 UTC vs.
Revision 1.423 by root, Sun Apr 20 00:44:13 2008 UTC

…		…
		1	#
		2	# This file is part of Deliantra, the Roguelike Realtime MMORPG.
		3	#
		4	# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
		5	#
		6	# Deliantra is free software: you can redistribute it and/or modify
		7	# it under the terms of the GNU General Public License as published by
		8	# the Free Software Foundation, either version 3 of the License, or
		9	# (at your option) any later version.
		10	#
		11	# This program is distributed in the hope that it will be useful,
		12	# but WITHOUT ANY WARRANTY; without even the implied warranty of
		13	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
		14	# GNU General Public License for more details.
		15	#
		16	# You should have received a copy of the GNU General Public License
		17	# along with this program. If not, see <http://www.gnu.org/licenses/>.
		18	#
		19	# The authors can be reached via e-mail to <support@deliantra.net>
		20	#
		21
1	package cf;	22	package cf;
2		23
3	use utf8;	24	use utf8;
4	use strict;	25	use strict;
5		26
6	use Symbol;	27	use Symbol;
7	use List::Util;	28	use List::Util;
8	use Socket;	29	use Socket;
9	use Event;	30	use EV 3.2;
10	use Opcode;	31	use Opcode;
11	use Safe;	32	use Safe;
12	use Safe::Hole;	33	use Safe::Hole;
13	use Storable ();	34	use Storable ();
14		35
15	use Coro 4.1 ();	36	use Coro 4.50 ();
16	use Coro::State;	37	use Coro::State;
17	use Coro::Handle;	38	use Coro::Handle;
18	use Coro::Event;	39	use Coro::EV;
19	use Coro::Timer;	40	use Coro::Timer;
20	use Coro::Signal;	41	use Coro::Signal;
21	use Coro::Semaphore;	42	use Coro::Semaphore;
22	use Coro::AIO;	43	use Coro::AIO;
		44	use Coro::BDB;
23	use Coro::Storable;	45	use Coro::Storable;
24	use Coro::Util ();	46	use Coro::Util ();
25		47
26	use JSON::XS ();	48	use JSON::XS 2.01 ();
27	use BDB ();	49	use BDB ();
28	use Data::Dumper;	50	use Data::Dumper;
29	use Digest::MD5;	51	use Digest::MD5;
30	use Fcntl;	52	use Fcntl;
31	use YAML::Syck ();	53	use YAML ();
32	use IO::AIO 2.51 ();	54	use IO::AIO 2.51 ();
33	use Time::HiRes;	55	use Time::HiRes;
34	use Compress::LZF;	56	use Compress::LZF;
35	use Digest::MD5 ();	57	use Digest::MD5 ();
36		58
37	# configure various modules to our taste	59	# configure various modules to our taste
38	#	60	#
39	$Storable::canonical = 1; # reduce rsync transfers	61	$Storable::canonical = 1; # reduce rsync transfers
40	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator	62	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	63	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		64
48	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority	65	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49		66
50	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	67	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51		68
70	our $TMPDIR = "$LOCALDIR/" . tmpdir;	87	our $TMPDIR = "$LOCALDIR/" . tmpdir;
71	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;	88	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72	our $PLAYERDIR = "$LOCALDIR/" . playerdir;	89	our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73	our $RANDOMDIR = "$LOCALDIR/random";	90	our $RANDOMDIR = "$LOCALDIR/random";
74	our $BDBDIR = "$LOCALDIR/db";	91	our $BDBDIR = "$LOCALDIR/db";
		92	our %RESOURCE;
75		93
76	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	94	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77	our $TICK_WATCHER;
78	our $AIO_POLL_WATCHER;	95	our $AIO_POLL_WATCHER;
79	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	96	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80	our $NEXT_TICK;	97	our $NEXT_TICK;
81	our $NOW;
82	our $USE_FSYNC = 1; # use fsync to write maps - default off	98	our $USE_FSYNC = 1; # use fsync to write maps - default off
83		99
84	our $BDB_POLL_WATCHER;	100	our $BDB_POLL_WATCHER;
85	our $BDB_DEADLOCK_WATCHER;	101	our $BDB_DEADLOCK_WATCHER;
86	our $BDB_CHECKPOINT_WATCHER;	102	our $BDB_CHECKPOINT_WATCHER;
…		…
89		105
90	our %CFG;	106	our %CFG;
91		107
92	our $UPTIME; $UPTIME \|\|= time;	108	our $UPTIME; $UPTIME \|\|= time;
93	our $RUNTIME;	109	our $RUNTIME;
		110	our $NOW;
94		111
95	our (%PLAYER, %PLAYER_LOADING); # all users	112	our (%PLAYER, %PLAYER_LOADING); # all users
96	our (%MAP, %MAP_LOADING ); # all maps	113	our (%MAP, %MAP_LOADING ); # all maps
97	our $LINK_MAP; # the special {link} map, which is always available	114	our $LINK_MAP; # the special {link} map, which is always available
98		115
99	# used to convert map paths into valid unix filenames by replacing / by ∕	116	# used to convert map paths into valid unix filenames by replacing / by ∕
100	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons	117	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
101		118
102	our $LOAD; # a number between 0 (idle) and 1 (too many objects)	119	our $LOAD; # a number between 0 (idle) and 1 (too many objects)
103	our $LOADAVG; # same thing, but with alpha-smoothing	120	our $LOADAVG; # same thing, but with alpha-smoothing
		121	our $JITTER; # average jitter
104	our $tick_start; # for load detecting purposes	122	our $TICK_START; # for load detecting purposes
105		123
106	binmode STDOUT;	124	binmode STDOUT;
107	binmode STDERR;	125	binmode STDERR;
108		126
109	# read virtual server time, if available	127	# read virtual server time, if available
…		…
162		180
163	The raw value load value from the last tick.	181	The raw value load value from the last tick.
164		182
165	=item %cf::CFG	183	=item %cf::CFG
166		184
167	Configuration for the server, loaded from C</etc/crossfire/config>, or	185	Configuration for the server, loaded from C</etc/deliantra-server/config>, or
168	from wherever your confdir points to.	186	from wherever your confdir points to.
169		187
170	=item cf::wait_for_tick, cf::wait_for_tick_begin	188	=item cf::wait_for_tick, cf::wait_for_tick_begin
171		189
172	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	190	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;	211	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
194		212
195	LOG llevError, $msg;	213	LOG llevError, $msg;
196	};	214	};
197	}	215	}
		216
		217	$Coro::State::DIEHOOK = sub {
		218	return unless $^S eq 0; # "eq", not "=="
		219
		220	if ($Coro::current == $Coro::main) {#d#
		221	warn "DIEHOOK called in main context, Coro bug?\n";#d#
		222	return;#d#
		223	}#d#
		224
		225	# kill coroutine otherwise
		226	warn Carp::longmess $_[0];
		227	Coro::terminate
		228	};
		229
		230	$SIG{__DIE__} = sub { }; #d#?
198		231
199	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	232	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
200	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';	233	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
201	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';	234	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
202	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';	235	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
…		…
215	)) {	248	)) {
216	no strict 'refs';	249	no strict 'refs';
217	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	250	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
218	}	251	}
219		252
220	$Event::DIED = sub {	253	$EV::DIED = sub {
221	warn "error in event callback: @_";	254	warn "error in event callback: @_";
222	};	255	};
223		256
224	#############################################################################	257	#############################################################################
225		258
…		…
248	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;	281	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
249	$d	282	$d
250	} \|\| "[unable to dump $_[0]: '$@']";	283	} \|\| "[unable to dump $_[0]: '$@']";
251	}	284	}
252		285
253	=item $ref = cf::from_json $json	286	=item $ref = cf::decode_json $json
254		287
255	Converts a JSON string into the corresponding perl data structure.	288	Converts a JSON string into the corresponding perl data structure.
256		289
257	=item $json = cf::to_json $ref	290	=item $json = cf::encode_json $ref
258		291
259	Converts a perl data structure into its JSON representation.	292	Converts a perl data structure into its JSON representation.
260		293
261	=cut	294	=cut
262		295
263	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max	296	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264		297
265	sub to_json ($) { $json_coder->encode ($_[0]) }	298	sub encode_json($) { $json_coder->encode ($_[0]) }
266	sub from_json ($) { $json_coder->decode ($_[0]) }	299	sub decode_json($) { $json_coder->decode ($_[0]) }
267		300
268	=item cf::lock_wait $string	301	=item cf::lock_wait $string
269		302
270	Wait until the given lock is available. See cf::lock_acquire.	303	Wait until the given lock is available. See cf::lock_acquire.
271		304
…		…
327		360
328	! ! $LOCK{$key}	361	! ! $LOCK{$key}
329	}	362	}
330		363
331	sub freeze_mainloop {	364	sub freeze_mainloop {
332	return unless $TICK_WATCHER->is_active;	365	tick_inhibit_inc;
333		366
334	my $guard = Coro::guard {	367	Coro::guard \&tick_inhibit_dec;
335	$TICK_WATCHER->start;	368	}
336	};	369
337	$TICK_WATCHER->stop;	370	=item cf::periodic $interval, $cb
338	$guard	371
		372	Like EV::periodic, but randomly selects a starting point so that the actions
		373	get spread over timer.
		374
		375	=cut
		376
		377	sub periodic($$) {
		378	my ($interval, $cb) = @_;
		379
		380	my $start = rand List::Util::min 180, $interval;
		381
		382	EV::periodic $start, $interval, 0, $cb
339	}	383	}
340		384
341	=item cf::get_slot $time[, $priority[, $name]]	385	=item cf::get_slot $time[, $priority[, $name]]
342		386
343	Allocate $time seconds of blocking CPU time at priority C<$priority>:	387	Allocate $time seconds of blocking CPU time at priority C<$priority>:
…		…
383	}	427	}
384	}	428	}
385	};	429	};
386		430
387	sub get_slot($;$$) {	431	sub get_slot($;$$) {
		432	return if tick_inhibit \|\| $Coro::current == $Coro::main;
		433
388	my ($time, $pri, $name) = @_;	434	my ($time, $pri, $name) = @_;
389		435
390	$time = $TICK * .6 if $time > $TICK * .6;	436	$time = $TICK * .6 if $time > $TICK * .6;
391	my $sig = new Coro::Signal;	437	my $sig = new Coro::Signal;
392		438
…		…
406		452
407	BEGIN { *async = \&Coro::async_pool }	453	BEGIN { *async = \&Coro::async_pool }
408		454
409	=item cf::sync_job { BLOCK }	455	=item cf::sync_job { BLOCK }
410		456
411	The design of Crossfire TRT requires that the main coroutine ($Coro::main)	457	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	458	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	459	partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
414	acceptable.	460	acceptable.
415		461
416	If it must be done, put the blocking parts into C<sync_job>. This will run	462	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	463	the given BLOCK in another coroutine while waiting for the result. The
…		…
422		468
423	sub sync_job(&) {	469	sub sync_job(&) {
424	my ($job) = @_;	470	my ($job) = @_;
425		471
426	if ($Coro::current == $Coro::main) {	472	if ($Coro::current == $Coro::main) {
427	my $time = Event::time;	473	my $time = EV::time;
428		474
429	# this is the main coro, too bad, we have to block	475	# this is the main coro, too bad, we have to block
430	# till the operation succeeds, freezing the server :/	476	# till the operation succeeds, freezing the server :/
431		477
432	LOG llevError, Carp::longmess "sync job";#d#	478	LOG llevError, Carp::longmess "sync job";#d#
433		479
434	# TODO: use suspend/resume instead
435	# (but this is cancel-safe)
436	my $freeze_guard = freeze_mainloop;	480	my $freeze_guard = freeze_mainloop;
437		481
438	my $busy = 1;	482	my $busy = 1;
439	my @res;	483	my @res;
440		484
…		…
444	warn $@ if $@;	488	warn $@ if $@;
445	undef $busy;	489	undef $busy;
446	})->prio (Coro::PRIO_MAX);	490	})->prio (Coro::PRIO_MAX);
447		491
448	while ($busy) {	492	while ($busy) {
449	Coro::cede or Event::one_event;	493	if (Coro::nready) {
		494	Coro::cede_notself;
		495	} else {
		496	EV::loop EV::LOOP_ONESHOT;
450	}	497	}
		498	}
451		499
452	$time = Event::time - $time;	500	my $time = EV::time - $time;
453		501
454	LOG llevError \| logBacktrace, Carp::longmess "long sync job"
455	if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
456
457	$tick_start += $time; # do not account sync jobs to server load	502	$TICK_START += $time; # do not account sync jobs to server load
458		503
459	wantarray ? @res : $res[0]	504	wantarray ? @res : $res[0]
460	} else {	505	} else {
461	# we are in another coroutine, how wonderful, everything just works	506	# we are in another coroutine, how wonderful, everything just works
462		507
…		…
487	=item fork_call { }, $args	532	=item fork_call { }, $args
488		533
489	Executes the given code block with the given arguments in a seperate	534	Executes the given code block with the given arguments in a seperate
490	process, returning the results. Everything must be serialisable with	535	process, returning the results. Everything must be serialisable with
491	Coro::Storable. May, of course, block. Note that the executed sub may	536	Coro::Storable. May, of course, block. Note that the executed sub may
492	never block itself or use any form of Event handling.	537	never block itself or use any form of event handling.
493		538
494	=cut	539	=cut
495		540
496	sub fork_call(&@) {	541	sub fork_call(&@) {
497	my ($cb, @args) = @_;	542	my ($cb, @args) = @_;
…		…
504	reset_signals;	549	reset_signals;
505	&$cb	550	&$cb
506	}, @args;	551	}, @args;
507		552
508	wantarray ? @res : $res[-1]	553	wantarray ? @res : $res[-1]
		554	}
		555
		556	=item $coin = coin_from_name $name
		557
		558	=cut
		559
		560	our %coin_alias = (
		561	"silver" => "silvercoin",
		562	"silvercoin" => "silvercoin",
		563	"silvercoins" => "silvercoin",
		564	"gold" => "goldcoin",
		565	"goldcoin" => "goldcoin",
		566	"goldcoins" => "goldcoin",
		567	"platinum" => "platinacoin",
		568	"platinumcoin" => "platinacoin",
		569	"platinumcoins" => "platinacoin",
		570	"platina" => "platinacoin",
		571	"platinacoin" => "platinacoin",
		572	"platinacoins" => "platinacoin",
		573	"royalty" => "royalty",
		574	"royalties" => "royalty",
		575	);
		576
		577	sub coin_from_name($) {
		578	$coin_alias{$_[0]}
		579	? cf::arch::find $coin_alias{$_[0]}
		580	: undef
509	}	581	}
510		582
511	=item $value = cf::db_get $family => $key	583	=item $value = cf::db_get $family => $key
512		584
513	Returns a single value from the environment database.	585	Returns a single value from the environment database.
…		…
658	attach callbacks/event handlers (a collection of which is called an "attachment")	730	attach callbacks/event handlers (a collection of which is called an "attachment")
659	to it. All such attachable objects support the following methods.	731	to it. All such attachable objects support the following methods.
660		732
661	In the following description, CLASS can be any of C<global>, C<object>	733	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	734	C<player>, C<client> or C<map> (i.e. the attachable objects in
663	Crossfire TRT).	735	Deliantra).
664		736
665	=over 4	737	=over 4
666		738
667	=item $attachable->attach ($attachment, key => $value...)	739	=item $attachable->attach ($attachment, key => $value...)
668		740
…		…
950	}	1022	}
951		1023
952	0	1024	0
953	}	1025	}
954		1026
955	=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)	1027	=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
956		1028
957	=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)	1029	=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
958		1030
959	Generate an object-specific event with the given arguments.	1031	Generate an object-specific event with the given arguments.
960		1032
…		…
1038	cf::attachable->attach (	1110	cf::attachable->attach (
1039	prio => -1000000,	1111	prio => -1000000,
1040	on_instantiate => sub {	1112	on_instantiate => sub {
1041	my ($obj, $data) = @_;	1113	my ($obj, $data) = @_;
1042		1114
1043	$data = from_json $data;	1115	$data = decode_json $data;
1044		1116
1045	for (@$data) {	1117	for (@$data) {
1046	my ($name, $args) = @$_;	1118	my ($name, $args) = @$_;
1047		1119
1048	$obj->attach ($name, %{$args \|\| {} });	1120	$obj->attach ($name, %{$args \|\| {} });
…		…
1077	close $fh;	1149	close $fh;
1078		1150
1079	if (@$objs) {	1151	if (@$objs) {
1080	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {	1152	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {
1081	chmod SAVE_MODE, $fh;	1153	chmod SAVE_MODE, $fh;
1082	my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs };	1154	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1083	aio_write $fh, 0, (length $data), $data, 0;	1155	aio_write $fh, 0, (length $data), $data, 0;
1084	aio_fsync $fh if $cf::USE_FSYNC;	1156	aio_fsync $fh if $cf::USE_FSYNC;
1085	close $fh;	1157	close $fh;
1086	aio_rename "$filename.pst~", "$filename.pst";	1158	aio_rename "$filename.pst~", "$filename.pst";
1087	}	1159	}
…		…
1118		1190
1119	unless (aio_stat "$filename.pst") {	1191	unless (aio_stat "$filename.pst") {
1120	(aio_load "$filename.pst", $av) >= 0	1192	(aio_load "$filename.pst", $av) >= 0
1121	or return;	1193	or return;
1122		1194
1123	my $st = eval { Coro::Storable::thaw $av }	1195	my $st = eval { Coro::Storable::thaw $av };
1124	\|\| eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1125	$av = $st->{objs};	1196	$av = $st->{objs};
1126	}	1197	}
1127		1198
1128	utf8::decode (my $decname = $filename);	1199	utf8::decode (my $decname = $filename);
1129	warn sprintf "loading %s (%d,%d)\n",	1200	warn sprintf "loading %s (%d,%d)\n",
…		…
1286	my $msg = $@ ? "$v->{path}: $@\n"	1357	my $msg = $@ ? "$v->{path}: $@\n"
1287	: "$v->{base}: extension inactive.\n";	1358	: "$v->{base}: extension inactive.\n";
1288		1359
1289	if (exists $v->{meta}{mandatory}) {	1360	if (exists $v->{meta}{mandatory}) {
1290	warn $msg;	1361	warn $msg;
1291	warn "mandatory extension failed to load, exiting.\n";	1362	cf::cleanup "mandatory extension failed to load, exiting.";
1292	exit 1;
1293	}	1363	}
1294		1364
1295	warn $msg;	1365	warn $msg;
1296	}	1366	}
1297		1367
…		…
1406	return if $pl->{deny_save};	1476	return if $pl->{deny_save};
1407		1477
1408	aio_mkdir playerdir $pl, 0770;	1478	aio_mkdir playerdir $pl, 0770;
1409	$pl->{last_save} = $cf::RUNTIME;	1479	$pl->{last_save} = $cf::RUNTIME;
1410		1480
		1481	cf::get_slot 0.01;
		1482
1411	$pl->save_pl ($path);	1483	$pl->save_pl ($path);
1412	cf::cede_to_tick;	1484	cf::cede_to_tick;
1413	}	1485	}
1414		1486
1415	sub new($) {	1487	sub new($) {
…		…
1545		1617
1546	Expand crossfire pod fragments into protocol xml.	1618	Expand crossfire pod fragments into protocol xml.
1547		1619
1548	=cut	1620	=cut
1549		1621
		1622	use re 'eval';
		1623
		1624	my $group;
		1625	my $interior; $interior = qr{
		1626	# match a pod interior sequence sans C<< >>
		1627	(?:
		1628	\ (.*?)\ (?{ $group = $^N })
		1629	\| < (??{$interior}) >
		1630	)
		1631	}x;
		1632
1550	sub expand_cfpod {	1633	sub expand_cfpod {
1551	((my $self), (local $_)) = @_;	1634	my ($self, $pod) = @_;
1552		1635
1553	# escape & and <	1636	my $xml;
1554	s/&/&/g;
1555	s/(?<![BIUGHT])</</g;
1556		1637
1557	# this is buggy, it needs to properly take care of nested <'s	1638	while () {
		1639	if ($pod =~ /\G( (?: [^BCGHITU]+ \| .(?!<) )+ )/xgcs) {
		1640	$group = $1;
1558		1641
1559	1 while	1642	$group =~ s/&/&/g;
1560	# replace B<>, I<>, U<> etc.	1643	$group =~ s/</</g;
1561	s/B<([^\>]*)>/<b>$1<\/b>/	1644
1562	\|\| s/I<([^\>]*)>/<i>$1<\/i>/	1645	$xml .= $group;
1563	\|\| s/U<([^\>]*)>/<u>$1<\/u>/	1646	} elsif ($pod =~ m%\G
1564	\|\| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/	1647	([BCGHITU])
1565	# replace G<male\|female> tags	1648	<
1566	\|\| s{G<([^>\|])\\|([^>])>}{	1649	(?:
1567	$self->gender ? $2 : $1	1650	([^<>]*) (?{ $group = $^N })
1568	}ge	1651	\| < $interior >
1569	# replace H<hint text>	1652	)
1570	\|\| s{H<([^\>]*)>}	1653	>
		1654	%gcsx
1571	{	1655	) {
		1656	my ($code, $data) = ($1, $group);
		1657
		1658	if ($code eq "B") {
		1659	$xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
		1660	} elsif ($code eq "I") {
		1661	$xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
		1662	} elsif ($code eq "U") {
		1663	$xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
		1664	} elsif ($code eq "C") {
		1665	$xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
		1666	} elsif ($code eq "T") {
		1667	$xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
		1668	} elsif ($code eq "G") {
		1669	my ($male, $female) = split /\\|/, $data;
		1670	$data = $self->gender ? $female : $male;
		1671	$xml .= expand_cfpod ($self, $data);
		1672	} elsif ($code eq "H") {
1572	("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",	1673	$xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1573	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",	1674	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1574	"")	1675	"")
1575	[$self->{hintmode}]	1676	[$self->{hintmode}];
		1677	} else {
		1678	$xml .= "error processing '$code($data)' directive";
1576	}ge;	1679	}
		1680	} else {
		1681	if ($pod =~ /\G(.+)/) {
		1682	warn "parse error while expanding $pod (at $1)";
		1683	}
		1684	last;
		1685	}
		1686	}
1577		1687
		1688	for ($xml) {
1578	# create single paragraphs (very hackish)	1689	# create single paragraphs (very hackish)
1579	s/(?<=\S)\n(?=\w)/ /g;	1690	s/(?<=\S)\n(?=\w)/ /g;
1580		1691
1581	# compress some whitespace	1692	# compress some whitespace
1582	s/\s+\n/\n/g; # ws line-ends	1693	s/\s+\n/\n/g; # ws line-ends
1583	s/\n\n+/\n/g; # double lines	1694	s/\n\n+/\n/g; # double lines
1584	s/^\n+//; # beginning lines	1695	s/^\n+//; # beginning lines
1585	s/\n+$//; # ending lines	1696	s/\n+$//; # ending lines
		1697	}
1586		1698
1587	$_	1699	$xml
1588	}	1700	}
		1701
		1702	no re 'eval';
1589		1703
1590	sub hintmode {	1704	sub hintmode {
1591	$_[0]{hintmode} = $_[1] if @_ > 1;	1705	$_[0]{hintmode} = $_[1] if @_ > 1;
1592	$_[0]{hintmode}	1706	$_[0]{hintmode}
1593	}	1707	}
…		…
1665	our $MAX_RESET = 3600;	1779	our $MAX_RESET = 3600;
1666	our $DEFAULT_RESET = 3000;	1780	our $DEFAULT_RESET = 3000;
1667		1781
1668	sub generate_random_map {	1782	sub generate_random_map {
1669	my ($self, $rmp) = @_;	1783	my ($self, $rmp) = @_;
		1784
		1785	my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
		1786
1670	# mit "rum" bekleckern, nicht	1787	# mit "rum" bekleckern, nicht
1671	$self->_create_random_map (	1788	$self->_create_random_map (
1672	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},	1789	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1673	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},	1790	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1674	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},	1791	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
…		…
1796		1913
1797	# the temporary/swap location	1914	# the temporary/swap location
1798	sub save_path {	1915	sub save_path {
1799	my ($self) = @_;	1916	my ($self) = @_;
1800		1917
1801	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;	1918	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1802	"$TMPDIR/$path.map"	1919	"$TMPDIR/$path.map"
1803	}	1920	}
1804		1921
1805	# the unique path, undef == no special unique path	1922	# the unique path, undef == no special unique path
1806	sub uniq_path {	1923	sub uniq_path {
1807	my ($self) = @_;	1924	my ($self) = @_;
1808		1925
1809	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;	1926	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1810	"$UNIQUEDIR/$path"	1927	"$UNIQUEDIR/$path"
1811	}	1928	}
1812		1929
1813	# and all this just because we cannot iterate over	1930	# and all this just because we cannot iterate over
1814	# all maps in C++...	1931	# all maps in C++...
…		…
2000	}	2117	}
2001		2118
2002	$self->{last_save} = $cf::RUNTIME;	2119	$self->{last_save} = $cf::RUNTIME;
2003	$self->last_access ($cf::RUNTIME);	2120	$self->last_access ($cf::RUNTIME);
2004		2121
2005	$self->in_memory (cf::MAP_IN_MEMORY);	2122	$self->in_memory (cf::MAP_ACTIVE);
2006	}	2123	}
2007		2124
2008	$self->post_load;	2125	$self->post_load;
2009	}	2126	}
2010		2127
…		…
2068	my ($path, $origin, $load) = @_;	2185	my ($path, $origin, $load) = @_;
2069		2186
2070	$path = normalise $path, $origin && $origin->{path};	2187	$path = normalise $path, $origin && $origin->{path};
2071		2188
2072	if (my $map = $cf::MAP{$path}) {	2189	if (my $map = $cf::MAP{$path}) {
2073	return $map if !$load \|\| $map->in_memory == cf::MAP_IN_MEMORY;	2190	return $map if !$load \|\| $map->in_memory == cf::MAP_ACTIVE;
2074	}	2191	}
2075		2192
2076	$MAP_PREFETCH{$path} \|= $load;	2193	$MAP_PREFETCH{$path} \|= $load;
2077		2194
2078	$MAP_PREFETCHER \|\|= cf::async {	2195	$MAP_PREFETCHER \|\|= cf::async {
…		…
2115	cf::async {	2232	cf::async {
2116	$Coro::current->{desc} = "map player save";	2233	$Coro::current->{desc} = "map player save";
2117	$_->contr->save for $self->players;	2234	$_->contr->save for $self->players;
2118	};	2235	};
2119		2236
		2237	cf::get_slot 0.02;
		2238
2120	if ($uniq) {	2239	if ($uniq) {
2121	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);	2240	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);
2122	$self->_save_objects ($uniq, cf::IO_UNIQUES);	2241	$self->_save_objects ($uniq, cf::IO_UNIQUES);
2123	} else {	2242	} else {
2124	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS \| cf::IO_UNIQUES);	2243	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS \| cf::IO_UNIQUES);
…		…
2132	$self->save;	2251	$self->save;
2133		2252
2134	my $lock = cf::lock_acquire "map_data:$self->{path}";	2253	my $lock = cf::lock_acquire "map_data:$self->{path}";
2135		2254
2136	return if $self->players;	2255	return if $self->players;
2137	return if $self->in_memory != cf::MAP_IN_MEMORY;	2256	return if $self->in_memory != cf::MAP_ACTIVE;
2138	return if $self->{deny_save};	2257	return if $self->{deny_save};
2139		2258
2140	$self->in_memory (cf::MAP_SWAPPED);	2259	$self->in_memory (cf::MAP_SWAPPED);
2141		2260
2142	$self->deactivate;	2261	$self->deactivate;
…		…
2260		2379
2261	sub unique_maps() {	2380	sub unique_maps() {
2262	[	2381	[
2263	map {	2382	map {
2264	utf8::decode $_;	2383	utf8::decode $_;
2265	/\.map$/	2384	s/\.map$//; # TODO future compatibility hack
		2385	/\.pst$/ \|\| !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
		2386	? ()
2266	? normalise $_	2387	: normalise $_
2267	: ()
2268	} @{ aio_readdir $UNIQUEDIR or [] }	2388	} @{ aio_readdir $UNIQUEDIR or [] }
2269	]	2389	]
2270	}	2390	}
2271		2391
2272	package cf;
2273
2274	=back	2392	=back
2275		2393
2276	=head3 cf::object	2394	=head3 cf::object
2277		2395
2278	=cut	2396	=cut
…		…
2281		2399
2282	=over 4	2400	=over 4
2283		2401
2284	=item $ob->inv_recursive	2402	=item $ob->inv_recursive
2285		2403
2286	Returns the inventory of the object _and_ their inventories, recursively.	2404	Returns the inventory of the object I<and> their inventories, recursively,
		2405	but I<not> the object itself.
2287		2406
2288	=cut	2407	=cut
2289		2408
2290	sub inv_recursive_;	2409	sub inv_recursive_;
2291	sub inv_recursive_ {	2410	sub inv_recursive_ {
…		…
2296	inv_recursive_ inv $_[0]	2415	inv_recursive_ inv $_[0]
2297	}	2416	}
2298		2417
2299	=item $ref = $ob->ref	2418	=item $ref = $ob->ref
2300		2419
2301	creates and returns a persistent reference to an objetc that can be stored as a string.	2420	Creates and returns a persistent reference to an object that can be stored as a string.
2302		2421
2303	=item $ob = cf::object::deref ($refstring)	2422	=item $ob = cf::object::deref ($refstring)
2304		2423
2305	returns the objetc referenced by refstring. may return undef when it cnanot find the object,	2424	returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2306	even if the object actually exists. May block.	2425	even if the object actually exists. May block.
…		…
2580	$rmp->{origin_y} = $exit->y;	2699	$rmp->{origin_y} = $exit->y;
2581	}	2700	}
2582		2701
2583	$rmp->{random_seed} \|\|= $exit->random_seed;	2702	$rmp->{random_seed} \|\|= $exit->random_seed;
2584		2703
2585	my $data = cf::to_json $rmp;	2704	my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2586	my $md5 = Digest::MD5::md5_hex $data;	2705	my $md5 = Digest::MD5::md5_hex $data;
2587	my $meta = "$RANDOMDIR/$md5.meta";	2706	my $meta = "$RANDOMDIR/$md5.meta";
2588		2707
2589	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {	2708	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {
2590	aio_write $fh, 0, (length $data), $data, 0;	2709	aio_write $fh, 0, (length $data), $data, 0;
…		…
2663	the message, with C<log> being the default. If C<$color> is negative, suppress	2782	the message, with C<log> being the default. If C<$color> is negative, suppress
2664	the message unless the client supports the msg packet.	2783	the message unless the client supports the msg packet.
2665		2784
2666	=cut	2785	=cut
2667		2786
		2787	# non-persistent channels (usually the info channel)
2668	our %CHANNEL = (	2788	our %CHANNEL = (
2669	"c/identify" => {	2789	"c/identify" => {
2670	id => "infobox",	2790	id => "infobox",
2671	title => "Identify",	2791	title => "Identify",
2672	reply => undef,	2792	reply => undef,
…		…
2676	id => "infobox",	2796	id => "infobox",
2677	title => "Examine",	2797	title => "Examine",
2678	reply => undef,	2798	reply => undef,
2679	tooltip => "Signs and other items you examined",	2799	tooltip => "Signs and other items you examined",
2680	},	2800	},
		2801	"c/book" => {
		2802	id => "infobox",
		2803	title => "Book",
		2804	reply => undef,
		2805	tooltip => "The contents of a note or book",
		2806	},
2681	"c/lookat" => {	2807	"c/lookat" => {
2682	id => "infobox",	2808	id => "infobox",
2683	title => "Look",	2809	title => "Look",
2684	reply => undef,	2810	reply => undef,
2685	tooltip => "What you saw there",	2811	tooltip => "What you saw there",
		2812	},
		2813	"c/who" => {
		2814	id => "infobox",
		2815	title => "Players",
		2816	reply => undef,
		2817	tooltip => "Shows players who are currently online",
		2818	},
		2819	"c/body" => {
		2820	id => "infobox",
		2821	title => "Body Parts",
		2822	reply => undef,
		2823	tooltip => "Shows which body parts you posess and are available",
		2824	},
		2825	"c/uptime" => {
		2826	id => "infobox",
		2827	title => "Uptime",
		2828	reply => undef,
		2829	tooltip => "How long the server has been running since last restart",
		2830	},
		2831	"c/mapinfo" => {
		2832	id => "infobox",
		2833	title => "Map Info",
		2834	reply => undef,
		2835	tooltip => "Information related to the maps",
2686	},	2836	},
2687	);	2837	);
2688		2838
2689	sub cf::client::send_msg {	2839	sub cf::client::send_msg {
2690	my ($self, $channel, $msg, $color, @extra) = @_;	2840	my ($self, $channel, $msg, $color, @extra) = @_;
…		…
3059	{	3209	{
3060	my $faces = $facedata->{faceinfo};	3210	my $faces = $facedata->{faceinfo};
3061		3211
3062	while (my ($face, $info) = each %$faces) {	3212	while (my ($face, $info) = each %$faces) {
3063	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	3213	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
		3214
3064	cf::face::set_visibility $idx, $info->{visibility};	3215	cf::face::set_visibility $idx, $info->{visibility};
3065	cf::face::set_magicmap $idx, $info->{magicmap};	3216	cf::face::set_magicmap $idx, $info->{magicmap};
3066	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};	3217	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3067	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};	3218	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3068		3219
3069	cf::cede_to_tick;	3220	cf::cede_to_tick;
3070	}	3221	}
3071		3222
3072	while (my ($face, $info) = each %$faces) {	3223	while (my ($face, $info) = each %$faces) {
3073	next unless $info->{smooth};	3224	next unless $info->{smooth};
		3225
3074	my $idx = cf::face::find $face	3226	my $idx = cf::face::find $face
3075	or next;	3227	or next;
		3228
3076	if (my $smooth = cf::face::find $info->{smooth}) {	3229	if (my $smooth = cf::face::find $info->{smooth}) {
3077	cf::face::set_smooth $idx, $smooth;	3230	cf::face::set_smooth $idx, $smooth;
3078	cf::face::set_smoothlevel $idx, $info->{smoothlevel};	3231	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3079	} else {	3232	} else {
3080	warn "smooth face '$info->{smooth}' not found for face '$face'";	3233	warn "smooth face '$info->{smooth}' not found for face '$face'";
…		…
3098	{	3251	{
3099	# TODO: for gcfclient pleasure, we should give resources	3252	# TODO: for gcfclient pleasure, we should give resources
3100	# that gcfclient doesn't grok a >10000 face index.	3253	# that gcfclient doesn't grok a >10000 face index.
3101	my $res = $facedata->{resource};	3254	my $res = $facedata->{resource};
3102		3255
3103	my $soundconf = delete $res->{"res/sound.conf"};
3104
3105	while (my ($name, $info) = each %$res) {	3256	while (my ($name, $info) = each %$res) {
		3257	if (defined $info->{type}) {
3106	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	3258	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
3107	my $data;	3259	my $data;
3108		3260
3109	if ($info->{type} & 1) {	3261	if ($info->{type} & 1) {
3110	# prepend meta info	3262	# prepend meta info
3111		3263
3112	my $meta = $enc->encode ({	3264	my $meta = $enc->encode ({
3113	name => $name,	3265	name => $name,
3114	%{ $info->{meta} \|\| {} },	3266	%{ $info->{meta} \|\| {} },
3115	});	3267	});
3116		3268
3117	$data = pack "(w/a)", $meta, $info->{data};	3269	$data = pack "(w/a)", $meta, $info->{data};
		3270	} else {
		3271	$data = $info->{data};
		3272	}
		3273
		3274	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
		3275	cf::face::set_type $idx, $info->{type};
3118	} else {	3276	} else {
3119	$data = $info->{data};	3277	$RESOURCE{$name} = $info;
3120	}	3278	}
3121		3279
3122	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3123	cf::face::set_type $idx, $info->{type};
3124
3125	cf::cede_to_tick;	3280	cf::cede_to_tick;
3126	}	3281	}
3127
3128	if ($soundconf) {
3129	$soundconf = $enc->decode (delete $soundconf->{data});
3130
3131	for (0 .. SOUND_CAST_SPELL_0 - 1) {
3132	my $sound = $soundconf->{compat}[$_]
3133	or next;
3134
3135	my $face = cf::face::find "sound/$sound->[1]";
3136	cf::sound::set $sound->[0] => $face;
3137	cf::sound::old_sound_index $_, $face; # gcfclient-compat
3138	}
3139
3140	while (my ($k, $v) = each %{$soundconf->{event}}) {
3141	my $face = cf::face::find "sound/$v";
3142	cf::sound::set $k => $face;
3143	}
3144	}
3145	}	3282	}
		3283
		3284	cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3146		3285
3147	1	3286	1
3148	}	3287	}
		3288
		3289	cf::global->attach (on_resource_update => sub {
		3290	if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
		3291	$soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
		3292
		3293	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3294	my $sound = $soundconf->{compat}[$_]
		3295	or next;
		3296
		3297	my $face = cf::face::find "sound/$sound->[1]";
		3298	cf::sound::set $sound->[0] => $face;
		3299	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3300	}
		3301
		3302	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3303	my $face = cf::face::find "sound/$v";
		3304	cf::sound::set $k => $face;
		3305	}
		3306	}
		3307	});
3149		3308
3150	register_exticmd fx_want => sub {	3309	register_exticmd fx_want => sub {
3151	my ($ns, $want) = @_;	3310	my ($ns, $want) = @_;
3152		3311
3153	while (my ($k, $v) = each %$want) {	3312	while (my ($k, $v) = each %$want) {
3154	$ns->fx_want ($k, $v);	3313	$ns->fx_want ($k, $v);
3155	}	3314	}
3156	};	3315	};
		3316
		3317	sub load_resource_file($) {
		3318	my $status = load_resource_file_ $_[0];
		3319	get_slot 0.1, 100;
		3320	cf::arch::commit_load;
		3321	$status
		3322	}
3157		3323
3158	sub reload_regions {	3324	sub reload_regions {
3159	# HACK to clear player env face cache, we need some signal framework	3325	# HACK to clear player env face cache, we need some signal framework
3160	# for this (global event?)	3326	# for this (global event?)
3161	%ext::player_env::MUSIC_FACE_CACHE = ();	3327	%ext::player_env::MUSIC_FACE_CACHE = ();
…		…
3175	}	3341	}
3176		3342
3177	sub reload_archetypes {	3343	sub reload_archetypes {
3178	load_resource_file "$DATADIR/archetypes"	3344	load_resource_file "$DATADIR/archetypes"
3179	or die "unable to load archetypes\n";	3345	or die "unable to load archetypes\n";
3180	#d# NEED to laod twice to resolve forward references
3181	# this really needs to be done in an extra post-pass
3182	# (which needs to be synchronous, so solve it differently)
3183	load_resource_file "$DATADIR/archetypes"
3184	or die "unable to load archetypes\n";
3185	}	3346	}
3186		3347
3187	sub reload_treasures {	3348	sub reload_treasures {
3188	load_resource_file "$DATADIR/treasures"	3349	load_resource_file "$DATADIR/treasures"
3189	or die "unable to load treasurelists\n";	3350	or die "unable to load treasurelists\n";
3190	}	3351	}
3191		3352
3192	sub reload_resources {	3353	sub reload_resources {
3193	warn "reloading resource files...\n";	3354	warn "reloading resource files...\n";
3194		3355
		3356	reload_facedata;
		3357	reload_archetypes;
3195	reload_regions;	3358	reload_regions;
3196	reload_facedata;
3197	#reload_archetypes;#d#
3198	reload_archetypes;
3199	reload_treasures;	3359	reload_treasures;
3200		3360
3201	warn "finished reloading resource files\n";	3361	warn "finished reloading resource files\n";
3202	}	3362	}
3203		3363
3204	sub init {	3364	sub init {
		3365	my $guard = freeze_mainloop;
		3366
3205	reload_resources;	3367	reload_resources;
3206	}	3368	}
3207		3369
3208	sub reload_config {	3370	sub reload_config {
3209	open my $fh, "<:utf8", "$CONFDIR/config"	3371	open my $fh, "<:utf8", "$CONFDIR/config"
3210	or return;	3372	or return;
3211		3373
3212	local $/;	3374	local $/;
3213	*CFG = YAML::Syck::Load <$fh>;	3375	*CFG = YAML::Load <$fh>;
3214		3376
3215	$EMERGENCY_POSITION = $CFG{emergency_position} \|\| ["/world/world_105_115", 5, 37];	3377	$EMERGENCY_POSITION = $CFG{emergency_position} \|\| ["/world/world_105_115", 5, 37];
3216		3378
3217	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};	3379	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3218	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};	3380	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
…		…
3230	# we must not ever block the main coroutine	3392	# we must not ever block the main coroutine
3231	local $Coro::idle = sub {	3393	local $Coro::idle = sub {
3232	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#	3394	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3233	(async {	3395	(async {
3234	$Coro::current->{desc} = "IDLE BUG HANDLER";	3396	$Coro::current->{desc} = "IDLE BUG HANDLER";
3235	Event::one_event;	3397	EV::loop EV::LOOP_ONESHOT;
3236	})->prio (Coro::PRIO_MAX);	3398	})->prio (Coro::PRIO_MAX);
3237	};	3399	};
3238		3400
		3401	{
		3402	my $guard = freeze_mainloop;
3239	reload_config;	3403	reload_config;
3240	db_init;	3404	db_init;
3241	load_extensions;	3405	load_extensions;
3242		3406
3243	$TICK_WATCHER->start;	3407	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
		3408	evthread_start IO::AIO::poll_fileno;
		3409	}
		3410
3244	Event::loop;	3411	EV::loop;
3245	}	3412	}
3246		3413
3247	#############################################################################	3414	#############################################################################
3248	# initialisation and cleanup	3415	# initialisation and cleanup
3249		3416
3250	# install some emergency cleanup handlers	3417	# install some emergency cleanup handlers
3251	BEGIN {	3418	BEGIN {
		3419	our %SIGWATCHER = ();
3252	for my $signal (qw(INT HUP TERM)) {	3420	for my $signal (qw(INT HUP TERM)) {
3253	Event->signal (	3421	$SIGWATCHER{$signal} = EV::signal $signal, sub {
3254	reentrant => 0,
3255	data => WF_AUTOCANCEL,
3256	signal => $signal,
3257	prio => 0,
3258	cb => sub {
3259	cf::cleanup "SIG$signal";	3422	cf::cleanup "SIG$signal";
3260	},
3261	);	3423	};
3262	}	3424	}
3263	}	3425	}
3264		3426
3265	sub write_runtime {	3427	sub write_runtime_sync {
3266	my $runtime = "$LOCALDIR/runtime";	3428	my $runtime = "$LOCALDIR/runtime";
3267		3429
3268	# first touch the runtime file to show we are still running:	3430	# first touch the runtime file to show we are still running:
3269	# the fsync below can take a very very long time.	3431	# the fsync below can take a very very long time.
3270		3432
…		…
3296	and return;	3458	and return;
3297		3459
3298	warn "runtime file written.\n";	3460	warn "runtime file written.\n";
3299		3461
3300	1	3462	1
		3463	}
		3464
		3465	our $uuid_lock;
		3466	our $uuid_skip;
		3467
		3468	sub write_uuid_sync($) {
		3469	$uuid_skip \|\|= $_[0];
		3470
		3471	return if $uuid_lock;
		3472	local $uuid_lock = 1;
		3473
		3474	my $uuid = "$LOCALDIR/uuid";
		3475
		3476	my $fh = aio_open "$uuid~", O_WRONLY \| O_CREAT, 0644
		3477	or return;
		3478
		3479	my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
		3480	$uuid_skip = 0;
		3481
		3482	(aio_write $fh, 0, (length $value), $value, 0) <= 0
		3483	and return;
		3484
		3485	# always fsync - this file is important
		3486	aio_fsync $fh
		3487	and return;
		3488
		3489	close $fh
		3490	or return;
		3491
		3492	aio_rename "$uuid~", $uuid
		3493	and return;
		3494
		3495	warn "uuid file written ($value).\n";
		3496
		3497	1
		3498
		3499	}
		3500
		3501	sub write_uuid($$) {
		3502	my ($skip, $sync) = @_;
		3503
		3504	$sync ? write_uuid_sync $skip
		3505	: async { write_uuid_sync $skip };
3301	}	3506	}
3302		3507
3303	sub emergency_save() {	3508	sub emergency_save() {
3304	my $freeze_guard = cf::freeze_mainloop;	3509	my $freeze_guard = cf::freeze_mainloop;
3305		3510
…		…
3327	warn "end emergency map save\n";	3532	warn "end emergency map save\n";
3328		3533
3329	warn "begin emergency database checkpoint\n";	3534	warn "begin emergency database checkpoint\n";
3330	BDB::db_env_txn_checkpoint $DB_ENV;	3535	BDB::db_env_txn_checkpoint $DB_ENV;
3331	warn "end emergency database checkpoint\n";	3536	warn "end emergency database checkpoint\n";
		3537
		3538	warn "begin write uuid\n";
		3539	write_uuid_sync 1;
		3540	warn "end write uuid\n";
3332	};	3541	};
3333		3542
3334	warn "leave emergency perl save\n";	3543	warn "leave emergency perl save\n";
3335	}	3544	}
3336		3545
…		…
3351	warn "reloading...";	3560	warn "reloading...";
3352		3561
3353	warn "entering sync_job";	3562	warn "entering sync_job";
3354		3563
3355	cf::sync_job {	3564	cf::sync_job {
3356	cf::write_runtime; # external watchdog should not bark	3565	cf::write_runtime_sync; # external watchdog should not bark
3357	cf::emergency_save;	3566	cf::emergency_save;
3358	cf::write_runtime; # external watchdog should not bark	3567	cf::write_runtime_sync; # external watchdog should not bark
3359		3568
3360	warn "syncing database to disk";	3569	warn "syncing database to disk";
3361	BDB::db_env_txn_checkpoint $DB_ENV;	3570	BDB::db_env_txn_checkpoint $DB_ENV;
3362		3571
3363	# if anything goes wrong in here, we should simply crash as we already saved	3572	# if anything goes wrong in here, we should simply crash as we already saved
3364
3365	warn "cancelling all WF_AUTOCANCEL watchers";
3366	for (Event::all_watchers) {
3367	$_->cancel if $_->data & WF_AUTOCANCEL;
3368	}
3369		3573
3370	warn "flushing outstanding aio requests";	3574	warn "flushing outstanding aio requests";
3371	for (;;) {	3575	for (;;) {
3372	BDB::flush;	3576	BDB::flush;
3373	IO::AIO::flush;	3577	IO::AIO::flush;
3374	Coro::cede;	3578	Coro::cede_notself;
3375	last unless IO::AIO::nreqs \|\| BDB::nreqs;	3579	last unless IO::AIO::nreqs \|\| BDB::nreqs;
3376	warn "iterate...";	3580	warn "iterate...";
3377	}	3581	}
3378		3582
3379	++$RELOAD;	3583	++$RELOAD;
…		…
3455	warn "leaving sync_job";	3659	warn "leaving sync_job";
3456		3660
3457	1	3661	1
3458	} or do {	3662	} or do {
3459	warn $@;	3663	warn $@;
3460	warn "error while reloading, exiting.";	3664	cf::cleanup "error while reloading, exiting.";
3461	exit 1;
3462	};	3665	};
3463		3666
3464	warn "reloaded";	3667	warn "reloaded";
3465	};	3668	};
3466		3669
…		…
3468		3671
3469	sub reload_perl() {	3672	sub reload_perl() {
3470	# doing reload synchronously and two reloads happen back-to-back,	3673	# doing reload synchronously and two reloads happen back-to-back,
3471	# coro crashes during coro_state_free->destroy here.	3674	# coro crashes during coro_state_free->destroy here.
3472		3675
3473	$RELOAD_WATCHER \|\|= Event->timer (	3676	$RELOAD_WATCHER \|\|= EV::timer 0, 0, sub {
3474	reentrant => 0,
3475	after => 0,
3476	data => WF_AUTOCANCEL,
3477	cb => sub {
3478	do_reload_perl;	3677	do_reload_perl;
3479	undef $RELOAD_WATCHER;	3678	undef $RELOAD_WATCHER;
3480	},
3481	);	3679	};
3482	}	3680	}
3483		3681
3484	register_command "reload" => sub {	3682	register_command "reload" => sub {
3485	my ($who, $arg) = @_;	3683	my ($who, $arg) = @_;
3486		3684
…		…
3499		3697
3500	our @WAIT_FOR_TICK;	3698	our @WAIT_FOR_TICK;
3501	our @WAIT_FOR_TICK_BEGIN;	3699	our @WAIT_FOR_TICK_BEGIN;
3502		3700
3503	sub wait_for_tick {	3701	sub wait_for_tick {
3504	return unless $TICK_WATCHER->is_active;
3505	return if $Coro::current == $Coro::main;	3702	return if tick_inhibit \|\| $Coro::current == $Coro::main;
3506		3703
3507	my $signal = new Coro::Signal;	3704	my $signal = new Coro::Signal;
3508	push @WAIT_FOR_TICK, $signal;	3705	push @WAIT_FOR_TICK, $signal;
3509	$signal->wait;	3706	$signal->wait;
3510	}	3707	}
3511		3708
3512	sub wait_for_tick_begin {	3709	sub wait_for_tick_begin {
3513	return unless $TICK_WATCHER->is_active;
3514	return if $Coro::current == $Coro::main;	3710	return if tick_inhibit \|\| $Coro::current == $Coro::main;
3515		3711
3516	my $signal = new Coro::Signal;	3712	my $signal = new Coro::Signal;
3517	push @WAIT_FOR_TICK_BEGIN, $signal;	3713	push @WAIT_FOR_TICK_BEGIN, $signal;
3518	$signal->wait;	3714	$signal->wait;
3519	}	3715	}
3520		3716
3521	$TICK_WATCHER = Event->timer (	3717	sub tick {
3522	reentrant => 0,
3523	parked => 1,
3524	prio => 0,
3525	at => $NEXT_TICK \|\| $TICK,
3526	data => WF_AUTOCANCEL,
3527	cb => sub {
3528	if ($Coro::current != $Coro::main) {	3718	if ($Coro::current != $Coro::main) {
3529	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"	3719	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3530	unless ++$bug_warning > 10;	3720	unless ++$bug_warning > 10;
3531	return;	3721	return;
3532	}	3722	}
3533		3723
3534	$NOW = $tick_start = Event::time;
3535
3536	cf::server_tick; # one server iteration	3724	cf::server_tick; # one server iteration
3537		3725
3538	$RUNTIME += $TICK;
3539	$NEXT_TICK += $TICK;
3540
3541	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3726	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3542	$NEXT_RUNTIME_WRITE = $NOW + 10;	3727	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3543	Coro::async_pool {	3728	Coro::async_pool {
3544	$Coro::current->{desc} = "runtime saver";	3729	$Coro::current->{desc} = "runtime saver";
3545	write_runtime	3730	write_runtime_sync
3546	or warn "ERROR: unable to write runtime file: $!";	3731	or warn "ERROR: unable to write runtime file: $!";
3547	};
3548	}	3732	};
		3733	}
3549		3734
3550	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3735	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3551	$sig->send;	3736	$sig->send;
3552	}	3737	}
3553	while (my $sig = shift @WAIT_FOR_TICK) {	3738	while (my $sig = shift @WAIT_FOR_TICK) {
3554	$sig->send;	3739	$sig->send;
3555	}	3740	}
3556		3741
3557	$NOW = Event::time;	3742	$LOAD = ($NOW - $TICK_START) / $TICK;
3558
3559	# if we are delayed by four ticks or more, skip them all
3560	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3561
3562	$TICK_WATCHER->at ($NEXT_TICK);
3563	$TICK_WATCHER->start;
3564
3565	$LOAD = ($NOW - $tick_start) / $TICK;
3566	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	3743	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3567		3744
3568	_post_tick;	3745	if (0) {
		3746	if ($NEXT_TICK) {
		3747	my $jitter = $TICK_START - $NEXT_TICK;
		3748	$JITTER = $JITTER * 0.75 + $jitter * 0.25;
		3749	warn "jitter $JITTER\n";#d#
		3750	}
3569	},	3751	}
3570	);	3752	}
3571		3753
3572	{	3754	{
		3755	# configure BDB
		3756
3573	BDB::min_parallel 8;	3757	BDB::min_parallel 8;
3574	BDB::max_poll_time $TICK * 0.1;	3758	BDB::max_poll_reqs $TICK * 0.1;
3575	$BDB_POLL_WATCHER = Event->io (	3759	$Coro::BDB::WATCHER->priority (1);
3576	reentrant => 0,
3577	fd => BDB::poll_fileno,
3578	poll => 'r',
3579	prio => 0,
3580	data => WF_AUTOCANCEL,
3581	cb => \&BDB::poll_cb,
3582	);
3583
3584	BDB::set_sync_prepare {
3585	my $status;
3586	my $current = $Coro::current;
3587	(
3588	sub {
3589	$status = $!;
3590	$current->ready; undef $current;
3591	},
3592	sub {
3593	Coro::schedule while defined $current;
3594	$! = $status;
3595	},
3596	)
3597	};
3598		3760
3599	unless ($DB_ENV) {	3761	unless ($DB_ENV) {
3600	$DB_ENV = BDB::db_env_create;	3762	$DB_ENV = BDB::db_env_create;
3601	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC	3763	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC
3602	\| BDB::LOG_AUTOREMOVE, 1);	3764	\| BDB::LOG_AUTOREMOVE, 1);
…		…
3617		3779
3618	cf::cleanup "db_env_open(db): $@" if $@;	3780	cf::cleanup "db_env_open(db): $@" if $@;
3619	};	3781	};
3620	}	3782	}
3621		3783
3622	$BDB_DEADLOCK_WATCHER = Event->timer (	3784	$BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3623	after => 3,
3624	interval => 1,
3625	hard => 1,
3626	prio => 0,
3627	data => WF_AUTOCANCEL,
3628	cb => sub {
3629	BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };	3785	BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3630	},
3631	);	3786	};
3632	$BDB_CHECKPOINT_WATCHER = Event->timer (	3787	$BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3633	after => 11,
3634	interval => 60,
3635	hard => 1,
3636	prio => 0,
3637	data => WF_AUTOCANCEL,
3638	cb => sub {
3639	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };	3788	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3640	},
3641	);	3789	};
3642	$BDB_TRICKLE_WATCHER = Event->timer (	3790	$BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3643	after => 5,
3644	interval => 10,
3645	hard => 1,
3646	prio => 0,
3647	data => WF_AUTOCANCEL,
3648	cb => sub {
3649	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };	3791	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3650	},
3651	);	3792	};
3652	}	3793	}
3653		3794
3654	{	3795	{
		3796	# configure IO::AIO
		3797
3655	IO::AIO::min_parallel 8;	3798	IO::AIO::min_parallel 8;
3656
3657	undef $Coro::AIO::WATCHER;
3658	IO::AIO::max_poll_time $TICK * 0.1;	3799	IO::AIO::max_poll_time $TICK * 0.1;
3659	$AIO_POLL_WATCHER = Event->io (	3800	$Coro::AIO::WATCHER->priority (1);
3660	reentrant => 0,
3661	data => WF_AUTOCANCEL,
3662	fd => IO::AIO::poll_fileno,
3663	poll => 'r',
3664	prio => 0,
3665	cb => \&IO::AIO::poll_cb,
3666	);
3667	}	3801	}
3668		3802
3669	my $_log_backtrace;	3803	my $_log_backtrace;
3670		3804
3671	sub _log_backtrace {	3805	sub _log_backtrace {

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.386 by root, Mon Oct 15 17:50:27 2007 UTC vs. Revision 1.423 by root, Sun Apr 20 00:44:13 2008 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.386 by root, Mon Oct 15 17:50:27 2007 UTC vs.
Revision 1.423 by root, Sun Apr 20 00:44:13 2008 UTC