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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.565 by root, Sat Apr 30 05:41:17 2011 UTC vs.
Revision 1.597 by root, Sun Nov 11 02:14:37 2012 UTC

…		…
1	#	1	#
2	# This file is part of Deliantra, the Roguelike Realtime MMORPG.	2	# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3	#	3	#
4	# Copyright (©) 2006,2007,2008,2009,2010,2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team	4	# Copyright (©) 2006,2007,2008,2009,2010,2011,2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5	#	5	#
6	# Deliantra is free software: you can redistribute it and/or modify it under	6	# Deliantra is free software: you can redistribute it and/or modify it under
7	# the terms of the Affero GNU General Public License as published by the	7	# the terms of the Affero GNU General Public License as published by the
8	# Free Software Foundation, either version 3 of the License, or (at your	8	# Free Software Foundation, either version 3 of the License, or (at your
9	# option) any later version.	9	# option) any later version.
10	#	10	#
11	# This program is distributed in the hope that it will be useful,	11	# This program is distributed in the hope that it will be useful,
12	# but WITHOUT ANY WARRANTY; without even the implied warranty of	12	# but WITHOUT ANY WARRANTY; without even the implied warranty of
13	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the	13	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14	# GNU General Public License for more details.	14	# GNU General Public License for more details.
15	#	15	#
16	# You should have received a copy of the Affero GNU General Public License	16	# You should have received a copy of the Affero GNU General Public License
17	# and the GNU General Public License along with this program. If not, see	17	# and the GNU General Public License along with this program. If not, see
18	# <http://www.gnu.org/licenses/>.	18	# <http://www.gnu.org/licenses/>.
19	#	19	#
20	# The authors can be reached via e-mail to <support@deliantra.net>	20	# The authors can be reached via e-mail to <support@deliantra.net>
21	#	21	#
22		22
23	package cf;	23	package cf;
24		24
32	use Safe;	32	use Safe;
33	use Safe::Hole;	33	use Safe::Hole;
34	use Storable ();	34	use Storable ();
35	use Carp ();	35	use Carp ();
36		36
37	use Guard ();	37	use AnyEvent ();
		38	use AnyEvent::IO ();
		39	use AnyEvent::DNS ();
		40
38	use Coro ();	41	use Coro ();
39	use Coro::State;	42	use Coro::State;
40	use Coro::Handle;	43	use Coro::Handle;
41	use Coro::EV;	44	use Coro::EV;
42	use Coro::AnyEvent;	45	use Coro::AnyEvent;
…		…
48	use Coro::AIO;	51	use Coro::AIO;
49	use Coro::BDB 1.6;	52	use Coro::BDB 1.6;
50	use Coro::Storable;	53	use Coro::Storable;
51	use Coro::Util ();	54	use Coro::Util ();
52		55
		56	use Guard ();
53	use JSON::XS 2.01 ();	57	use JSON::XS 2.01 ();
54	use BDB ();	58	use BDB ();
55	use Data::Dumper;	59	use Data::Dumper;
56	use Fcntl;	60	use Fcntl;
57	use YAML::XS ();	61	use YAML::XS ();
…		…
83	our %COMMAND = ();	87	our %COMMAND = ();
84	our %COMMAND_TIME = ();	88	our %COMMAND_TIME = ();
85		89
86	our @EXTS = (); # list of extension package names	90	our @EXTS = (); # list of extension package names
87	our %EXTCMD = ();	91	our %EXTCMD = ();
		92	our %EXTACMD = ();
88	our %EXTICMD = ();	93	our %EXTICMD = ();
		94	our %EXTIACMD = ();
89	our %EXT_CORO = (); # coroutines bound to extensions	95	our %EXT_CORO = (); # coroutines bound to extensions
90	our %EXT_MAP = (); # pluggable maps	96	our %EXT_MAP = (); # pluggable maps
91		97
92	our $RELOAD; # number of reloads so far, non-zero while in reload	98	our $RELOAD; # number of reloads so far, non-zero while in reload
93	our @EVENT;	99	our @EVENT;
…		…
108	our $RANDOMDIR = "$LOCALDIR/random";	114	our $RANDOMDIR = "$LOCALDIR/random";
109	our $BDBDIR = "$LOCALDIR/db";	115	our $BDBDIR = "$LOCALDIR/db";
110	our $PIDFILE = "$LOCALDIR/pid";	116	our $PIDFILE = "$LOCALDIR/pid";
111	our $RUNTIMEFILE = "$LOCALDIR/runtime";	117	our $RUNTIMEFILE = "$LOCALDIR/runtime";
112		118
113	our %RESOURCE; # unused	119	#our %RESOURCE; # unused
114		120
115	our $OUTPUT_RATE_MIN = 3000;	121	our $OUTPUT_RATE_MIN = 3000;
116	our $OUTPUT_RATE_MAX = 1000000;	122	our $OUTPUT_RATE_MAX = 1000000;
117		123
118	our $MAX_LINKS = 32; # how many chained exits to follow	124	our $MAX_LINKS = 32; # how many chained exits to follow
…		…
129	our $DB_ENV;	135	our $DB_ENV;
130		136
131	our @EXTRA_MODULES = qw(pod match mapscript incloader);	137	our @EXTRA_MODULES = qw(pod match mapscript incloader);
132		138
133	our %CFG;	139	our %CFG;
		140	our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
134		141
135	our $UPTIME; $UPTIME \|\|= time;	142	our $UPTIME; $UPTIME \|\|= time;
136	our $RUNTIME;	143	our $RUNTIME = 0;
		144	our $SERVER_TICK = 0;
137	our $NOW;	145	our $NOW;
138		146
139	our (%PLAYER, %PLAYER_LOADING); # all users	147	our (%PLAYER, %PLAYER_LOADING); # all users
140	our (%MAP, %MAP_LOADING ); # all maps	148	our (%MAP, %MAP_LOADING ); # all maps
141	our $LINK_MAP; # the special {link} map, which is always available	149	our $LINK_MAP; # the special {link} map, which is always available
…		…
150		158
151	our @POST_INIT;	159	our @POST_INIT;
152		160
153	our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)	161	our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
154	our $REALLY_UNLOOP; # never set to true, please :)	162	our $REALLY_UNLOOP; # never set to true, please :)
		163
		164	our $WAIT_FOR_TICK = new Coro::Signal;
		165	our @WAIT_FOR_TICK_BEGIN;
155		166
156	binmode STDOUT;	167	binmode STDOUT;
157	binmode STDERR;	168	binmode STDERR;
158		169
159	# read virtual server time, if available	170	# read virtual server time, if available
…		…
193		204
194	=over 4	205	=over 4
195		206
196	=item $cf::UPTIME	207	=item $cf::UPTIME
197		208
198	The timestamp of the server start (so not actually an uptime).	209	The timestamp of the server start (so not actually an "uptime").
		210
		211	=item $cf::SERVER_TICK
		212
		213	An unsigned integer that starts at zero when the server is started and is
		214	incremented on every tick.
		215
		216	=item $cf::NOW
		217
		218	The (real) time of the last (current) server tick - updated before and
		219	after tick processing, so this is useful only as a rough "what time is it
		220	now" estimate.
		221
		222	=item $cf::TICK
		223
		224	The interval between each server tick, in seconds.
199		225
200	=item $cf::RUNTIME	226	=item $cf::RUNTIME
201		227
202	The time this server has run, starts at 0 and is increased by $cf::TICK on	228	The time this server has run, starts at 0 and is increased by $cf::TICK on
203	every server tick.	229	every server tick.
204		230
205	=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR	231	=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
206	$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR	232	$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
207	$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR	233	$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
208		234
209	Various directories - "/etc", read-only install directory, perl-library	235	Various directories - "/etc", read-only install directory, perl-library
210	directory, pod-directory, read-only maps directory, "/var", "/var/tmp",	236	directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
211	unique-items directory, player file directory, random maps directory and	237	unique-items directory, player file directory, random maps directory and
212	database environment.	238	database environment.
213		239
214	=item $cf::NOW
215
216	The time of the last (current) server tick.
217
218	=item $cf::TICK
219
220	The interval between server ticks, in seconds.
221
222	=item $cf::LOADAVG	240	=item $cf::LOADAVG
223		241
224	The current CPU load on the server (alpha-smoothed), as a value between 0	242	The current CPU load on the server (alpha-smoothed), as a value between 0
225	(none) and 1 (overloaded), indicating how much time is spent on processing	243	(none) and 1 (overloaded), indicating how much time is spent on processing
226	objects per tick. Healthy values are < 0.5.	244	objects per tick. Healthy values are < 0.5.
…		…
237	=item cf::wait_for_tick, cf::wait_for_tick_begin	255	=item cf::wait_for_tick, cf::wait_for_tick_begin
238		256
239	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	257	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
240	returns directly I<after> the tick processing (and consequently, can only wake one thread	258	returns directly I<after> the tick processing (and consequently, can only wake one thread
241	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	259	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
		260
		261	Note that cf::Wait_for_tick will immediately return when the server is not
		262	ticking, making it suitable for small pauses in threads that need to run
		263	when the server is paused. If that is not applicable (i.e. you I<really>
		264	want to wait, use C<$cf::WAIT_FOR_TICK>).
		265
		266	=item $cf::WAIT_FOR_TICK
		267
		268	Note that C<cf::wait_for_tick> is probably the correct thing to use. This
		269	variable contains a L<Coro::Signal> that is broadcats after every server
		270	tick. Calling C<< ->wait >> on it will suspend the caller until after the
		271	next server tick.
242		272
243	=cut	273	=cut
244		274
245	sub wait_for_tick();	275	sub wait_for_tick();
246	sub wait_for_tick_begin();	276	sub wait_for_tick_begin();
…		…
312	)) {	342	)) {
313	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	343	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
314	}	344	}
315		345
316	$EV::DIED = sub {	346	$EV::DIED = sub {
317	Carp::cluck "error in event callback: @_";	347	warn "error in event callback: $@";
318	};	348	};
319		349
320	#############################################################################	350	#############################################################################
321		351
322	sub fork_call(&@);	352	sub fork_call(&@);
…		…
349	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;	379	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
350	$d	380	$d
351	} \|\| "[unable to dump $_[0]: '$@']";	381	} \|\| "[unable to dump $_[0]: '$@']";
352	}	382	}
353		383
354	=item $scalar = load_file $path	384	=item $scalar = cf::load_file $path
355		385
356	Loads the given file from path and returns its contents. Croaks on error	386	Loads the given file from path and returns its contents. Croaks on error
357	and can block.	387	and can block.
358		388
359	=cut	389	=cut
…		…
361	sub load_file($) {	391	sub load_file($) {
362	0 <= aio_load $_[0], my $data	392	0 <= aio_load $_[0], my $data
363	or Carp::croak "$_[0]: $!";	393	or Carp::croak "$_[0]: $!";
364		394
365	$data	395	$data
		396	}
		397
		398	=item $success = cf::replace_file $path, $data, $sync
		399
		400	Atomically replaces the file at the given $path with new $data, and
		401	optionally $sync the data to disk before replacing the file.
		402
		403	=cut
		404
		405	sub replace_file($$;$) {
		406	my ($path, $data, $sync) = @_;
		407
		408	my $lock = cf::lock_acquire ("replace_file:$path");
		409
		410	my $fh = aio_open "$path~", Fcntl::O_WRONLY \| Fcntl::O_CREAT \| Fcntl::O_TRUNC, 0644
		411	or return;
		412
		413	$data = $data->() if ref $data;
		414
		415	length $data == aio_write $fh, 0, (length $data), $data, 0
		416	or return;
		417
		418	!$sync
		419	or !aio_fsync $fh
		420	or return;
		421
		422	aio_close $fh
		423	and return;
		424
		425	aio_rename "$path~", $path
		426	and return;
		427
		428	if ($sync) {
		429	$path =~ s%/[^/]*$%%;
		430	aio_pathsync $path;
		431	}
		432
		433	1
366	}	434	}
367		435
368	=item $ref = cf::decode_json $json	436	=item $ref = cf::decode_json $json
369		437
370	Converts a JSON string into the corresponding perl data structure.	438	Converts a JSON string into the corresponding perl data structure.
…		…
545	}	613	}
546	}	614	}
547		615
548	if (@SLOT_QUEUE) {	616	if (@SLOT_QUEUE) {
549	# we do not use wait_for_tick() as it returns immediately when tick is inactive	617	# we do not use wait_for_tick() as it returns immediately when tick is inactive
550	push @cf::WAIT_FOR_TICK, $signal;	618	$WAIT_FOR_TICK->wait;
551	$signal->wait;
552	} else {	619	} else {
553	$busy = 0;	620	$busy = 0;
554	Coro::schedule;	621	Coro::schedule;
555	}	622	}
556	}	623	}
…		…
1366	=cut	1433	=cut
1367		1434
1368	#############################################################################	1435	#############################################################################
1369	# command handling &c	1436	# command handling &c
1370		1437
1371	=item cf::register_command $name => \&callback($ob,$args);	1438	=item cf::register_command $name => \&callback($ob,$args)
1372		1439
1373	Register a callback for execution when the client sends the user command	1440	Register a callback for execution when the client sends the user command
1374	$name.	1441	$name.
1375		1442
1376	=cut	1443	=cut
…		…
1382	#warn "registering command '$name/$time' to '$caller'";	1449	#warn "registering command '$name/$time' to '$caller'";
1383		1450
1384	push @{ $COMMAND{$name} }, [$caller, $cb];	1451	push @{ $COMMAND{$name} }, [$caller, $cb];
1385	}	1452	}
1386		1453
1387	=item cf::register_extcmd $name => \&callback($pl,$packet);	1454	=item cf::register_extcmd $name => \&callback($pl,@args)
1388		1455
1389	Register a callback for execution when the client sends an (synchronous)	1456	Register a callback for execution when the client sends an (synchronous)
1390	extcmd packet. Ext commands will be processed in the order they are	1457	extcmd packet. Ext commands will be processed in the order they are
1391	received by the server, like other user commands. The first argument is	1458	received by the server, like other user commands. The first argument is
1392	the logged-in player. Ext commands can only be processed after a player	1459	the logged-in player. Ext commands can only be processed after a player
1393	has logged in successfully.	1460	has logged in successfully.
1394		1461
1395	If the callback returns something, it is sent back as if reply was being	1462	The values will be sent back to the client.
1396	called.
1397		1463
		1464	=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
		1465
		1466	Same as C<cf::register_extcmd>, but instead of returning values, the
		1467	callback needs to clal the C<$reply> function.
		1468
1398	=item cf::register_exticmd $name => \&callback($ns,$packet);	1469	=item cf::register_exticmd $name => \&callback($ns,@args)
1399		1470
1400	Register a callback for execution when the client sends an (asynchronous)	1471	Register a callback for execution when the client sends an (asynchronous)
1401	exticmd packet. Exti commands are processed by the server as soon as they	1472	exticmd packet. Exti commands are processed by the server as soon as they
1402	are received, i.e. out of order w.r.t. other commands. The first argument	1473	are received, i.e. out of order w.r.t. other commands. The first argument
1403	is a client socket. Exti commands can be received anytime, even before	1474	is a client socket. Exti commands can be received anytime, even before
1404	log-in.	1475	log-in.
1405		1476
1406	If the callback returns something, it is sent back as if reply was being	1477	The values will be sent back to the client.
1407	called.
1408		1478
1409	=cut	1479	=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
1410		1480
		1481	Same as C<cf::register_extcmd>, but instead of returning values, the
		1482	callback needs to clal the C<$reply> function.
		1483
		1484	=cut
		1485
1411	sub register_extcmd {	1486	sub register_extcmd($$) {
1412	my ($name, $cb) = @_;	1487	my ($name, $cb) = @_;
1413		1488
1414	$EXTCMD{$name} = $cb;	1489	$EXTCMD{$name} = $cb;
1415	}	1490	}
1416		1491
1417	sub register_exticmd {	1492	sub register_async_extcmd($$) {
1418	my ($name, $cb) = @_;	1493	my ($name, $cb) = @_;
1419		1494
		1495	$EXTACMD{$name} = $cb;
		1496	}
		1497
		1498	sub register_exticmd($$) {
		1499	my ($name, $cb) = @_;
		1500
1420	$EXTICMD{$name} = $cb;	1501	$EXTICMD{$name} = $cb;
		1502	}
		1503
		1504	sub register_async_exticmd($$) {
		1505	my ($name, $cb) = @_;
		1506
		1507	$EXTIACMD{$name} = $cb;
1421	}	1508	}
1422		1509
1423	use File::Glob ();	1510	use File::Glob ();
1424		1511
1425	cf::player->attach (	1512	cf::player->attach (
…		…
1439	my ($pl, $buf) = @_;	1526	my ($pl, $buf) = @_;
1440		1527
1441	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1528	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1442		1529
1443	if (ref $msg) {	1530	if (ref $msg) {
1444	my ($type, $reply, @payload) =	1531	my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1445	"ARRAY" eq ref $msg
1446	? @$msg
1447	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1448		1532
1449	my @reply;
1450
1451	if (my $cb = $EXTCMD{$type}) {	1533	if (my $cb = $EXTACMD{$type}) {
		1534	$cb->(
		1535	$pl,
		1536	sub {
		1537	$pl->ext_msg ("reply-$reply", @_)
		1538	if $reply;
		1539	},
		1540	@payload
		1541	);
		1542	} else {
		1543	my @reply;
		1544
		1545	if (my $cb = $EXTCMD{$type}) {
1452	@reply = $cb->($pl, @payload);	1546	@reply = $cb->($pl, @payload);
		1547	}
		1548
		1549	$pl->ext_msg ("reply-$reply", @reply)
		1550	if $reply;
1453	}	1551	}
1454
1455	$pl->ext_reply ($reply, @reply)
1456	if $reply;
1457		1552
1458	} else {	1553	} else {
1459	error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1554	error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1460	}	1555	}
1461		1556
…		…
1474	};	1569	};
1475		1570
1476	$grp	1571	$grp
1477	}	1572	}
1478		1573
		1574	sub _ext_cfg_reg($$$$) {
		1575	my ($rvar, $varname, $cfgname, $default) = @_;
		1576
		1577	$cfgname = lc $varname
		1578	unless length $cfgname;
		1579
		1580	$EXT_CFG{$cfgname} = [$rvar, $default];
		1581
		1582	$$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
		1583	}
		1584
1479	sub load_extensions {	1585	sub load_extensions {
1480	info "loading extensions...";	1586	info "loading extensions...";
		1587
		1588	%EXT_CFG = ();
1481		1589
1482	cf::sync_job {	1590	cf::sync_job {
1483	my %todo;	1591	my %todo;
1484		1592
1485	for my $path (<$LIBDIR/*.ext>) {	1593	for my $path (<$LIBDIR/*.ext>) {
…		…
1528	unless exists $done{$_};	1636	unless exists $done{$_};
1529	}	1637	}
1530		1638
1531	trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";	1639	trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1532		1640
		1641	my $source = $v->{source};
		1642
		1643	# support "CONF varname :confname = default" pseudo-statements
		1644	$source =~ s{
		1645	^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
		1646	}{
		1647	"our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
		1648	}gmxe;
		1649
1533	my $active = eval $v->{source};	1650	my $active = eval $source;
1534		1651
1535	if (length $@) {	1652	if (length $@) {
1536	error "$v->{path}: $@\n";	1653	error "$v->{path}: $@\n";
1537		1654
1538	cf::cleanup "mandatory extension '$k' failed to load, exiting."	1655	cf::cleanup "mandatory extension '$k' failed to load, exiting."
…		…
1825	}	1942	}
1826		1943
1827	=item $protocol_xml = $player->expand_cfpod ($cfpod)	1944	=item $protocol_xml = $player->expand_cfpod ($cfpod)
1828		1945
1829	Expand deliantra pod fragments into protocol xml.	1946	Expand deliantra pod fragments into protocol xml.
1830
1831	=item $player->ext_reply ($msgid, @msg)
1832
1833	Sends an ext reply to the player.
1834
1835	=cut
1836
1837	sub ext_reply($$@) {
1838	my ($self, $id, @msg) = @_;
1839
1840	$self->ns->ext_reply ($id, @msg)
1841	}
1842		1947
1843	=item $player->ext_msg ($type, @msg)	1948	=item $player->ext_msg ($type, @msg)
1844		1949
1845	Sends an ext event to the client.	1950	Sends an ext event to the client.
1846		1951
…		…
1954	# {... are special paths that are not being touched	2059	# {... are special paths that are not being touched
1955	# ?xxx/... are special absolute paths	2060	# ?xxx/... are special absolute paths
1956	# ?random/... random maps	2061	# ?random/... random maps
1957	# /... normal maps	2062	# /... normal maps
1958	# ~user/... per-player map of a specific user	2063	# ~user/... per-player map of a specific user
1959	# !up !down for quad maps, or other maps with up/down layers
1960		2064
1961	$path =~ s/$PATH_SEP/\//go;	2065	$path =~ s/$PATH_SEP/\//go;
1962		2066
1963	# treat it as relative path if it starts with	2067	# treat it as relative path if it starts with
1964	# something that looks reasonable	2068	# something that looks reasonable
1965	if ($path =~ m{^(?:\./\|\.\./\|\w)}) {	2069	if ($path =~ m{^(?:\./\|\.\./\|\w)}) {
1966	$base or Carp::carp "normalise called with relative path and no base: '$path'";	2070	$base or Carp::carp "normalise called with relative path and no base: '$path'";
1967		2071
1968	$base =~ s{[^/]+/?$}{};	2072	$base =~ s{[^/]+/?$}{};
1969	$path = "$base/$path";	2073	$path = "$base/$path";
1970
1971	} elsif ($path eq '!up') {
1972	$base && ref $base
1973	or Carp::carp "normalise called with relative tile path and no base: '$path'";
1974
1975	my $uppth = $base->tile_path (cf::TILE_UP);
1976	$path = $uppth if $uppth;
1977
1978	} elsif ($path eq '!down') {
1979	$base && ref $base
1980	or Carp::carp "normalise called with relative tile path and no base: '$path'";
1981
1982	my $dpth = $base->tile_path (cf::TILE_DOWN);
1983	$path = $dpth if $dpth;
1984	}	2074	}
1985		2075
1986	for ($path) {	2076	for ($path) {
1987	redo if s{/\.?/}{/};	2077	redo if s{/\.?/}{/};
1988	redo if s{/[^/]+/\.\./}{/};	2078	redo if s{/[^/]+/\.\./}{/};
…		…
2084	$self->{load_path} = $path;	2174	$self->{load_path} = $path;
2085		2175
2086	1	2176	1
2087	}	2177	}
2088		2178
		2179	# used to laod the header of an original map
2089	sub load_header_orig {	2180	sub load_header_orig {
2090	my ($self) = @_;	2181	my ($self) = @_;
2091		2182
2092	$self->load_header_from ($self->load_path)	2183	$self->load_header_from ($self->load_path)
2093	}	2184	}
2094		2185
		2186	# used to laod the header of an instantiated map
2095	sub load_header_temp {	2187	sub load_header_temp {
2096	my ($self) = @_;	2188	my ($self) = @_;
2097		2189
2098	$self->load_header_from ($self->save_path)	2190	$self->load_header_from ($self->save_path)
2099	}	2191	}
2100		2192
		2193	# called after loading the header from an instantiated map
2101	sub prepare_temp {	2194	sub prepare_temp {
2102	my ($self) = @_;	2195	my ($self) = @_;
2103		2196
2104	$self->last_access ((delete $self->{last_access})	2197	$self->last_access ((delete $self->{last_access})
2105	\|\| $cf::RUNTIME); #d#	2198	\|\| $cf::RUNTIME); #d#
2106	# safety	2199	# safety
2107	$self->{instantiate_time} = $cf::RUNTIME	2200	$self->{instantiate_time} = $cf::RUNTIME
2108	if $self->{instantiate_time} > $cf::RUNTIME;	2201	if $self->{instantiate_time} > $cf::RUNTIME;
2109	}	2202	}
2110		2203
		2204	# called after loading the header from an original map
2111	sub prepare_orig {	2205	sub prepare_orig {
2112	my ($self) = @_;	2206	my ($self) = @_;
2113		2207
2114	$self->{load_original} = 1;	2208	$self->{load_original} = 1;
2115	$self->{instantiate_time} = $cf::RUNTIME;	2209	$self->{instantiate_time} = $cf::RUNTIME;
…		…
2182		2276
2183	{	2277	{
2184	my $guard = cf::lock_acquire "map_data:$path";	2278	my $guard = cf::lock_acquire "map_data:$path";
2185		2279
2186	return unless $self->valid;	2280	return unless $self->valid;
2187	return unless $self->in_memory == cf::MAP_SWAPPED;	2281	return unless $self->state == cf::MAP_SWAPPED;
2188
2189	$self->in_memory (cf::MAP_LOADING);
2190		2282
2191	$self->alloc;	2283	$self->alloc;
2192		2284
2193	$self->pre_load;	2285	$self->pre_load;
2194	cf::cede_to_tick;	2286	cf::cede_to_tick;
…		…
2212	}	2304	}
2213	}	2305	}
2214	}	2306	}
2215		2307
2216	$f->resolve_delayed_derefs;	2308	$f->resolve_delayed_derefs;
		2309	} else {
		2310	$self->post_load_original
		2311	if delete $self->{load_original};
2217	}	2312	}
		2313
		2314	$self->state (cf::MAP_INACTIVE);
2218		2315
2219	cf::cede_to_tick;	2316	cf::cede_to_tick;
2220	# now do the right thing for maps	2317	# now do the right thing for maps
2221	$self->link_multipart_objects;	2318	$self->link_multipart_objects;
2222	$self->difficulty ($self->estimate_difficulty)	2319	$self->difficulty ($self->estimate_difficulty)
…		…
2226	unless ($self->{deny_activate}) {	2323	unless ($self->{deny_activate}) {
2227	$self->decay_objects;	2324	$self->decay_objects;
2228	$self->fix_auto_apply;	2325	$self->fix_auto_apply;
2229	$self->update_buttons;	2326	$self->update_buttons;
2230	cf::cede_to_tick;	2327	cf::cede_to_tick;
2231	$self->activate;	2328	#$self->activate; # no longer activate maps automatically
2232	}	2329	}
2233		2330
2234	$self->{last_save} = $cf::RUNTIME;	2331	$self->{last_save} = $cf::RUNTIME;
2235	$self->last_access ($cf::RUNTIME);	2332	$self->last_access ($cf::RUNTIME);
2236
2237	$self->in_memory (cf::MAP_ACTIVE);
2238	}	2333	}
2239		2334
2240	$self->post_load;	2335	$self->post_load;
2241		2336
2242	1	2337	1
…		…
2255	# if $self->per_party;	2350	# if $self->per_party;
2256		2351
2257	$self	2352	$self
2258	}	2353	}
2259		2354
2260	# find and load all maps in the 3x3 area around a map
2261	sub load_neighbours {
2262	my ($map) = @_;
2263
2264	my @neigh; # diagonal neighbours
2265
2266	for (0 .. 3) {
2267	my $neigh = $map->tile_path ($_)
2268	or next;
2269	$neigh = find $neigh, $map
2270	or next;
2271	$neigh->load;
2272
2273	# now find the diagonal neighbours
2274	push @neigh,
2275	[$neigh->tile_path (($_ + 3) % 4), $neigh],
2276	[$neigh->tile_path (($_ + 1) % 4), $neigh];
2277	}
2278
2279	for (grep defined $_->[0], @neigh) {
2280	my ($path, $origin) = @$_;
2281	my $neigh = find $path, $origin
2282	or next;
2283	$neigh->load;
2284	}
2285	}
2286
2287	sub find_sync {	2355	sub find_sync {
2288	my ($path, $origin) = @_;	2356	my ($path, $origin) = @_;
2289		2357
		2358	# it's a bug to call this from the main context
2290	return cf::LOG cf::llevError \| cf::logBacktrace, "do_find_sync"	2359	return cf::LOG cf::llevError \| cf::logBacktrace, "do_find_sync"
2291	if $Coro::current == $Coro::main;	2360	if $Coro::current == $Coro::main;
2292		2361
2293	find $path, $origin	2362	find $path, $origin
2294	}	2363	}
2295		2364
2296	sub do_load_sync {	2365	sub do_load_sync {
2297	my ($map) = @_;	2366	my ($map) = @_;
2298		2367
		2368	# it's a bug to call this from the main context
2299	return cf::LOG cf::llevError \| cf::logBacktrace, "do_load_sync"	2369	return cf::LOG cf::llevError \| cf::logBacktrace, "do_load_sync"
2300	if $Coro::current == $Coro::main;	2370	if $Coro::current == $Coro::main;
2301		2371
2302	$map->load;	2372	$map->load;
2303	}	2373	}
…		…
2309	my ($path, $origin, $load) = @_;	2379	my ($path, $origin, $load) = @_;
2310		2380
2311	$path = normalise $path, $origin;	2381	$path = normalise $path, $origin;
2312		2382
2313	if (my $map = $cf::MAP{$path}) {	2383	if (my $map = $cf::MAP{$path}) {
2314	return $map if !$load \|\| $map->in_memory == cf::MAP_ACTIVE;	2384	return $map if !$load \|\| $map->linkable;
2315	}	2385	}
2316		2386
2317	$MAP_PREFETCH{$path} \|= $load;	2387	$MAP_PREFETCH{$path} \|= $load;
2318		2388
2319	$MAP_PREFETCHER \|\|= cf::async {	2389	$MAP_PREFETCHER \|\|= cf::async {
…		…
2378	sub swap_out {	2448	sub swap_out {
2379	my ($self) = @_;	2449	my ($self) = @_;
2380		2450
2381	my $lock = cf::lock_acquire "map_data:$self->{path}";	2451	my $lock = cf::lock_acquire "map_data:$self->{path}";
2382		2452
2383	return if $self->in_memory != cf::MAP_ACTIVE;	2453	return if !$self->linkable;
2384	return if $self->{deny_save};	2454	return if $self->{deny_save};
2385	return if $self->players;	2455	return if $self->players;
2386		2456
2387	# first deactivate the map and "unlink" it from the core	2457	# first deactivate the map and "unlink" it from the core
2388	$self->deactivate;	2458	$self->deactivate;
2389	$_->clear_links_to ($self) for values %cf::MAP;	2459	$_->clear_links_to ($self) for values %cf::MAP;
2390	$self->in_memory (cf::MAP_SWAPPED);	2460	$self->state (cf::MAP_SWAPPED);
2391		2461
2392	# then atomically save	2462	# then atomically save
2393	$self->_save;	2463	$self->_save;
2394		2464
2395	# then free the map	2465	# then free the map
…		…
2421		2491
2422	return if $self->players;	2492	return if $self->players;
2423		2493
2424	cf::trace "resetting map ", $self->path, "\n";	2494	cf::trace "resetting map ", $self->path, "\n";
2425		2495
2426	$self->in_memory (cf::MAP_SWAPPED);	2496	$self->state (cf::MAP_SWAPPED);
2427		2497
2428	# need to save uniques path	2498	# need to save uniques path
2429	unless ($self->{deny_save}) {	2499	unless ($self->{deny_save}) {
2430	my $uniq = $self->uniq_path; utf8::encode $uniq;	2500	my $uniq = $self->uniq_path; utf8::encode $uniq;
2431		2501
…		…
2761	# use -1 or undef as default coordinates, not 0, 0	2831	# use -1 or undef as default coordinates, not 0, 0
2762	($x, $y) = ($map->enter_x, $map->enter_y)	2832	($x, $y) = ($map->enter_x, $map->enter_y)
2763	if $x <= 0 && $y <= 0;	2833	if $x <= 0 && $y <= 0;
2764		2834
2765	$map->load;	2835	$map->load;
2766	$map->load_neighbours;
2767		2836
2768	return unless $self->contr->active;	2837	return unless $self->contr->active;
2769		2838
2770	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2839	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2771	if ($self->enter_map ($map, $x, $y)) {	2840	if ($self->enter_map ($map, $x, $y)) {
…		…
2927	$Coro::current->{desc} = "enter_exit";	2996	$Coro::current->{desc} = "enter_exit";
2928		2997
2929	unless (eval {	2998	unless (eval {
2930	$self->deactivate_recursive; # just to be sure	2999	$self->deactivate_recursive; # just to be sure
2931		3000
2932	# random map handling
2933	{
2934	my $guard = cf::lock_acquire "exit_prepare:$exit";
2935
2936	prepare_random_map $exit
2937	if $exit->slaying eq "/!";
2938	}
2939
2940	my $map = cf::map::normalise $exit->slaying, $exit->map;	3001	my $map = cf::map::normalise $exit->slaying, $exit->map;
2941	my $x = $exit->stats->hp;	3002	my $x = $exit->stats->hp;
2942	my $y = $exit->stats->sp;	3003	my $y = $exit->stats->sp;
		3004
		3005	# special map handling
		3006	my $slaying = $exit->slaying;
		3007
		3008	# special map handling
		3009	if ($slaying eq "/!") {
		3010	my $guard = cf::lock_acquire "exit_prepare:$exit";
		3011
		3012	prepare_random_map $exit
		3013	if $exit->slaying eq "/!"; # need to re-check after getting the lock
		3014
		3015	$map = $exit->slaying;
		3016
		3017	} elsif ($slaying eq '!up') {
		3018	$map = $exit->map->tile_path (cf::TILE_UP);
		3019	$x = $exit->x;
		3020	$y = $exit->y;
		3021
		3022	} elsif ($slaying eq '!down') {
		3023	$map = $exit->map->tile_path (cf::TILE_DOWN);
		3024	$x = $exit->x;
		3025	$y = $exit->y;
		3026	}
2943		3027
2944	$self->goto ($map, $x, $y);	3028	$self->goto ($map, $x, $y);
2945		3029
2946	# if exit is damned, update players death & WoR home-position	3030	# if exit is damned, update players death & WoR home-position
2947	$self->contr->savebed ($map, $x, $y)	3031	$self->contr->savebed ($map, $x, $y)
…		…
3172	=cut	3256	=cut
3173		3257
3174	sub cf::client::ext_msg($$@) {	3258	sub cf::client::ext_msg($$@) {
3175	my ($self, $type, @msg) = @_;	3259	my ($self, $type, @msg) = @_;
3176		3260
3177	if ($self->extcmd == 2) {
3178	$self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));	3261	$self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3179	} elsif ($self->extcmd == 1) { # TODO: remove
3180	push @msg, msgtype => "event_$type";
3181	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3182	}
3183	}
3184
3185	=item $client->ext_reply ($msgid, @msg)
3186
3187	Sends an ext reply to the client.
3188
3189	=cut
3190
3191	sub cf::client::ext_reply($$@) {
3192	my ($self, $id, @msg) = @_;
3193
3194	if ($self->extcmd == 2) {
3195	$self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3196	} elsif ($self->extcmd == 1) {
3197	#TODO: version 1, remove
3198	unshift @msg, msgtype => "reply", msgid => $id;
3199	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3200	}
3201	}	3262	}
3202		3263
3203	=item $success = $client->query ($flags, "text", \&cb)	3264	=item $success = $client->query ($flags, "text", \&cb)
3204		3265
3205	Queues a query to the client, calling the given callback with	3266	Queues a query to the client, calling the given callback with
…		…
3260	my ($ns, $buf) = @_;	3321	my ($ns, $buf) = @_;
3261		3322
3262	my $msg = eval { $ns->{json_coder}->decode ($buf) };	3323	my $msg = eval { $ns->{json_coder}->decode ($buf) };
3263		3324
3264	if (ref $msg) {	3325	if (ref $msg) {
3265	my ($type, $reply, @payload) =	3326	my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3266	"ARRAY" eq ref $msg
3267	? @$msg
3268	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3269		3327
3270	my @reply;
3271
3272	if (my $cb = $EXTICMD{$type}) {	3328	if (my $cb = $EXTIACMD{$type}) {
		3329	$cb->(
		3330	$ns,
		3331	sub {
		3332	$ns->ext_msg ("reply-$reply", @_)
		3333	if $reply;
		3334	},
		3335	@payload
		3336	);
		3337	} else {
		3338	my @reply;
		3339
		3340	if (my $cb = $EXTICMD{$type}) {
3273	@reply = $cb->($ns, @payload);	3341	@reply = $cb->($ns, @payload);
		3342	}
		3343
		3344	$ns->ext_msg ("reply-$reply", @reply)
		3345	if $reply;
3274	}	3346	}
3275
3276	$ns->ext_reply ($reply, @reply)
3277	if $reply;
3278
3279	} else {	3347	} else {
3280	error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	3348	error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3281	}	3349	}
3282		3350
3283	cf::override;	3351	cf::override;
…		…
3451	=cut	3519	=cut
3452		3520
3453	#############################################################################	3521	#############################################################################
3454	# the server's init and main functions	3522	# the server's init and main functions
3455		3523
		3524	our %FACEHASH; # hash => idx, #d# HACK for http server
		3525
		3526	# internal api, not fianlised
		3527	sub set_face {
		3528	my ($name, $type, $data) = @_;
		3529
		3530	my $idx = cf::face::find $name;
		3531
		3532	if ($idx) {
		3533	delete $FACEHASH{cf::face::get_chksum $idx};
		3534	} else {
		3535	$idx = cf::face::alloc $name;
		3536	}
		3537
		3538	my $hash = cf::face::mangle_chksum Digest::MD5::md5 $data;
		3539
		3540	cf::face::set_type $idx, $type;
		3541	cf::face::set_data $idx, 0, $data, $hash;
		3542	cf::face::set_meta $idx, $type & 1 ? undef : undef;
		3543	$FACEHASH{$hash} = $idx;#d#
		3544
		3545	$idx
		3546	}
		3547
3456	sub load_facedata($) {	3548	sub load_facedata($) {
3457	my ($path) = @_;	3549	my ($path) = @_;
3458		3550
3459	# HACK to clear player env face cache, we need some signal framework	3551	# HACK to clear player env face cache, we need some signal framework
3460	# for this (global event?)	3552	# for this (global event?)
…		…
3467	my $facedata = decode_storable load_file $path;	3559	my $facedata = decode_storable load_file $path;
3468		3560
3469	$facedata->{version} == 2	3561	$facedata->{version} == 2
3470	or cf::cleanup "$path: version mismatch, cannot proceed.";	3562	or cf::cleanup "$path: version mismatch, cannot proceed.";
3471		3563
3472	# patch in the exptable
3473	my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3474	$facedata->{resource}{"res/exp_table"} = {
3475	type => FT_RSRC,
3476	data => $exp_table,
3477	hash => (Digest::MD5::md5 $exp_table),
3478	};
3479	cf::cede_to_tick;	3564	cf::cede_to_tick;
3480		3565
3481	{	3566	{
3482	my $faces = $facedata->{faceinfo};	3567	my $faces = delete $facedata->{faceinfo};
3483		3568
3484	while (my ($face, $info) = each %$faces) {	3569	for my $face (sort keys %$faces) {
		3570	my $info = $faces->{$face};
3485	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	3571	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
3486		3572
3487	cf::face::set_visibility $idx, $info->{visibility};	3573	cf::face::set_visibility $idx, $info->{visibility};
3488	cf::face::set_magicmap $idx, $info->{magicmap};	3574	cf::face::set_magicmap $idx, $info->{magicmap};
3489	cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};	3575	cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3490	cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};	3576	cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3491	cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;	3577	cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3492		3578	$FACEHASH{$info->{hash64}} = $idx;#d#
		3579
3493	cf::cede_to_tick;	3580	cf::cede_to_tick;
3494	}	3581	}
3495		3582
3496	while (my ($face, $info) = each %$faces) {	3583	while (my ($face, $info) = each %$faces) {
3497	next unless $info->{smooth};	3584	next unless $info->{smooth};
…		…
3509	cf::cede_to_tick;	3596	cf::cede_to_tick;
3510	}	3597	}
3511	}	3598	}
3512		3599
3513	{	3600	{
3514	my $anims = $facedata->{animinfo};	3601	my $anims = delete $facedata->{animinfo};
3515		3602
3516	while (my ($anim, $info) = each %$anims) {	3603	while (my ($anim, $info) = each %$anims) {
3517	cf::anim::set $anim, $info->{frames}, $info->{facings};	3604	cf::anim::set $anim, $info->{frames}, $info->{facings};
3518	cf::cede_to_tick;	3605	cf::cede_to_tick;
3519	}	3606	}
3520		3607
3521	cf::anim::invalidate_all; # d'oh	3608	cf::anim::invalidate_all; # d'oh
3522	}	3609	}
3523		3610
3524	{	3611	{
3525	my $res = $facedata->{resource};	3612	my $res = delete $facedata->{resource};
3526		3613
3527	while (my ($name, $info) = each %$res) {	3614	while (my ($name, $info) = each %$res) {
3528	if (defined $info->{type}) {	3615	if (defined (my $type = $info->{type})) {
		3616	# TODO: different hash - must free and use new index, or cache ixface data queue
3529	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	3617	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
3530		3618
		3619	cf::face::set_type $idx, $type;
3531	cf::face::set_data $idx, 0, $info->{data}, $info->{hash};	3620	cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3532	cf::face::set_type $idx, $info->{type};	3621	cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
		3622	$FACEHASH{$info->{hash}} = $idx;#d#
3533	} else {	3623	} else {
3534	$RESOURCE{$name} = $info; # unused	3624	# $RESOURCE{$name} = $info; # unused
3535	}	3625	}
3536		3626
3537	cf::cede_to_tick;	3627	cf::cede_to_tick;
3538	}	3628	}
3539	}	3629	}
…		…
3557	my $status = load_resource_file_ $_[0];	3647	my $status = load_resource_file_ $_[0];
3558	get_slot 0.1, 100;	3648	get_slot 0.1, 100;
3559	cf::arch::commit_load;	3649	cf::arch::commit_load;
3560		3650
3561	$status	3651	$status
		3652	}
		3653
		3654	sub reload_exp_table {
		3655	_reload_exp_table;
		3656
		3657	set_face "res/exp_table" => FT_RSRC,
		3658	JSON::XS->new->utf8->canonical->encode (
		3659	[map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
		3660	);
		3661	}
		3662
		3663	sub reload_materials {
		3664	_reload_materials;
3562	}	3665	}
3563		3666
3564	sub reload_regions {	3667	sub reload_regions {
3565	# HACK to clear player env face cache, we need some signal framework	3668	# HACK to clear player env face cache, we need some signal framework
3566	# for this (global event?)	3669	# for this (global event?)
…		…
3581	}	3684	}
3582		3685
3583	sub reload_archetypes {	3686	sub reload_archetypes {
3584	load_resource_file "$DATADIR/archetypes"	3687	load_resource_file "$DATADIR/archetypes"
3585	or die "unable to load archetypes\n";	3688	or die "unable to load archetypes\n";
		3689
		3690	set_face "res/skill_info" => FT_RSRC,
		3691	JSON::XS->new->utf8->canonical->encode (
		3692	[map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
		3693	);
		3694	set_face "res/spell_paths" => FT_RSRC,
		3695	JSON::XS->new->utf8->canonical->encode (
		3696	[map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
		3697	);
3586	}	3698	}
3587		3699
3588	sub reload_treasures {	3700	sub reload_treasures {
3589	load_resource_file "$DATADIR/treasures"	3701	load_resource_file "$DATADIR/treasures"
3590	or die "unable to load treasurelists\n";	3702	or die "unable to load treasurelists\n";
…		…
3611	}	3723	}
3612		3724
3613	sub reload_resources {	3725	sub reload_resources {
3614	trace "reloading resource files...\n";	3726	trace "reloading resource files...\n";
3615		3727
3616	reload_exp_table;
3617	reload_materials;	3728	reload_materials;
3618	reload_facedata;	3729	reload_facedata;
		3730	reload_exp_table;
3619	reload_sound;	3731	reload_sound;
3620	reload_archetypes;	3732	reload_archetypes;
3621	reload_regions;	3733	reload_regions;
3622	reload_treasures;	3734	reload_treasures;
3623		3735
…		…
3675		3787
3676	sub main {	3788	sub main {
3677	cf::init_globals; # initialise logging	3789	cf::init_globals; # initialise logging
3678		3790
3679	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;	3791	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3680	LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";	3792	LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3681	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";	3793	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3682	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";	3794	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3683		3795
3684	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority	3796	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3685		3797
3686	# we must not ever block the main coroutine	3798	# we must not ever block the main coroutine
3687	local $Coro::idle = sub {	3799	$Coro::idle = sub {
3688	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#	3800	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3689	(async {	3801	(async {
3690	$Coro::current->{desc} = "IDLE BUG HANDLER";	3802	$Coro::current->{desc} = "IDLE BUG HANDLER";
3691	EV::loop EV::LOOP_ONESHOT;	3803	EV::loop EV::LOOP_ONESHOT;
3692	})->prio (Coro::PRIO_MAX);	3804	})->prio (Coro::PRIO_MAX);
…		…
3695	evthread_start IO::AIO::poll_fileno;	3807	evthread_start IO::AIO::poll_fileno;
3696		3808
3697	cf::sync_job {	3809	cf::sync_job {
3698	cf::incloader::init ();	3810	cf::incloader::init ();
3699		3811
		3812	db_init;
		3813
3700	cf::init_anim;	3814	cf::init_anim;
3701	cf::init_attackmess;	3815	cf::init_attackmess;
3702	cf::init_dynamic;	3816	cf::init_dynamic;
3703		3817
3704	cf::load_settings;	3818	cf::load_settings;
3705		3819
3706	reload_resources;	3820	reload_resources;
3707	reload_config;	3821	reload_config;
3708	db_init;
3709		3822
3710	cf::init_uuid;	3823	cf::init_uuid;
3711	cf::init_signals;	3824	cf::init_signals;
3712	cf::init_skills;	3825	cf::init_skills;
3713		3826
…		…
3727	};	3840	};
3728		3841
3729	cf::object::thawer::errors_are_fatal 0;	3842	cf::object::thawer::errors_are_fatal 0;
3730	info "parse errors in files are no longer fatal from this point on.\n";	3843	info "parse errors in files are no longer fatal from this point on.\n";
3731		3844
3732	my $free_main; $free_main = EV::idle sub {	3845	AE::postpone {
3733	undef $free_main;
3734	undef &main; # free gobs of memory :)	3846	undef &main; # free gobs of memory :)
3735	};	3847	};
3736		3848
3737	goto &main_loop;	3849	goto &main_loop;
3738	}	3850	}
…		…
3895		4007
3896	cf::write_runtime_sync; # external watchdog should not bark	4008	cf::write_runtime_sync; # external watchdog should not bark
3897		4009
3898	trace "emergency_perl_save: flushing outstanding aio requests";	4010	trace "emergency_perl_save: flushing outstanding aio requests";
3899	while (IO::AIO::nreqs \|\| BDB::nreqs) {	4011	while (IO::AIO::nreqs \|\| BDB::nreqs) {
3900	Coro::EV::timer_once 0.01; # let the sync_job do it's thing	4012	Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
3901	}	4013	}
3902		4014
3903	cf::write_runtime_sync; # external watchdog should not bark	4015	cf::write_runtime_sync; # external watchdog should not bark
3904	};	4016	};
3905		4017
…		…
4086		4198
4087	#############################################################################	4199	#############################################################################
4088		4200
4089	my $bug_warning = 0;	4201	my $bug_warning = 0;
4090		4202
4091	our @WAIT_FOR_TICK;
4092	our @WAIT_FOR_TICK_BEGIN;
4093
4094	sub wait_for_tick() {	4203	sub wait_for_tick() {
4095	return Coro::cede if tick_inhibit \|\| $Coro::current == $Coro::main;	4204	return Coro::AnyEvent::poll if tick_inhibit \|\| $Coro::current == $Coro::main;
4096		4205
4097	my $signal = new Coro::Signal;	4206	$WAIT_FOR_TICK->wait;
4098	push @WAIT_FOR_TICK, $signal;
4099	$signal->wait;
4100	}	4207	}
4101		4208
4102	sub wait_for_tick_begin() {	4209	sub wait_for_tick_begin() {
4103	return Coro::cede if tick_inhibit \|\| $Coro::current == $Coro::main;	4210	return Coro::AnyEvent::poll if tick_inhibit \|\| $Coro::current == $Coro::main;
4104		4211
4105	my $signal = new Coro::Signal;	4212	my $signal = new Coro::Signal;
4106	push @WAIT_FOR_TICK_BEGIN, $signal;	4213	push @WAIT_FOR_TICK_BEGIN, $signal;
4107	$signal->wait;	4214	$signal->wait;
4108	}	4215	}
…		…
4112	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"	4219	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4113	unless ++$bug_warning > 10;	4220	unless ++$bug_warning > 10;
4114	return;	4221	return;
4115	}	4222	}
4116		4223
4117	cf::server_tick; # one server iteration	4224	cf::one_tick; # one server iteration
4118		4225
4119	#for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#	4226	#for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4120		4227
4121	if ($NOW >= $NEXT_RUNTIME_WRITE) {	4228	if ($NOW >= $NEXT_RUNTIME_WRITE) {
4122	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;	4229	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
…		…
4128	}	4235	}
4129		4236
4130	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	4237	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4131	$sig->send;	4238	$sig->send;
4132	}	4239	}
4133	while (my $sig = shift @WAIT_FOR_TICK) {	4240	$WAIT_FOR_TICK->broadcast;
4134	$sig->send;
4135	}
4136		4241
4137	$LOAD = ($NOW - $TICK_START) / $TICK;	4242	$LOAD = ($NOW - $TICK_START) / $TICK;
4138	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	4243	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4139		4244
4140	if (0) {	4245	if (0) {
…		…
4146	}	4251	}
4147	}	4252	}
4148		4253
4149	{	4254	{
4150	# configure BDB	4255	# configure BDB
		4256	info "initialising database";
4151		4257
4152	BDB::min_parallel 16;	4258	BDB::min_parallel 16;
4153	BDB::max_poll_reqs $TICK * 0.1;	4259	BDB::max_poll_reqs $TICK * 0.1;
4154	$AnyEvent::BDB::WATCHER->priority (1);	4260	#$AnyEvent::BDB::WATCHER->priority (1);
4155		4261
4156	unless ($DB_ENV) {	4262	unless ($DB_ENV) {
4157	$DB_ENV = BDB::db_env_create;	4263	$DB_ENV = BDB::db_env_create;
4158	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT);	4264	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT);
4159	$DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;	4265	$DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
…		…
4184	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };	4290	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4185	};	4291	};
4186	$BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {	4292	$BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4187	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };	4293	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4188	};	4294	};
		4295
		4296	info "database initialised";
4189	}	4297	}
4190		4298
4191	{	4299	{
4192	# configure IO::AIO	4300	# configure IO::AIO
4193		4301
		4302	info "initialising aio";
4194	IO::AIO::min_parallel 8;	4303	IO::AIO::min_parallel 8;
4195	IO::AIO::max_poll_time $TICK * 0.1;	4304	IO::AIO::max_poll_time $TICK * 0.1;
4196	undef $AnyEvent::AIO::WATCHER;	4305	undef $AnyEvent::AIO::WATCHER;
		4306	info "aio initialised";
4197	}	4307	}
4198		4308
4199	our $_log_backtrace;	4309	our $_log_backtrace;
4200	our $_log_backtrace_last;	4310	our $_log_backtrace_last;
4201		4311

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.565 by root, Sat Apr 30 05:41:17 2011 UTC vs. Revision 1.597 by root, Sun Nov 11 02:14:37 2012 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.565 by root, Sat Apr 30 05:41:17 2011 UTC vs.
Revision 1.597 by root, Sun Nov 11 02:14:37 2012 UTC