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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.449 by root, Sat Sep 20 00:09:27 2008 UTC vs.
Revision 1.502 by root, Sat Jan 23 20:24:50 2010 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 Marc Alexander Lehmann / Robin Redeker / the Deliantra team	4	# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5	#	5	#
6	# Deliantra is free software: you can redistribute it and/or modify	6	# Deliantra is free software: you can redistribute it and/or modify it under
7	# it under the terms of the GNU General Public License as published by	7	# the terms of the Affero GNU General Public License as published by the
8	# the Free Software Foundation, either version 3 of the License, or	8	# Free Software Foundation, either version 3 of the License, or (at your
9	# (at your 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 GNU General Public License	16	# You should have received a copy of the Affero GNU General Public License
17	# along with this program. If not, see <http://www.gnu.org/licenses/>.	17	# and the GNU General Public License along with this program. If not, see
		18	# <http://www.gnu.org/licenses/>.
18	#	19	#
19	# 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>
20	#	21	#
21		22
22	package cf;	23	package cf;
23		24
24	use 5.10.0;	25	use 5.10.0;
25	use utf8;	26	use utf8;
26	use strict "vars", "subs";	27	use strict qw(vars subs);
27		28
28	use Symbol;	29	use Symbol;
29	use List::Util;	30	use List::Util;
30	use Socket;	31	use Socket;
31	use EV;	32	use EV;
32	use Opcode;	33	use Opcode;
33	use Safe;	34	use Safe;
34	use Safe::Hole;	35	use Safe::Hole;
35	use Storable ();	36	use Storable ();
		37	use Carp ();
36		38
		39	use Guard ();
37	use Coro ();	40	use Coro ();
38	use Coro::State;	41	use Coro::State;
39	use Coro::Handle;	42	use Coro::Handle;
40	use Coro::EV;	43	use Coro::EV;
41	use Coro::AnyEvent;	44	use Coro::AnyEvent;
42	use Coro::Timer;	45	use Coro::Timer;
43	use Coro::Signal;	46	use Coro::Signal;
44	use Coro::Semaphore;	47	use Coro::Semaphore;
		48	use Coro::SemaphoreSet;
45	use Coro::AnyEvent;	49	use Coro::AnyEvent;
46	use Coro::AIO;	50	use Coro::AIO;
47	use Coro::BDB 1.6;	51	use Coro::BDB 1.6;
48	use Coro::Storable;	52	use Coro::Storable;
49	use Coro::Util ();	53	use Coro::Util ();
50		54
51	use JSON::XS 2.01 ();	55	use JSON::XS 2.01 ();
52	use BDB ();	56	use BDB ();
53	use Data::Dumper;	57	use Data::Dumper;
54	use Digest::MD5;
55	use Fcntl;	58	use Fcntl;
56	use YAML ();	59	use YAML::XS ();
57	use IO::AIO ();	60	use IO::AIO ();
58	use Time::HiRes;	61	use Time::HiRes;
59	use Compress::LZF;	62	use Compress::LZF;
60	use Digest::MD5 ();	63	use Digest::MD5 ();
61		64
69	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority	72	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
70		73
71	# make sure c-lzf reinitialises itself	74	# make sure c-lzf reinitialises itself
72	Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";	75	Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
73	Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later	76	Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
		77
		78	# strictly for debugging
		79	$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
74		80
75	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	81	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
76		82
77	our %COMMAND = ();	83	our %COMMAND = ();
78	our %COMMAND_TIME = ();	84	our %COMMAND_TIME = ();
…		…
81	our %EXTCMD = ();	87	our %EXTCMD = ();
82	our %EXTICMD = ();	88	our %EXTICMD = ();
83	our %EXT_CORO = (); # coroutines bound to extensions	89	our %EXT_CORO = (); # coroutines bound to extensions
84	our %EXT_MAP = (); # pluggable maps	90	our %EXT_MAP = (); # pluggable maps
85		91
86	our $RELOAD; # number of reloads so far	92	our $RELOAD; # number of reloads so far, non-zero while in reload
87	our @EVENT;	93	our @EVENT;
		94	our @REFLECT; # set by XS
		95	our %REFLECT; # set by us
88		96
89	our $CONFDIR = confdir;	97	our $CONFDIR = confdir;
90	our $DATADIR = datadir;	98	our $DATADIR = datadir;
91	our $LIBDIR = "$DATADIR/ext";	99	our $LIBDIR = "$DATADIR/ext";
92	our $PODDIR = "$DATADIR/pod";	100	our $PODDIR = "$DATADIR/pod";
…		…
103	our %RESOURCE;	111	our %RESOURCE;
104		112
105	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	113	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
106	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	114	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
107	our $NEXT_TICK;	115	our $NEXT_TICK;
108	our $USE_FSYNC = 1; # use fsync to write maps - default off	116	our $USE_FSYNC = 1; # use fsync to write maps - default on
109		117
110	our $BDB_DEADLOCK_WATCHER;	118	our $BDB_DEADLOCK_WATCHER;
111	our $BDB_CHECKPOINT_WATCHER;	119	our $BDB_CHECKPOINT_WATCHER;
112	our $BDB_TRICKLE_WATCHER;	120	our $BDB_TRICKLE_WATCHER;
113	our $DB_ENV;	121	our $DB_ENV;
114		122
		123	our @EXTRA_MODULES = qw(pod match mapscript);
		124
115	our %CFG;	125	our %CFG;
116		126
117	our $UPTIME; $UPTIME \|\|= time;	127	our $UPTIME; $UPTIME \|\|= time;
118	our $RUNTIME;	128	our $RUNTIME;
119	our $NOW;	129	our $NOW;
…		…
127		137
128	our $LOAD; # a number between 0 (idle) and 1 (too many objects)	138	our $LOAD; # a number between 0 (idle) and 1 (too many objects)
129	our $LOADAVG; # same thing, but with alpha-smoothing	139	our $LOADAVG; # same thing, but with alpha-smoothing
130	our $JITTER; # average jitter	140	our $JITTER; # average jitter
131	our $TICK_START; # for load detecting purposes	141	our $TICK_START; # for load detecting purposes
		142
		143	our @POST_INIT;
		144
		145	our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
		146	our $REALLY_UNLOOP; # never set to true, please :)
132		147
133	binmode STDOUT;	148	binmode STDOUT;
134	binmode STDERR;	149	binmode STDERR;
135		150
136	# read virtual server time, if available	151	# read virtual server time, if available
…		…
138	open my $fh, "<", $RUNTIMEFILE	153	open my $fh, "<", $RUNTIMEFILE
139	or die "unable to read $RUNTIMEFILE file: $!";	154	or die "unable to read $RUNTIMEFILE file: $!";
140	$RUNTIME = <$fh> + 0.;	155	$RUNTIME = <$fh> + 0.;
141	}	156	}
142		157
		158	eval "sub TICK() { $TICK } 1" or die;
		159
143	mkdir $_	160	mkdir $_
144	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;	161	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
145		162
146	our $EMERGENCY_POSITION;	163	our $EMERGENCY_POSITION;
147		164
148	sub cf::map::normalise;	165	sub cf::map::normalise;
		166
		167	#############################################################################
		168
		169	%REFLECT = ();
		170	for (@REFLECT) {
		171	my $reflect = JSON::XS::decode_json $_;
		172	$REFLECT{$reflect->{class}} = $reflect;
		173	}
		174
		175	# this is decidedly evil
		176	$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
149		177
150	#############################################################################	178	#############################################################################
151		179
152	=head2 GLOBAL VARIABLES	180	=head2 GLOBAL VARIABLES
153		181
…		…
200	returns directly I<after> the tick processing (and consequently, can only wake one process	228	returns directly I<after> the tick processing (and consequently, can only wake one process
201	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	229	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
202		230
203	=item @cf::INVOKE_RESULTS	231	=item @cf::INVOKE_RESULTS
204		232
205	This array contains the results of the last C<invoke ()> call. When	233	This array contains the results of the last C<invoke ()> call. When
206	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of	234	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
207	that call.	235	that call.
208		236
		237	=item %cf::REFLECT
		238
		239	Contains, for each (C++) class name, a hash reference with information
		240	about object members (methods, scalars, arrays and flags) and other
		241	metadata, which is useful for introspection.
		242
209	=back	243	=back
210		244
211	=cut	245	=cut
212		246
213	BEGIN {	247	$Coro::State::WARNHOOK = sub {
214	*CORE::GLOBAL::warn = sub {
215	my $msg = join "", @_;	248	my $msg = join "", @_;
216		249
217	$msg .= "\n"	250	$msg .= "\n"
218	unless $msg =~ /\n$/;	251	unless $msg =~ /\n$/;
219		252
220	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;	253	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
221		254
222	LOG llevError, $msg;	255	LOG llevError, $msg;
223	};	256	};
224	}
225		257
226	$Coro::State::DIEHOOK = sub {	258	$Coro::State::DIEHOOK = sub {
227	return unless $^S eq 0; # "eq", not "=="	259	return unless $^S eq 0; # "eq", not "=="
		260
		261	warn Carp::longmess $_[0];
228		262
229	if ($Coro::current == $Coro::main) {#d#	263	if ($Coro::current == $Coro::main) {#d#
230	warn "DIEHOOK called in main context, Coro bug?\n";#d#	264	warn "DIEHOOK called in main context, Coro bug?\n";#d#
231	return;#d#	265	return;#d#
232	}#d#	266	}#d#
233		267
234	# kill coroutine otherwise	268	# kill coroutine otherwise
235	warn Carp::longmess $_[0];
236	Coro::terminate	269	Coro::terminate
237	};	270	};
238
239	$SIG{__DIE__} = sub { }; #d#?
240		271
241	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	272	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
242	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';	273	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
243	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';	274	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
244	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';	275	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
…		…
258	)) {	289	)) {
259	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	290	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
260	}	291	}
261		292
262	$EV::DIED = sub {	293	$EV::DIED = sub {
263	warn "error in event callback: @_";	294	Carp::cluck "error in event callback: @_";
264	};	295	};
265		296
266	#############################################################################	297	#############################################################################
267		298
268	=head2 UTILITY FUNCTIONS	299	=head2 UTILITY FUNCTIONS
…		…
305	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max	336	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
306		337
307	sub encode_json($) { $json_coder->encode ($_[0]) }	338	sub encode_json($) { $json_coder->encode ($_[0]) }
308	sub decode_json($) { $json_coder->decode ($_[0]) }	339	sub decode_json($) { $json_coder->decode ($_[0]) }
309		340
		341	=item cf::post_init { BLOCK }
		342
		343	Execute the given codeblock, I<after> all extensions have been (re-)loaded,
		344	but I<before> the server starts ticking again.
		345
		346	The cdoeblock will have a single boolean argument to indicate whether this
		347	is a reload or not.
		348
		349	=cut
		350
		351	sub post_init(&) {
		352	push @POST_INIT, shift;
		353	}
		354
310	=item cf::lock_wait $string	355	=item cf::lock_wait $string
311		356
312	Wait until the given lock is available. See cf::lock_acquire.	357	Wait until the given lock is available. See cf::lock_acquire.
313		358
314	=item my $lock = cf::lock_acquire $string	359	=item my $lock = cf::lock_acquire $string
315		360
316	Wait until the given lock is available and then acquires it and returns	361	Wait until the given lock is available and then acquires it and returns
317	a Coro::guard object. If the guard object gets destroyed (goes out of scope,	362	a L<Guard> object. If the guard object gets destroyed (goes out of scope,
318	for example when the coroutine gets canceled), the lock is automatically	363	for example when the coroutine gets canceled), the lock is automatically
319	returned.	364	returned.
320		365
321	Locks are not recursive, locking from the same coro twice results in a	366	Locks are not recursive, locking from the same coro twice results in a
322	deadlocked coro.	367	deadlocked coro.
…		…
328		373
329	Return true if the lock is currently active, i.e. somebody has locked it.	374	Return true if the lock is currently active, i.e. somebody has locked it.
330		375
331	=cut	376	=cut
332		377
333	our %LOCK;	378	our $LOCKS = new Coro::SemaphoreSet;
334	our %LOCKER;#d#
335		379
336	sub lock_wait($) {	380	sub lock_wait($) {
337	my ($key) = @_;	381	$LOCKS->wait ($_[0]);
338
339	if ($LOCKER{$key} == $Coro::current) {#d#
340	Carp::cluck "lock_wait($key) for already-acquired lock";#d#
341	return;#d#
342	}#d#
343
344	# wait for lock, if any
345	while ($LOCK{$key}) {
346	push @{ $LOCK{$key} }, $Coro::current;
347	Coro::schedule;
348	}
349	}	382	}
350		383
351	sub lock_acquire($) {	384	sub lock_acquire($) {
352	my ($key) = @_;	385	$LOCKS->guard ($_[0])
353
354	# wait, to be sure we are not locked
355	lock_wait $key;
356
357	$LOCK{$key} = [];
358	$LOCKER{$key} = $Coro::current;#d#
359
360	Coro::guard {
361	delete $LOCKER{$key};#d#
362	# wake up all waiters, to be on the safe side
363	$_->ready for @{ delete $LOCK{$key} };
364	}
365	}	386	}
366		387
367	sub lock_active($) {	388	sub lock_active($) {
368	my ($key) = @_;	389	$LOCKS->count ($_[0]) < 1
369
370	! ! $LOCK{$key}
371	}	390	}
372		391
373	sub freeze_mainloop {	392	sub freeze_mainloop {
374	tick_inhibit_inc;	393	tick_inhibit_inc;
375		394
376	Coro::guard \&tick_inhibit_dec;	395	&Guard::guard (\&tick_inhibit_dec);
377	}	396	}
378		397
379	=item cf::periodic $interval, $cb	398	=item cf::periodic $interval, $cb
380		399
381	Like EV::periodic, but randomly selects a starting point so that the actions	400	Like EV::periodic, but randomly selects a starting point so that the actions
…		…
404		423
405	=cut	424	=cut
406		425
407	our @SLOT_QUEUE;	426	our @SLOT_QUEUE;
408	our $SLOT_QUEUE;	427	our $SLOT_QUEUE;
		428	our $SLOT_DECAY = 0.9;
409		429
410	$SLOT_QUEUE->cancel if $SLOT_QUEUE;	430	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
411	$SLOT_QUEUE = Coro::async {	431	$SLOT_QUEUE = Coro::async {
412	$Coro::current->desc ("timeslot manager");	432	$Coro::current->desc ("timeslot manager");
413		433
414	my $signal = new Coro::Signal;	434	my $signal = new Coro::Signal;
		435	my $busy;
415		436
416	while () {	437	while () {
417	next_job:	438	next_job:
		439
418	my $avail = cf::till_tick;	440	my $avail = cf::till_tick;
419	if ($avail > 0.01) {	441
420	for (0 .. $#SLOT_QUEUE) {	442	for (0 .. $#SLOT_QUEUE) {
421	if ($SLOT_QUEUE[$_][0] < $avail) {	443	if ($SLOT_QUEUE[$_][0] <= $avail) {
		444	$busy = 0;
422	my $job = splice @SLOT_QUEUE, $_, 1, ();	445	my $job = splice @SLOT_QUEUE, $_, 1, ();
423	$job->[2]->send;	446	$job->[2]->send;
424	Coro::cede;	447	Coro::cede;
425	goto next_job;	448	goto next_job;
426	}	449	} else {
		450	$SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
427	}	451	}
428	}	452	}
429		453
430	if (@SLOT_QUEUE) {	454	if (@SLOT_QUEUE) {
431	# we do not use wait_for_tick() as it returns immediately when tick is inactive	455	# we do not use wait_for_tick() as it returns immediately when tick is inactive
432	push @cf::WAIT_FOR_TICK, $signal;	456	push @cf::WAIT_FOR_TICK, $signal;
433	$signal->wait;	457	$signal->wait;
434	} else {	458	} else {
		459	$busy = 0;
435	Coro::schedule;	460	Coro::schedule;
436	}	461	}
437	}	462	}
438	};	463	};
439		464
440	sub get_slot($;$$) {	465	sub get_slot($;$$) {
441	return if tick_inhibit \|\| $Coro::current == $Coro::main;	466	return if tick_inhibit \|\| $Coro::current == $Coro::main;
442		467
443	my ($time, $pri, $name) = @_;	468	my ($time, $pri, $name) = @_;
444		469
445	$time = $TICK * .6 if $time > $TICK * .6;	470	$time = clamp $time, 0.01, $TICK * .6;
		471
446	my $sig = new Coro::Signal;	472	my $sig = new Coro::Signal;
447		473
448	push @SLOT_QUEUE, [$time, $pri, $sig, $name];	474	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
449	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;	475	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
450	$SLOT_QUEUE->ready;	476	$SLOT_QUEUE->ready;
…		…
1153	$decname, length $$rdata, scalar @$objs;	1179	$decname, length $$rdata, scalar @$objs;
1154		1180
1155	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {	1181	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {
1156	aio_chmod $fh, SAVE_MODE;	1182	aio_chmod $fh, SAVE_MODE;
1157	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1183	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1158	aio_fsync $fh if $cf::USE_FSYNC;	1184	if ($cf::USE_FSYNC) {
		1185	aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE \| IO::AIO::SYNC_FILE_RANGE_WRITE \| IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
		1186	aio_fsync $fh;
		1187	}
1159	aio_close $fh;	1188	aio_close $fh;
1160		1189
1161	if (@$objs) {	1190	if (@$objs) {
1162	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {	1191	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {
1163	aio_chmod $fh, SAVE_MODE;	1192	aio_chmod $fh, SAVE_MODE;
1164	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };	1193	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1165	aio_write $fh, 0, (length $data), $data, 0;	1194	aio_write $fh, 0, (length $data), $data, 0;
1166	aio_fsync $fh if $cf::USE_FSYNC;	1195	if ($cf::USE_FSYNC) {
		1196	aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE \| IO::AIO::SYNC_FILE_RANGE_WRITE \| IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
		1197	aio_fsync $fh;
		1198	}
1167	aio_close $fh;	1199	aio_close $fh;
1168	aio_rename "$filename.pst~", "$filename.pst";	1200	aio_rename "$filename.pst~", "$filename.pst";
1169	}	1201	}
1170	} else {	1202	} else {
1171	aio_unlink "$filename.pst";	1203	aio_unlink "$filename.pst";
1172	}	1204	}
1173		1205
1174	aio_rename "$filename~", $filename;	1206	aio_rename "$filename~", $filename;
		1207
		1208	$filename =~ s%/[^/]+$%%;
		1209	aio_pathsync $filename if $cf::USE_FSYNC;
1175	} else {	1210	} else {
1176	warn "FATAL: $filename~: $!\n";	1211	warn "unable to save objects: $filename~: $!\n";
1177	}	1212	}
1178	} else {	1213	} else {
1179	aio_unlink $filename;	1214	aio_unlink $filename;
1180	aio_unlink "$filename.pst";	1215	aio_unlink "$filename.pst";
1181	}	1216	}
…		…
1272	my ($name, $cb) = @_;	1307	my ($name, $cb) = @_;
1273		1308
1274	$EXTICMD{$name} = $cb;	1309	$EXTICMD{$name} = $cb;
1275	}	1310	}
1276		1311
		1312	use File::Glob ();
		1313
1277	cf::player->attach (	1314	cf::player->attach (
1278	on_command => sub {	1315	on_command => sub {
1279	my ($pl, $name, $params) = @_;	1316	my ($pl, $name, $params) = @_;
1280		1317
1281	my $cb = $COMMAND{$name}	1318	my $cb = $COMMAND{$name}
…		…
1312	}	1349	}
1313		1350
1314	cf::override;	1351	cf::override;
1315	},	1352	},
1316	);	1353	);
		1354
		1355	# "readahead" all extensions
		1356	sub cache_extensions {
		1357	my $grp = IO::AIO::aio_group;
		1358
		1359	add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
		1360	for (grep /\.ext$/, @{$_[0]}) {
		1361	add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
		1362	}
		1363	};
		1364
		1365	$grp
		1366	}
1317		1367
1318	sub load_extensions {	1368	sub load_extensions {
1319	cf::sync_job {	1369	cf::sync_job {
1320	my %todo;	1370	my %todo;
1321		1371
…		…
1444		1494
1445	sub exists($) {	1495	sub exists($) {
1446	my ($login) = @_;	1496	my ($login) = @_;
1447		1497
1448	$cf::PLAYER{$login}	1498	$cf::PLAYER{$login}
1449	or cf::sync_job { !aio_stat path $login }	1499	or !aio_stat path $login
1450	}	1500	}
1451		1501
1452	sub find($) {	1502	sub find($) {
1453	return $cf::PLAYER{$_[0]} \|\| do {	1503	return $cf::PLAYER{$_[0]} \|\| do {
1454	my $login = $_[0];	1504	my $login = $_[0];
…		…
1850		1900
1851	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;	1901	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1852	"$UNIQUEDIR/$path"	1902	"$UNIQUEDIR/$path"
1853	}	1903	}
1854		1904
1855	# and all this just because we cannot iterate over
1856	# all maps in C++...
1857	sub change_all_map_light {
1858	my ($change) = @_;
1859
1860	$_->change_map_light ($change)
1861	for grep $_->outdoor, values %cf::MAP;
1862	}
1863
1864	sub decay_objects {	1905	sub decay_objects {
1865	my ($self) = @_;	1906	my ($self) = @_;
1866		1907
1867	return if $self->{deny_reset};	1908	return if $self->{deny_reset};
1868		1909
…		…
1950	sub find {	1991	sub find {
1951	my ($path, $origin) = @_;	1992	my ($path, $origin) = @_;
1952		1993
1953	$path = normalise $path, $origin && $origin->path;	1994	$path = normalise $path, $origin && $origin->path;
1954		1995
1955	cf::lock_wait "map_data:$path";#d#remove	1996	my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1956	cf::lock_wait "map_find:$path";	1997	my $guard2 = cf::lock_acquire "map_find:$path";
1957		1998
1958	$cf::MAP{$path} \|\| do {	1999	$cf::MAP{$path} \|\| do {
1959	my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1960	my $guard2 = cf::lock_acquire "map_find:$path";
1961
1962	my $map = new_from_path cf::map $path	2000	my $map = new_from_path cf::map $path
1963	or return;	2001	or return;
1964		2002
1965	$map->{last_save} = $cf::RUNTIME;	2003	$map->{last_save} = $cf::RUNTIME;
1966		2004
…		…
1978		2016
1979	$cf::MAP{$path} = $map	2017	$cf::MAP{$path} = $map
1980	}	2018	}
1981	}	2019	}
1982		2020
1983	sub pre_load { }	2021	sub pre_load { }
1984	sub post_load { }	2022	#sub post_load { } # XS
1985		2023
1986	sub load {	2024	sub load {
1987	my ($self) = @_;	2025	my ($self) = @_;
1988		2026
1989	local $self->{deny_reset} = 1; # loading can take a long time	2027	local $self->{deny_reset} = 1; # loading can take a long time
…		…
2034	unless ($self->{deny_activate}) {	2072	unless ($self->{deny_activate}) {
2035	$self->decay_objects;	2073	$self->decay_objects;
2036	$self->fix_auto_apply;	2074	$self->fix_auto_apply;
2037	$self->update_buttons;	2075	$self->update_buttons;
2038	cf::cede_to_tick;	2076	cf::cede_to_tick;
2039	$self->set_darkness_map;
2040	cf::cede_to_tick;
2041	$self->activate;	2077	$self->activate;
2042	}	2078	}
2043		2079
2044	$self->{last_save} = $cf::RUNTIME;	2080	$self->{last_save} = $cf::RUNTIME;
2045	$self->last_access ($cf::RUNTIME);	2081	$self->last_access ($cf::RUNTIME);
…		…
2211		2247
2212	my $lock = cf::lock_acquire "map_data:$self->{path}";	2248	my $lock = cf::lock_acquire "map_data:$self->{path}";
2213		2249
2214	return if $self->players;	2250	return if $self->players;
2215		2251
2216	warn "resetting map ", $self->path;	2252	warn "resetting map ", $self->path, "\n";
2217		2253
2218	$self->in_memory (cf::MAP_SWAPPED);	2254	$self->in_memory (cf::MAP_SWAPPED);
2219		2255
2220	# need to save uniques path	2256	# need to save uniques path
2221	unless ($self->{deny_save}) {	2257	unless ($self->{deny_save}) {
…		…
2312	: normalise $_	2348	: normalise $_
2313	} @{ aio_readdir $UNIQUEDIR or [] }	2349	} @{ aio_readdir $UNIQUEDIR or [] }
2314	]	2350	]
2315	}	2351	}
2316		2352
		2353	=item cf::map::static_maps
		2354
		2355	Returns an arrayref if paths of all static maps (all preinstalled F<.map>
		2356	file in the shared directory excluding F</styles> and F</editor>). May
		2357	block.
		2358
		2359	=cut
		2360
		2361	sub static_maps() {
		2362	my @dirs = "";
		2363	my @maps;
		2364
		2365	while (@dirs) {
		2366	my $dir = shift @dirs;
		2367
		2368	next if $dir eq "/styles" \|\| $dir eq "/editor";
		2369
		2370	my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
		2371	or return;
		2372
		2373	for (@$files) {
		2374	s/\.map$// or next;
		2375	utf8::decode $_;
		2376	push @maps, "$dir/$_";
		2377	}
		2378
		2379	push @dirs, map "$dir/$_", @$dirs;
		2380	}
		2381
		2382	\@maps
		2383	}
		2384
2317	=back	2385	=back
2318		2386
2319	=head3 cf::object	2387	=head3 cf::object
2320		2388
2321	=cut	2389	=cut
…		…
2386		2454
2387	our $SAY_CHANNEL = {	2455	our $SAY_CHANNEL = {
2388	id => "say",	2456	id => "say",
2389	title => "Map",	2457	title => "Map",
2390	reply => "say ",	2458	reply => "say ",
2391	tooltip => "Things said to and replied from npcs near you and other players on the same map only.",	2459	tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2392	};	2460	};
2393		2461
2394	our $CHAT_CHANNEL = {	2462	our $CHAT_CHANNEL = {
2395	id => "chat",	2463	id => "chat",
2396	title => "Chat",	2464	title => "Chat",
…		…
2516	($x, $y) = (-1, -1)	2584	($x, $y) = (-1, -1)
2517	unless (defined $x) && (defined $y);	2585	unless (defined $x) && (defined $y);
2518		2586
2519	# use -1 or undef as default coordinates, not 0, 0	2587	# use -1 or undef as default coordinates, not 0, 0
2520	($x, $y) = ($map->enter_x, $map->enter_y)	2588	($x, $y) = ($map->enter_x, $map->enter_y)
2521	if $x <=0 && $y <= 0;	2589	if $x <= 0 && $y <= 0;
2522		2590
2523	$map->load;	2591	$map->load;
2524	$map->load_neighbours;	2592	$map->load_neighbours;
2525		2593
2526	return unless $self->contr->active;	2594	return unless $self->contr->active;
2527	$self->flag (cf::FLAG_DEBUG, 0);#d# temp
2528	$self->activate_recursive;
2529		2595
2530	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2596	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2531	$self->enter_map ($map, $x, $y);	2597	$self->enter_map ($map, $x, $y);
		2598
		2599	# only activate afterwards, to support waiting in hooks
		2600	$self->activate_recursive;
2532	}	2601	}
2533		2602
2534	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])	2603	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2535		2604
2536	Moves the player to the given map-path and coordinates by first freezing	2605	Moves the player to the given map-path and coordinates by first freezing
…		…
2724		2793
2725	utf8::encode $text;	2794	utf8::encode $text;
2726	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2795	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2727	}	2796	}
2728		2797
		2798	=item $client->send_big_packet ($pkt)
		2799
		2800	Like C<send_packet>, but tries to compress large packets, and fragments
		2801	them as required.
		2802
		2803	=cut
		2804
		2805	our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
		2806
		2807	sub cf::client::send_big_packet {
		2808	my ($self, $pkt) = @_;
		2809
		2810	# try lzf for large packets
		2811	$pkt = "lzf " . Compress::LZF::compress $pkt
		2812	if 1024 <= length $pkt and $self->{can_lzf};
		2813
		2814	# split very large packets
		2815	if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
		2816	$self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
		2817	$pkt = "frag";
		2818	}
		2819
		2820	$self->send_packet ($pkt);
		2821	}
		2822
2729	=item $client->send_msg ($channel, $msg, $color, [extra...])	2823	=item $client->send_msg ($channel, $msg, $color, [extra...])
2730		2824
2731	Send a drawinfo or msg packet to the client, formatting the msg for the	2825	Send a drawinfo or msg packet to the client, formatting the msg for the
2732	client if neccessary. C<$type> should be a string identifying the type of	2826	client if neccessary. C<$type> should be a string identifying the type of
2733	the message, with C<log> being the default. If C<$color> is negative, suppress	2827	the message, with C<log> being the default. If C<$color> is negative, suppress
…		…
2735		2829
2736	=cut	2830	=cut
2737		2831
2738	# non-persistent channels (usually the info channel)	2832	# non-persistent channels (usually the info channel)
2739	our %CHANNEL = (	2833	our %CHANNEL = (
		2834	"c/motd" => {
		2835	id => "infobox",
		2836	title => "MOTD",
		2837	reply => undef,
		2838	tooltip => "The message of the day",
		2839	},
2740	"c/identify" => {	2840	"c/identify" => {
2741	id => "infobox",	2841	id => "infobox",
2742	title => "Identify",	2842	title => "Identify",
2743	reply => undef,	2843	reply => undef,
2744	tooltip => "Items recently identified",	2844	tooltip => "Items recently identified",
…		…
2746	"c/examine" => {	2846	"c/examine" => {
2747	id => "infobox",	2847	id => "infobox",
2748	title => "Examine",	2848	title => "Examine",
2749	reply => undef,	2849	reply => undef,
2750	tooltip => "Signs and other items you examined",	2850	tooltip => "Signs and other items you examined",
		2851	},
		2852	"c/shopinfo" => {
		2853	id => "infobox",
		2854	title => "Shop Info",
		2855	reply => undef,
		2856	tooltip => "What your bargaining skill tells you about the shop",
2751	},	2857	},
2752	"c/book" => {	2858	"c/book" => {
2753	id => "infobox",	2859	id => "infobox",
2754	title => "Book",	2860	title => "Book",
2755	reply => undef,	2861	reply => undef,
…		…
2771	id => "infobox",	2877	id => "infobox",
2772	title => "Body Parts",	2878	title => "Body Parts",
2773	reply => undef,	2879	reply => undef,
2774	tooltip => "Shows which body parts you posess and are available",	2880	tooltip => "Shows which body parts you posess and are available",
2775	},	2881	},
		2882	"c/statistics" => {
		2883	id => "infobox",
		2884	title => "Statistics",
		2885	reply => undef,
		2886	tooltip => "Shows your primary statistics",
		2887	},
		2888	"c/skills" => {
		2889	id => "infobox",
		2890	title => "Skills",
		2891	reply => undef,
		2892	tooltip => "Shows your experience per skill and item power",
		2893	},
		2894	"c/shopitems" => {
		2895	id => "infobox",
		2896	title => "Shop Items",
		2897	reply => undef,
		2898	tooltip => "Shows the items currently for sale in this shop",
		2899	},
		2900	"c/resistances" => {
		2901	id => "infobox",
		2902	title => "Resistances",
		2903	reply => undef,
		2904	tooltip => "Shows your resistances",
		2905	},
		2906	"c/pets" => {
		2907	id => "infobox",
		2908	title => "Pets",
		2909	reply => undef,
		2910	tooltip => "Shows information abotu your pets/a specific pet",
		2911	},
		2912	"c/perceiveself" => {
		2913	id => "infobox",
		2914	title => "Perceive Self",
		2915	reply => undef,
		2916	tooltip => "You gained detailed knowledge about yourself",
		2917	},
2776	"c/uptime" => {	2918	"c/uptime" => {
2777	id => "infobox",	2919	id => "infobox",
2778	title => "Uptime",	2920	title => "Uptime",
2779	reply => undef,	2921	reply => undef,
2780	tooltip => "How long the server has been running since last restart",	2922	tooltip => "How long the server has been running since last restart",
…		…
2789	id => "party",	2931	id => "party",
2790	title => "Party",	2932	title => "Party",
2791	reply => "gsay ",	2933	reply => "gsay ",
2792	tooltip => "Messages and chat related to your party",	2934	tooltip => "Messages and chat related to your party",
2793	},	2935	},
		2936	"c/death" => {
		2937	id => "death",
		2938	title => "Death",
		2939	reply => undef,
		2940	tooltip => "Reason for and more info about your most recent death",
		2941	},
		2942	"c/say" => $SAY_CHANNEL,
		2943	"c/chat" => $CHAT_CHANNEL,
2794	);	2944	);
2795		2945
2796	sub cf::client::send_msg {	2946	sub cf::client::send_msg {
2797	my ($self, $channel, $msg, $color, @extra) = @_;	2947	my ($self, $channel, $msg, $color, @extra) = @_;
2798		2948
…		…
2803		2953
2804	# check predefined channels, for the benefit of C	2954	# check predefined channels, for the benefit of C
2805	if ($CHANNEL{$channel}) {	2955	if ($CHANNEL{$channel}) {
2806	$channel = $CHANNEL{$channel};	2956	$channel = $CHANNEL{$channel};
2807		2957
2808	$self->ext_msg (channel_info => $channel)	2958	$self->ext_msg (channel_info => $channel);
2809	if $self->can_msg;
2810
2811	$channel = $channel->{id};	2959	$channel = $channel->{id};
2812		2960
2813	} elsif (ref $channel) {	2961	} elsif (ref $channel) {
2814	# send meta info to client, if not yet sent	2962	# send meta info to client, if not yet sent
2815	unless (exists $self->{channel}{$channel->{id}}) {	2963	unless (exists $self->{channel}{$channel->{id}}) {
2816	$self->{channel}{$channel->{id}} = $channel;	2964	$self->{channel}{$channel->{id}} = $channel;
2817	$self->ext_msg (channel_info => $channel)	2965	$self->ext_msg (channel_info => $channel);
2818	if $self->can_msg;
2819	}	2966	}
2820		2967
2821	$channel = $channel->{id};	2968	$channel = $channel->{id};
2822	}	2969	}
2823		2970
2824	return unless @extra \|\| length $msg;	2971	return unless @extra \|\| length $msg;
2825		2972
2826	if ($self->can_msg) {
2827	# default colour, mask it out	2973	# default colour, mask it out
2828	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)	2974	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
2829	if $color & cf::NDI_DEF;	2975	if $color & cf::NDI_DEF;
2830		2976
2831	my $pkt = "msg "	2977	my $pkt = "msg "
2832	. $self->{json_coder}->encode (	2978	. $self->{json_coder}->encode (
2833	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]	2979	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2834	);	2980	);
2835		2981
2836	# try lzf for large packets
2837	$pkt = "lzf " . Compress::LZF::compress $pkt
2838	if 1024 <= length $pkt and $self->{can_lzf};
2839
2840	# split very large packets
2841	if (8192 < length $pkt and $self->{can_lzf}) {
2842	$self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2843	$pkt = "frag";
2844	}
2845
2846	$self->send_packet ($pkt);	2982	$self->send_big_packet ($pkt);
2847	} else {
2848	if ($color >= 0) {
2849	# replace some tags by gcfclient-compatible ones
2850	for ($msg) {
2851	1 while
2852	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2853	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2854	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2855	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2856	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2857	}
2858
2859	$color &= cf::NDI_COLOR_MASK;
2860
2861	utf8::encode $msg;
2862
2863	if (0 && $msg =~ /\[/) {
2864	# COMMAND/INFO
2865	$self->send_packet ("drawextinfo $color 10 8 $msg")
2866	} else {
2867	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2868	$self->send_packet ("drawinfo $color $msg")
2869	}
2870	}
2871	}
2872	}	2983	}
2873		2984
2874	=item $client->ext_msg ($type, @msg)	2985	=item $client->ext_msg ($type, @msg)
2875		2986
2876	Sends an ext event to the client.	2987	Sends an ext event to the client.
…		…
2879		2990
2880	sub cf::client::ext_msg($$@) {	2991	sub cf::client::ext_msg($$@) {
2881	my ($self, $type, @msg) = @_;	2992	my ($self, $type, @msg) = @_;
2882		2993
2883	if ($self->extcmd == 2) {	2994	if ($self->extcmd == 2) {
2884	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));	2995	$self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2885	} elsif ($self->extcmd == 1) { # TODO: remove	2996	} elsif ($self->extcmd == 1) { # TODO: remove
2886	push @msg, msgtype => "event_$type";	2997	push @msg, msgtype => "event_$type";
2887	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));	2998	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2888	}	2999	}
2889	}	3000	}
2890		3001
2891	=item $client->ext_reply ($msgid, @msg)	3002	=item $client->ext_reply ($msgid, @msg)
2892		3003
…		…
2896		3007
2897	sub cf::client::ext_reply($$@) {	3008	sub cf::client::ext_reply($$@) {
2898	my ($self, $id, @msg) = @_;	3009	my ($self, $id, @msg) = @_;
2899		3010
2900	if ($self->extcmd == 2) {	3011	if ($self->extcmd == 2) {
2901	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));	3012	$self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2902	} elsif ($self->extcmd == 1) {	3013	} elsif ($self->extcmd == 1) {
2903	#TODO: version 1, remove	3014	#TODO: version 1, remove
2904	unshift @msg, msgtype => "reply", msgid => $id;	3015	unshift @msg, msgtype => "reply", msgid => $id;
2905	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));	3016	$self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2906	}	3017	}
2907	}	3018	}
2908		3019
2909	=item $success = $client->query ($flags, "text", \&cb)	3020	=item $success = $client->query ($flags, "text", \&cb)
2910		3021
…		…
3037	our $safe_hole = new Safe::Hole;	3148	our $safe_hole = new Safe::Hole;
3038		3149
3039	$SIG{FPE} = 'IGNORE';	3150	$SIG{FPE} = 'IGNORE';
3040		3151
3041	$safe->permit_only (Opcode::opset qw(	3152	$safe->permit_only (Opcode::opset qw(
3042	:base_core :base_mem :base_orig :base_math	3153	:base_core :base_mem :base_orig :base_math :base_loop
3043	grepstart grepwhile mapstart mapwhile	3154	grepstart grepwhile mapstart mapwhile
3044	sort time	3155	sort time
3045	));	3156	));
3046		3157
3047	# here we export the classes and methods available to script code	3158	# here we export the classes and methods available to script code
…		…
3051	The following functions and methods are available within a safe environment:	3162	The following functions and methods are available within a safe environment:
3052		3163
3053	cf::object	3164	cf::object
3054	contr pay_amount pay_player map x y force_find force_add destroy	3165	contr pay_amount pay_player map x y force_find force_add destroy
3055	insert remove name archname title slaying race decrease split	3166	insert remove name archname title slaying race decrease split
		3167	value
3056		3168
3057	cf::object::player	3169	cf::object::player
3058	player	3170	player
3059		3171
3060	cf::player	3172	cf::player
…		…
3066	=cut	3178	=cut
3067		3179
3068	for (	3180	for (
3069	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	3181	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3070	insert remove inv nrof name archname title slaying race	3182	insert remove inv nrof name archname title slaying race
3071	decrease split destroy change_exp)],	3183	decrease split destroy change_exp value msg lore send_msg)],
3072	["cf::object::player" => qw(player)],	3184	["cf::object::player" => qw(player)],
3073	["cf::player" => qw(peaceful)],	3185	["cf::player" => qw(peaceful send_msg)],
3074	["cf::map" => qw(trigger)],	3186	["cf::map" => qw(trigger)],
3075	) {	3187	) {
3076	no strict 'refs';	3188	no strict 'refs';
3077	my ($pkg, @funs) = @$_;	3189	my ($pkg, @funs) = @$_;
3078	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	3190	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
…		…
3096		3208
3097	my $qcode = $code;	3209	my $qcode = $code;
3098	$qcode =~ s/"/‟/g; # not allowed in #line filenames	3210	$qcode =~ s/"/‟/g; # not allowed in #line filenames
3099	$qcode =~ s/\n/\\n/g;	3211	$qcode =~ s/\n/\\n/g;
3100		3212
		3213	%vars = (_dummy => 0) unless %vars;
		3214
		3215	my @res;
3101	local $_;	3216	local $_;
3102	local @safe::cf::_safe_eval_args = values %vars;
3103		3217
3104	my $eval =	3218	my $eval =
3105	"do {\n"	3219	"do {\n"
3106	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"	3220	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3107	. "#line 0 \"{$qcode}\"\n"	3221	. "#line 0 \"{$qcode}\"\n"
3108	. $code	3222	. $code
3109	. "\n}"	3223	. "\n}"
3110	;	3224	;
3111		3225
		3226	if ($CFG{safe_eval}) {
3112	sub_generation_inc;	3227	sub_generation_inc;
		3228	local @safe::cf::_safe_eval_args = values %vars;
3113	my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);	3229	@res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3114	sub_generation_inc;	3230	sub_generation_inc;
		3231	} else {
		3232	local @cf::_safe_eval_args = values %vars;
		3233	@res = wantarray ? eval eval : scalar eval $eval;
		3234	}
3115		3235
3116	if ($@) {	3236	if ($@) {
3117	warn "$@";	3237	warn "$@";
3118	warn "while executing safe code '$code'\n";	3238	warn "while executing safe code '$code'\n";
3119	warn "with arguments " . (join " ", %vars) . "\n";	3239	warn "with arguments " . (join " ", %vars) . "\n";
…		…
3138	=cut	3258	=cut
3139		3259
3140	sub register_script_function {	3260	sub register_script_function {
3141	my ($fun, $cb) = @_;	3261	my ($fun, $cb) = @_;
3142		3262
3143	no strict 'refs';	3263	$fun = "safe::$fun" if $CFG{safe_eval};
3144	*{"safe::$fun"} = $safe_hole->wrap ($cb);	3264	*$fun = $safe_hole->wrap ($cb);
3145	}	3265	}
3146		3266
3147	=back	3267	=back
3148		3268
3149	=cut	3269	=cut
…		…
3170		3290
3171	$facedata->{version} == 2	3291	$facedata->{version} == 2
3172	or cf::cleanup "$path: version mismatch, cannot proceed.";	3292	or cf::cleanup "$path: version mismatch, cannot proceed.";
3173		3293
3174	# patch in the exptable	3294	# patch in the exptable
		3295	my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3175	$facedata->{resource}{"res/exp_table"} = {	3296	$facedata->{resource}{"res/exp_table"} = {
3176	type => FT_RSRC,	3297	type => FT_RSRC,
3177	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),	3298	data => $exp_table,
		3299	hash => (Digest::MD5::md5 $exp_table),
3178	};	3300	};
3179	cf::cede_to_tick;	3301	cf::cede_to_tick;
3180		3302
3181	{	3303	{
3182	my $faces = $facedata->{faceinfo};	3304	my $faces = $facedata->{faceinfo};
…		…
3184	while (my ($face, $info) = each %$faces) {	3306	while (my ($face, $info) = each %$faces) {
3185	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	3307	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
3186		3308
3187	cf::face::set_visibility $idx, $info->{visibility};	3309	cf::face::set_visibility $idx, $info->{visibility};
3188	cf::face::set_magicmap $idx, $info->{magicmap};	3310	cf::face::set_magicmap $idx, $info->{magicmap};
3189	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};	3311	cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3190	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};	3312	cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3191		3313
3192	cf::cede_to_tick;	3314	cf::cede_to_tick;
3193	}	3315	}
3194		3316
3195	while (my ($face, $info) = each %$faces) {	3317	while (my ($face, $info) = each %$faces) {
…		…
3219		3341
3220	cf::anim::invalidate_all; # d'oh	3342	cf::anim::invalidate_all; # d'oh
3221	}	3343	}
3222		3344
3223	{	3345	{
3224	# TODO: for gcfclient pleasure, we should give resources
3225	# that gcfclient doesn't grok a >10000 face index.
3226	my $res = $facedata->{resource};	3346	my $res = $facedata->{resource};
3227		3347
3228	while (my ($name, $info) = each %$res) {	3348	while (my ($name, $info) = each %$res) {
3229	if (defined $info->{type}) {	3349	if (defined $info->{type}) {
3230	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	3350	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
3231	my $data;
3232		3351
3233	if ($info->{type} & 1) {	3352	cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3234	# prepend meta info
3235
3236	my $meta = $enc->encode ({
3237	name => $name,
3238	%{ $info->{meta} \|\| {} },
3239	});
3240
3241	$data = pack "(w/a)", $meta, $info->{data};
3242	} else {
3243	$data = $info->{data};
3244	}
3245
3246	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3247	cf::face::set_type $idx, $info->{type};	3353	cf::face::set_type $idx, $info->{type};
3248	} else {	3354	} else {
3249	$RESOURCE{$name} = $info;	3355	$RESOURCE{$name} = $info;
3250	}	3356	}
3251		3357
…		…
3334	reload_treasures;	3440	reload_treasures;
3335		3441
3336	warn "finished reloading resource files\n";	3442	warn "finished reloading resource files\n";
3337	}	3443	}
3338		3444
3339	sub init {
3340	my $guard = freeze_mainloop;
3341
3342	evthread_start IO::AIO::poll_fileno;
3343
3344	reload_resources;
3345	}
3346
3347	sub reload_config {	3445	sub reload_config {
		3446	warn "reloading config file...\n";
		3447
3348	open my $fh, "<:utf8", "$CONFDIR/config"	3448	open my $fh, "<:utf8", "$CONFDIR/config"
3349	or return;	3449	or return;
3350		3450
3351	local $/;	3451	local $/;
3352	*CFG = YAML::Load <$fh>;	3452	*CFG = YAML::XS::Load scalar <$fh>;
3353		3453
3354	$EMERGENCY_POSITION = $CFG{emergency_position} \|\| ["/world/world_105_115", 5, 37];	3454	$EMERGENCY_POSITION = $CFG{emergency_position} \|\| ["/world/world_105_115", 5, 37];
3355		3455
3356	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};	3456	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3357	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};	3457	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
…		…
3361	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"	3461	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3362	and die "WARNING: m(un)lockall failed: $!\n";	3462	and die "WARNING: m(un)lockall failed: $!\n";
3363	};	3463	};
3364	warn $@ if $@;	3464	warn $@ if $@;
3365	}	3465	}
		3466
		3467	warn "finished reloading resource files\n";
3366	}	3468	}
3367		3469
3368	sub pidfile() {	3470	sub pidfile() {
3369	sysopen my $fh, $PIDFILE, O_RDWR \| O_CREAT	3471	sysopen my $fh, $PIDFILE, O_RDWR \| O_CREAT
3370	or die "$PIDFILE: $!";	3472	or die "$PIDFILE: $!";
…		…
3382		3484
3383	seek $fh, 0, 0;	3485	seek $fh, 0, 0;
3384	print $fh $$;	3486	print $fh $$;
3385	}	3487	}
3386		3488
		3489	sub main_loop {
		3490	warn "EV::loop starting\n";
		3491	if (1) {
		3492	EV::loop;
		3493	}
		3494	warn "EV::loop returned\n";
		3495	goto &main_loop unless $REALLY_UNLOOP;
		3496	}
		3497
3387	sub main {	3498	sub main {
3388	atomic;	3499	cf::init_globals; # initialise logging
		3500
		3501	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
		3502	LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
		3503	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
		3504	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
		3505
		3506	cf::init_experience;
		3507	cf::init_anim;
		3508	cf::init_attackmess;
		3509	cf::init_dynamic;
		3510
		3511	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3389		3512
3390	# we must not ever block the main coroutine	3513	# we must not ever block the main coroutine
3391	local $Coro::idle = sub {	3514	local $Coro::idle = sub {
3392	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#	3515	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3393	(async {	3516	(async {
3394	$Coro::current->{desc} = "IDLE BUG HANDLER";	3517	$Coro::current->{desc} = "IDLE BUG HANDLER";
3395	EV::loop EV::LOOP_ONESHOT;	3518	EV::loop EV::LOOP_ONESHOT;
3396	})->prio (Coro::PRIO_MAX);	3519	})->prio (Coro::PRIO_MAX);
3397	};	3520	};
3398		3521
3399	{	3522	evthread_start IO::AIO::poll_fileno;
3400	my $guard = freeze_mainloop;	3523
		3524	cf::sync_job {
		3525	cf::load_settings;
		3526	cf::load_materials;
		3527
		3528	reload_resources;
3401	reload_config;	3529	reload_config;
3402	db_init;	3530	db_init;
		3531
		3532	cf::init_uuid;
		3533	cf::init_signals;
		3534	cf::init_commands;
		3535	cf::init_skills;
		3536
		3537	cf::init_beforeplay;
		3538
		3539	atomic;
		3540
3403	load_extensions;	3541	load_extensions;
3404		3542
3405	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3406	}
3407
3408	utime time, time, $RUNTIMEFILE;	3543	utime time, time, $RUNTIMEFILE;
3409		3544
3410	# no (long-running) fork's whatsoever before this point(!)	3545	# no (long-running) fork's whatsoever before this point(!)
		3546	use POSIX ();
3411	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};	3547	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3412		3548
3413	EV::loop;	3549	(pop @POST_INIT)->(0) while @POST_INIT;
		3550	};
		3551
		3552	main_loop;
3414	}	3553	}
3415		3554
3416	#############################################################################	3555	#############################################################################
3417	# initialisation and cleanup	3556	# initialisation and cleanup
3418		3557
…		…
3474	my $uuid = "$LOCALDIR/uuid";	3613	my $uuid = "$LOCALDIR/uuid";
3475		3614
3476	my $fh = aio_open "$uuid~", O_WRONLY \| O_CREAT, 0644	3615	my $fh = aio_open "$uuid~", O_WRONLY \| O_CREAT, 0644
3477	or return;	3616	or return;
3478		3617
3479	my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;	3618	my $value = uuid_seq uuid_cur;
		3619
		3620	unless ($value) {
		3621	warn "cowardly refusing to write zero uuid value!\n";
		3622	return;
		3623	}
		3624
		3625	my $value = uuid_str $value + $uuid_skip;
3480	$uuid_skip = 0;	3626	$uuid_skip = 0;
3481		3627
3482	(aio_write $fh, 0, (length $value), $value, 0) <= 0	3628	(aio_write $fh, 0, (length $value), $value, 0) <= 0
3483	and return;	3629	and return;
3484		3630
…		…
3506	}	3652	}
3507		3653
3508	sub emergency_save() {	3654	sub emergency_save() {
3509	my $freeze_guard = cf::freeze_mainloop;	3655	my $freeze_guard = cf::freeze_mainloop;
3510		3656
3511	warn "enter emergency perl save\n";	3657	warn "emergency_perl_save: enter\n";
3512		3658
3513	cf::sync_job {	3659	cf::sync_job {
		3660	# this is a trade-off: we want to be very quick here, so
		3661	# save all maps without fsync, and later call a global sync
		3662	# (which in turn might be very very slow)
		3663	local $USE_FSYNC = 0;
		3664
3514	# use a peculiar iteration method to avoid tripping on perl	3665	# use a peculiar iteration method to avoid tripping on perl
3515	# refcount bugs in for. also avoids problems with players	3666	# refcount bugs in for. also avoids problems with players
3516	# and maps saved/destroyed asynchronously.	3667	# and maps saved/destroyed asynchronously.
3517	warn "begin emergency player save\n";	3668	warn "emergency_perl_save: begin player save\n";
3518	for my $login (keys %cf::PLAYER) {	3669	for my $login (keys %cf::PLAYER) {
3519	my $pl = $cf::PLAYER{$login} or next;	3670	my $pl = $cf::PLAYER{$login} or next;
3520	$pl->valid or next;	3671	$pl->valid or next;
3521	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt	3672	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3522	$pl->save;	3673	$pl->save;
3523	}	3674	}
3524	warn "end emergency player save\n";	3675	warn "emergency_perl_save: end player save\n";
3525		3676
3526	warn "begin emergency map save\n";	3677	warn "emergency_perl_save: begin map save\n";
3527	for my $path (keys %cf::MAP) {	3678	for my $path (keys %cf::MAP) {
3528	my $map = $cf::MAP{$path} or next;	3679	my $map = $cf::MAP{$path} or next;
3529	$map->valid or next;	3680	$map->valid or next;
3530	$map->save;	3681	$map->save;
3531	}	3682	}
3532	warn "end emergency map save\n";	3683	warn "emergency_perl_save: end map save\n";
3533		3684
3534	warn "begin emergency database checkpoint\n";	3685	warn "emergency_perl_save: begin database checkpoint\n";
3535	BDB::db_env_txn_checkpoint $DB_ENV;	3686	BDB::db_env_txn_checkpoint $DB_ENV;
3536	warn "end emergency database checkpoint\n";	3687	warn "emergency_perl_save: end database checkpoint\n";
3537		3688
3538	warn "begin write uuid\n";	3689	warn "emergency_perl_save: begin write uuid\n";
3539	write_uuid_sync 1;	3690	write_uuid_sync 1;
3540	warn "end write uuid\n";	3691	warn "emergency_perl_save: end write uuid\n";
3541	};	3692	};
3542		3693
		3694	warn "emergency_perl_save: starting sync()\n";
		3695	IO::AIO::aio_sync sub {
		3696	warn "emergency_perl_save: finished sync()\n";
		3697	};
		3698
3543	warn "leave emergency perl save\n";	3699	warn "emergency_perl_save: leave\n";
3544	}	3700	}
3545		3701
3546	sub post_cleanup {	3702	sub post_cleanup {
3547	my ($make_core) = @_;	3703	my ($make_core) = @_;
3548		3704
…		…
3574	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};	3730	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3575	for my $name (keys %$leaf_symtab) {	3731	for my $name (keys %$leaf_symtab) {
3576	_gv_clear *{"$pkg$name"};	3732	_gv_clear *{"$pkg$name"};
3577	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};	3733	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3578	}	3734	}
3579	warn "cleared package #$pkg\n";#d#	3735	warn "cleared package $pkg\n";#d#
3580	}	3736	}
3581
3582	our $RELOAD; # how many times to reload
3583		3737
3584	sub do_reload_perl() {	3738	sub do_reload_perl() {
3585	# can/must only be called in main	3739	# can/must only be called in main
3586	if ($Coro::current != $Coro::main) {	3740	if ($Coro::current != $Coro::main) {
3587	warn "can only reload from main coroutine";	3741	warn "can only reload from main coroutine";
3588	return;	3742	return;
3589	}	3743	}
3590		3744
3591	return if $RELOAD++;	3745	return if $RELOAD++;
		3746
		3747	my $t1 = EV::time;
3592		3748
3593	while ($RELOAD) {	3749	while ($RELOAD) {
3594	warn "reloading...";	3750	warn "reloading...";
3595		3751
3596	warn "entering sync_job";	3752	warn "entering sync_job";
…		…
3657	clear_package "safe::$_"	3813	clear_package "safe::$_"
3658	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	3814	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3659		3815
3660	warn "unloading cf.pm \"a bit\"";	3816	warn "unloading cf.pm \"a bit\"";
3661	delete $INC{"cf.pm"};	3817	delete $INC{"cf.pm"};
3662	delete $INC{"cf/pod.pm"};	3818	delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3663		3819
3664	# don't, removes xs symbols, too,	3820	# don't, removes xs symbols, too,
3665	# and global variables created in xs	3821	# and global variables created in xs
3666	#clear_package __PACKAGE__;	3822	#clear_package __PACKAGE__;
3667		3823
3668	warn "unload completed, starting to reload now";	3824	warn "unload completed, starting to reload now";
3669		3825
3670	warn "reloading cf.pm";	3826	warn "reloading cf.pm";
3671	require cf;	3827	require cf;
3672	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3828	cf::_connect_to_perl_1;
3673		3829
3674	warn "loading config and database again";	3830	warn "loading config and database again";
3675	cf::reload_config;	3831	cf::reload_config;
3676		3832
3677	warn "loading extensions";	3833	warn "loading extensions";
3678	cf::load_extensions;	3834	cf::load_extensions;
3679		3835
		3836	if ($REATTACH_ON_RELOAD) {
3680	warn "reattaching attachments to objects/players";	3837	warn "reattaching attachments to objects/players";
3681	_global_reattach; # objects, sockets	3838	_global_reattach; # objects, sockets
3682	warn "reattaching attachments to maps";	3839	warn "reattaching attachments to maps";
3683	reattach $_ for values %MAP;	3840	reattach $_ for values %MAP;
3684	warn "reattaching attachments to players";	3841	warn "reattaching attachments to players";
3685	reattach $_ for values %PLAYER;	3842	reattach $_ for values %PLAYER;
		3843	}
		3844
		3845	warn "running post_init jobs";
		3846	(pop @POST_INIT)->(1) while @POST_INIT;
3686		3847
3687	warn "leaving sync_job";	3848	warn "leaving sync_job";
3688		3849
3689	1	3850	1
3690	} or do {	3851	} or do {
…		…
3693	};	3854	};
3694		3855
3695	warn "reloaded";	3856	warn "reloaded";
3696	--$RELOAD;	3857	--$RELOAD;
3697	}	3858	}
		3859
		3860	$t1 = EV::time - $t1;
		3861	warn "reload completed in ${t1}s\n";
3698	};	3862	};
3699		3863
3700	our $RELOAD_WATCHER; # used only during reload	3864	our $RELOAD_WATCHER; # used only during reload
3701		3865
3702	sub reload_perl() {	3866	sub reload_perl() {
3703	# doing reload synchronously and two reloads happen back-to-back,	3867	# doing reload synchronously and two reloads happen back-to-back,
3704	# coro crashes during coro_state_free->destroy here.	3868	# coro crashes during coro_state_free->destroy here.
3705		3869
		3870	$RELOAD_WATCHER \|\|= cf::async {
		3871	Coro::AIO::aio_wait cache_extensions;
		3872
3706	$RELOAD_WATCHER \|\|= EV::timer 0, 0, sub {	3873	$RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3707	do_reload_perl;	3874	do_reload_perl;
3708	undef $RELOAD_WATCHER;	3875	undef $RELOAD_WATCHER;
		3876	};
3709	};	3877	};
3710	}	3878	}
3711		3879
3712	register_command "reload" => sub {	3880	register_command "reload" => sub {
3713	my ($who, $arg) = @_;	3881	my ($who, $arg) = @_;
…		…
3727		3895
3728	our @WAIT_FOR_TICK;	3896	our @WAIT_FOR_TICK;
3729	our @WAIT_FOR_TICK_BEGIN;	3897	our @WAIT_FOR_TICK_BEGIN;
3730		3898
3731	sub wait_for_tick {	3899	sub wait_for_tick {
3732	return if tick_inhibit \|\| $Coro::current == $Coro::main;	3900	return Coro::cede if tick_inhibit \|\| $Coro::current == $Coro::main;
3733		3901
3734	my $signal = new Coro::Signal;	3902	my $signal = new Coro::Signal;
3735	push @WAIT_FOR_TICK, $signal;	3903	push @WAIT_FOR_TICK, $signal;
3736	$signal->wait;	3904	$signal->wait;
3737	}	3905	}
3738		3906
3739	sub wait_for_tick_begin {	3907	sub wait_for_tick_begin {
3740	return if tick_inhibit \|\| $Coro::current == $Coro::main;	3908	return Coro::cede if tick_inhibit \|\| $Coro::current == $Coro::main;
3741		3909
3742	my $signal = new Coro::Signal;	3910	my $signal = new Coro::Signal;
3743	push @WAIT_FOR_TICK_BEGIN, $signal;	3911	push @WAIT_FOR_TICK_BEGIN, $signal;
3744	$signal->wait;	3912	$signal->wait;
3745	}	3913	}
…		…
3750	unless ++$bug_warning > 10;	3918	unless ++$bug_warning > 10;
3751	return;	3919	return;
3752	}	3920	}
3753		3921
3754	cf::server_tick; # one server iteration	3922	cf::server_tick; # one server iteration
		3923
		3924	#for(1..3e6){} EV::now_update; $NOW=EV::now; # generate load #d#
3755		3925
3756	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3926	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3757	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;	3927	$NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3758	Coro::async_pool {	3928	Coro::async_pool {
3759	$Coro::current->{desc} = "runtime saver";	3929	$Coro::current->{desc} = "runtime saver";
…		…
3872	LOG llevInfo, "[ABT] [suppressed]\n";	4042	LOG llevInfo, "[ABT] [suppressed]\n";
3873	}	4043	}
3874	}	4044	}
3875		4045
3876	# load additional modules	4046	# load additional modules
3877	use cf::pod;	4047	require "cf/$_.pm" for @EXTRA_MODULES;
		4048	cf::_connect_to_perl_2;
3878		4049
3879	END { cf::emergency_save }	4050	END { cf::emergency_save }
3880		4051
3881	1	4052	1
3882		4053

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.449 by root, Sat Sep 20 00:09:27 2008 UTC vs. Revision 1.502 by root, Sat Jan 23 20:24:50 2010 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.449 by root, Sat Sep 20 00:09:27 2008 UTC vs.
Revision 1.502 by root, Sat Jan 23 20:24:50 2010 UTC