ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/deliantra/server/lib/cf.pm

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.250 by root, Wed Apr 18 14:24:10 2007 UTC vs.
Revision 1.282 by elmex, Tue Jun 19 18:15:34 2007 UTC

…		…
54	our %EXT_CORO = (); # coroutines bound to extensions	54	our %EXT_CORO = (); # coroutines bound to extensions
55	our %EXT_MAP = (); # pluggable maps	55	our %EXT_MAP = (); # pluggable maps
56		56
57	our $RELOAD; # number of reloads so far	57	our $RELOAD; # number of reloads so far
58	our @EVENT;	58	our @EVENT;
59	our $LIBDIR = datadir . "/ext";	59
		60	our $CONFDIR = confdir;
		61	our $DATADIR = datadir;
		62	our $LIBDIR = "$DATADIR/ext";
		63	our $PODDIR = "$DATADIR/pod";
		64	our $MAPDIR = "$DATADIR/" . mapdir;
		65	our $LOCALDIR = localdir;
		66	our $TMPDIR = "$LOCALDIR/" . tmpdir;
		67	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
		68	our $PLAYERDIR = "$LOCALDIR/" . playerdir;
		69	our $RANDOMDIR = "$LOCALDIR/random";
		70	our $BDBDIR = "$LOCALDIR/db";
60		71
61	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	72	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
62	our $TICK_WATCHER;	73	our $TICK_WATCHER;
63	our $AIO_POLL_WATCHER;	74	our $AIO_POLL_WATCHER;
64	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	75	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
…		…
75	our $RUNTIME;	86	our $RUNTIME;
76		87
77	our %PLAYER; # all users	88	our %PLAYER; # all users
78	our %MAP; # all maps	89	our %MAP; # all maps
79	our $LINK_MAP; # the special {link} map, which is always available	90	our $LINK_MAP; # the special {link} map, which is always available
80	our $RANDOM_MAPS = cf::localdir . "/random";
81	our $BDB_ENV_DIR = cf::localdir . "/db";
82		91
83	# used to convert map paths into valid unix filenames by replacing / by ∕	92	# used to convert map paths into valid unix filenames by replacing / by ∕
84	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons	93	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
85		94
		95	our $LOAD; # a number between 0 (idle) and 1 (too many objects)
		96	our $LOADAVG; # same thing, but with alpha-smoothing
		97	our $tick_start; # for load detecting purposes
		98
86	binmode STDOUT;	99	binmode STDOUT;
87	binmode STDERR;	100	binmode STDERR;
88		101
89	# read virtual server time, if available	102	# read virtual server time, if available
90	unless ($RUNTIME || !-e cf::localdir . "/runtime") {	103	unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
91	open my $fh, "<", cf::localdir . "/runtime"	104	open my $fh, "<", "$LOCALDIR/runtime"
92	or die "unable to read runtime file: $!";	105	or die "unable to read runtime file: $!";
93	$RUNTIME = <$fh> + 0.;	106	$RUNTIME = <$fh> + 0.;
94	}	107	}
95		108
96	mkdir cf::localdir;	109	mkdir $_
97	mkdir cf::localdir . "/" . cf::playerdir;	110	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
98	mkdir cf::localdir . "/" . cf::tmpdir;
99	mkdir cf::localdir . "/" . cf::uniquedir;
100	mkdir $RANDOM_MAPS;
101	mkdir $BDB_ENV_DIR;
102		111
103	our $EMERGENCY_POSITION;	112	our $EMERGENCY_POSITION;
104		113
105	sub cf::map::normalise;	114	sub cf::map::normalise;
106		115
…		…
117	=item $cf::RUNTIME	126	=item $cf::RUNTIME
118		127
119	The time this server has run, starts at 0 and is increased by $cf::TICK on	128	The time this server has run, starts at 0 and is increased by $cf::TICK on
120	every server tick.	129	every server tick.
121		130
122	=item $cf::LIBDIR	131	=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
		132	$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
		133	$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
123		134
124	The perl library directory, where extensions and cf-specific modules can	135	Various directories - "/etc", read-only install directory, perl-library
125	be found. It will be added to C<@INC> automatically.	136	directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
		137	unique-items directory, player file directory, random maps directory and
		138	database environment.
126		139
127	=item $cf::NOW	140	=item $cf::NOW
128		141
129	The time of the last (current) server tick.	142	The time of the last (current) server tick.
130		143
131	=item $cf::TICK	144	=item $cf::TICK
132		145
133	The interval between server ticks, in seconds.	146	The interval between server ticks, in seconds.
		147
		148	=item $cf::LOADAVG
		149
		150	The current CPU load on the server (alpha-smoothed), as a value between 0
		151	(none) and 1 (overloaded), indicating how much time is spent on processing
		152	objects per tick. Healthy values are < 0.5.
		153
		154	=item $cf::LOAD
		155
		156	The raw value load value from the last tick.
134		157
135	=item %cf::CFG	158	=item %cf::CFG
136		159
137	Configuration for the server, loaded from C</etc/crossfire/config>, or	160	Configuration for the server, loaded from C</etc/crossfire/config>, or
138	from wherever your confdir points to.	161	from wherever your confdir points to.
…		…
152	my $msg = join "", @_;	175	my $msg = join "", @_;
153		176
154	$msg .= "\n"	177	$msg .= "\n"
155	unless $msg =~ /\n$/;	178	unless $msg =~ /\n$/;
156		179
157	$msg =~ s/([\x00-\x09\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;	180	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
158		181
159	utf8::encode $msg;	182	utf8::encode $msg;
160	LOG llevError, $msg;	183	LOG llevError, $msg;
161	};	184	};
162	}	185	}
…		…
164	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	187	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
165	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';	188	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
166	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';	189	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
167	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';	190	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
168	@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';	191	@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
		192	@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
169	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';	193	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
170		194
171	# we bless all objects into (empty) derived classes to force a method lookup	195	# we bless all objects into (empty) derived classes to force a method lookup
172	# within the Safe compartment.	196	# within the Safe compartment.
173	for my $pkg (qw(	197	for my $pkg (qw(
174	cf::global cf::attachable	198	cf::global cf::attachable
…		…
182	}	206	}
183		207
184	$Event::DIED = sub {	208	$Event::DIED = sub {
185	warn "error in event callback: @_";	209	warn "error in event callback: @_";
186	};	210	};
		211
		212	#############################################################################
187		213
188	=head2 UTILITY FUNCTIONS	214	=head2 UTILITY FUNCTIONS
189		215
190	=over 4	216	=over 4
191		217
…		…
234	returned.	260	returned.
235		261
236	Lock names should begin with a unique identifier (for example, cf::map::find	262	Lock names should begin with a unique identifier (for example, cf::map::find
237	uses map_find and cf::map::load uses map_load).	263	uses map_find and cf::map::load uses map_load).
238		264
		265	=item $locked = cf::lock_active $string
		266
		267	Return true if the lock is currently active, i.e. somebody has locked it.
		268
239	=cut	269	=cut
240		270
241	our %LOCK;	271	our %LOCK;
242		272
243	sub lock_wait($) {	273	sub lock_wait($) {
…		…
260		290
261	Coro::guard {	291	Coro::guard {
262	# wake up all waiters, to be on the safe side	292	# wake up all waiters, to be on the safe side
263	$_->ready for @{ delete $LOCK{$key} };	293	$_->ready for @{ delete $LOCK{$key} };
264	}	294	}
		295	}
		296
		297	sub lock_active($) {
		298	my ($key) = @_;
		299
		300	! ! $LOCK{$key}
265	}	301	}
266		302
267	sub freeze_mainloop {	303	sub freeze_mainloop {
268	return unless $TICK_WATCHER->is_active;	304	return unless $TICK_WATCHER->is_active;
269		305
…		…
284		320
285	BEGIN { *async = \&Coro::async_pool }	321	BEGIN { *async = \&Coro::async_pool }
286		322
287	=item cf::sync_job { BLOCK }	323	=item cf::sync_job { BLOCK }
288		324
289	The design of crossfire+ requires that the main coro ($Coro::main) is	325	The design of Crossfire TRT requires that the main coroutine ($Coro::main)
290	always able to handle events or runnable, as crossfire+ is only partly	326	is always able to handle events or runnable, as Crossfire TRT is only
291	reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.	327	partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
		328	acceptable.
292		329
293	If it must be done, put the blocking parts into C<sync_job>. This will run	330	If it must be done, put the blocking parts into C<sync_job>. This will run
294	the given BLOCK in another coroutine while waiting for the result. The	331	the given BLOCK in another coroutine while waiting for the result. The
295	server will be frozen during this time, so the block should either finish	332	server will be frozen during this time, so the block should either finish
296	fast or be very important.	333	fast or be very important.
…		…
299		336
300	sub sync_job(&) {	337	sub sync_job(&) {
301	my ($job) = @_;	338	my ($job) = @_;
302		339
303	if ($Coro::current == $Coro::main) {	340	if ($Coro::current == $Coro::main) {
		341	my $time = Event::time;
		342
304	# this is the main coro, too bad, we have to block	343	# this is the main coro, too bad, we have to block
305	# till the operation succeeds, freezing the server :/	344	# till the operation succeeds, freezing the server :/
306		345
307	# TODO: use suspend/resume instead	346	# TODO: use suspend/resume instead
308	# (but this is cancel-safe)	347	# (but this is cancel-safe)
…		…
319		358
320	while ($busy) {	359	while ($busy) {
321	Coro::cede or Event::one_event;	360	Coro::cede or Event::one_event;
322	}	361	}
323		362
		363	$time = Event::time - $time;
		364
		365	LOG llevError | logBacktrace, Carp::longmess "long sync job"
		366	if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
		367
		368	$tick_start += $time; # do not account sync jobs to server load
		369
324	wantarray ? @res : $res[0]	370	wantarray ? @res : $res[0]
325	} else {	371	} else {
326	# we are in another coroutine, how wonderful, everything just works	372	# we are in another coroutine, how wonderful, everything just works
327		373
328	$job->()	374	$job->()
…		…
347	$EXT_CORO{$coro+0} = $coro;	393	$EXT_CORO{$coro+0} = $coro;
348		394
349	$coro	395	$coro
350	}	396	}
351		397
352	sub write_runtime {	398	=item fork_call { }, $args
353	my $guard = cf::lock_acquire "write_runtime";
354		399
355	my $runtime = cf::localdir . "/runtime";	400	Executes the given code block with the given arguments in a seperate
		401	process, returning the results. Everything must be serialisable with
		402	Coro::Storable. May, of course, block. Note that the executed sub may
		403	never block itself or use any form of Event handling.
356		404
357	my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644	405	=cut
358	or return;
359		406
360	my $value = $cf::RUNTIME + 90 + 10;	407	sub fork_call(&@) {
361	# 10 is the runtime save interval, for a monotonic clock	408	my ($cb, @args) = @_;
362	# 60 allows for the watchdog to kill the server.
363		409
364	(aio_write $fh, 0, (length $value), $value, 0) <= 0	410	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
365	and return;	411	# or die "socketpair: $!";
		412	pipe my $fh1, my $fh2
		413	or die "pipe: $!";
366		414
367	# always fsync - this file is important	415	if (my $pid = fork) {
368	aio_fsync $fh
369	and return;
370
371	close $fh	416	close $fh2;
372	or return;
373		417
374	aio_rename "$runtime~", $runtime	418	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
375	and return;	419	$res = Coro::Storable::thaw $res;
376		420
		421	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
		422
		423	die $$res unless "ARRAY" eq ref $res;
		424
		425	return wantarray ? @$res : $res->[-1];
		426	} else {
		427	reset_signals;
		428	local $SIG{__WARN__};
		429	local $SIG{__DIE__};
		430	eval {
		431	close $fh1;
		432
		433	my @res = eval { $cb->(@args) };
		434	syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
		435	};
		436
		437	warn $@ if $@;
		438	_exit 0;
377	1	439	}
		440	}
		441
		442	=item $value = cf::db_get $family => $key
		443
		444	Returns a single value from the environment database.
		445
		446	=item cf::db_put $family => $key => $value
		447
		448	Stores the given C<$value> in the family. It can currently store binary
		449	data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
		450
		451	=cut
		452
		453	our $DB;
		454
		455	sub db_init {
		456	unless ($DB) {
		457	$DB = BDB::db_create $DB_ENV;
		458
		459	cf::sync_job {
		460	eval {
		461	$DB->set_flags (BDB::CHKSUM);
		462
		463	BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
		464	BDB::CREATE | BDB::AUTO_COMMIT, 0666;
		465	cf::cleanup "db_open(db): $!" if $!;
		466	};
		467	cf::cleanup "db_open(db): $@" if $@;
		468	};
		469	}
		470	}
		471
		472	sub db_get($$) {
		473	my $key = "$_[0]/$_[1]";
		474
		475	cf::sync_job {
		476	BDB::db_get $DB, undef, $key, my $data;
		477
		478	$! ? ()
		479	: $data
		480	}
		481	}
		482
		483	sub db_put($$$) {
		484	BDB::dbreq_pri 4;
		485	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
		486	}
		487
		488	=item cf::cache $id => [$paths...], $processversion => $process
		489
		490	Generic caching function that returns the value of the resource $id,
		491	caching and regenerating as required.
		492
		493	This function can block.
		494
		495	=cut
		496
		497	sub cache {
		498	my ($id, $src, $processversion, $process) = @_;
		499
		500	my $meta =
		501	join "\x00",
		502	$processversion,
		503	map {
		504	aio_stat $_
		505	and Carp::croak "$_: $!";
		506
		507	($_, (stat _)[7,9])
		508	} @$src;
		509
		510	my $dbmeta = db_get cache => "$id/meta";
		511	if ($dbmeta ne $meta) {
		512	# changed, we may need to process
		513
		514	my @data;
		515	my $md5;
		516
		517	for (0 .. $#$src) {
		518	0 <= aio_load $src->[$_], $data[$_]
		519	or Carp::croak "$src->[$_]: $!";
		520	}
		521
		522	# if processing is expensive, check
		523	# checksum first
		524	if (1) {
		525	$md5 =
		526	join "\x00",
		527	$processversion,
		528	map {
		529	Coro::cede;
		530	($src->[$_], Digest::MD5::md5_hex $data[$_])
		531	} 0.. $#$src;
		532
		533
		534	my $dbmd5 = db_get cache => "$id/md5";
		535	if ($dbmd5 eq $md5) {
		536	db_put cache => "$id/meta", $meta;
		537
		538	return db_get cache => "$id/data";
		539	}
		540	}
		541
		542	my $t1 = Time::HiRes::time;
		543	my $data = $process->(\@data);
		544	my $t2 = Time::HiRes::time;
		545
		546	warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
		547
		548	db_put cache => "$id/data", $data;
		549	db_put cache => "$id/md5" , $md5;
		550	db_put cache => "$id/meta", $meta;
		551
		552	return $data;
		553	}
		554
		555	db_get cache => "$id/data"
378	}	556	}
379		557
380	=item cf::datalog type => key => value, ...	558	=item cf::datalog type => key => value, ...
381		559
382	Log a datalog packet of the given type with the given key-value pairs.	560	Log a datalog packet of the given type with the given key-value pairs.
…		…
400	attach callbacks/event handlers (a collection of which is called an "attachment")	578	attach callbacks/event handlers (a collection of which is called an "attachment")
401	to it. All such attachable objects support the following methods.	579	to it. All such attachable objects support the following methods.
402		580
403	In the following description, CLASS can be any of C<global>, C<object>	581	In the following description, CLASS can be any of C<global>, C<object>
404	C<player>, C<client> or C<map> (i.e. the attachable objects in	582	C<player>, C<client> or C<map> (i.e. the attachable objects in
405	crossfire+).	583	Crossfire TRT).
406		584
407	=over 4	585	=over 4
408		586
409	=item $attachable->attach ($attachment, key => $value...)	587	=item $attachable->attach ($attachment, key => $value...)
410		588
…		…
573	$registry = $CB_TYPE[$object_type] ||= [];	751	$registry = $CB_TYPE[$object_type] ||= [];
574		752
575	} elsif ($type eq "subtype") {	753	} elsif ($type eq "subtype") {
576	defined $object_type or Carp::croak "subtype specified without type";	754	defined $object_type or Carp::croak "subtype specified without type";
577	my $object_subtype = shift @arg;	755	my $object_subtype = shift @arg;
578	$registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];	756	$registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
579		757
580	} elsif ($type eq "package") {	758	} elsif ($type eq "package") {
581	my $pkg = shift @arg;	759	my $pkg = shift @arg;
582		760
583	while (my ($name, $id) = each %cb_id) {	761	while (my ($name, $id) = each %cb_id) {
…		…
612	_attach $registry, $klass, @attach;	790	_attach $registry, $klass, @attach;
613	}	791	}
614		792
615	$obj->{$name} = \%arg;	793	$obj->{$name} = \%arg;
616	} else {	794	} else {
617	warn "object uses attachment '$name' that is not available, postponing.\n";	795	warn "object uses attachment '$name' which is not available, postponing.\n";
618	}	796	}
619		797
620	$obj->{_attachment}{$name} = undef;	798	$obj->{_attachment}{$name} = undef;
621	}	799	}
622		800
…		…
624	if (ref $_[0]) {	802	if (ref $_[0]) {
625	_object_attach @_;	803	_object_attach @_;
626	} else {	804	} else {
627	_attach shift->_attach_registry, @_;	805	_attach shift->_attach_registry, @_;
628	}	806	}
		807	_recalc_want;
629	};	808	};
630		809
631	# all those should be optimised	810	# all those should be optimised
632	sub cf::attachable::detach {	811	sub cf::attachable::detach {
633	my ($obj, $name) = @_;	812	my ($obj, $name) = @_;
…		…
636	delete $obj->{_attachment}{$name};	815	delete $obj->{_attachment}{$name};
637	reattach ($obj);	816	reattach ($obj);
638	} else {	817	} else {
639	Carp::croak "cannot, currently, detach class attachments";	818	Carp::croak "cannot, currently, detach class attachments";
640	}	819	}
		820	_recalc_want;
641	};	821	};
642		822
643	sub cf::attachable::attached {	823	sub cf::attachable::attached {
644	my ($obj, $name) = @_;	824	my ($obj, $name) = @_;
645		825
…		…
818	or return;	998	or return;
819	$av = eval { (Storable::thaw $av)->{objs} };	999	$av = eval { (Storable::thaw $av)->{objs} };
820	}	1000	}
821		1001
822	warn sprintf "loading %s (%d)\n",	1002	warn sprintf "loading %s (%d)\n",
823	$filename, length $data, scalar @{$av || []};#d#	1003	$filename, length $data, scalar @{$av || []};
824	return ($data, $av);	1004	return ($data, $av);
825	}	1005	}
		1006
		1007	=head2 COMMAND CALLBACKS
		1008
		1009	=over 4
		1010
		1011	=cut
826		1012
827	#############################################################################	1013	#############################################################################
828	# command handling &c	1014	# command handling &c
829		1015
830	=item cf::register_command $name => \&callback($ob,$args);	1016	=item cf::register_command $name => \&callback($ob,$args);
…		…
843	push @{ $COMMAND{$name} }, [$caller, $cb];	1029	push @{ $COMMAND{$name} }, [$caller, $cb];
844	}	1030	}
845		1031
846	=item cf::register_extcmd $name => \&callback($pl,$packet);	1032	=item cf::register_extcmd $name => \&callback($pl,$packet);
847		1033
848	Register a callbackf ro execution when the client sends an extcmd packet.	1034	Register a callback fro execution when the client sends an extcmd packet.
849		1035
850	If the callback returns something, it is sent back as if reply was being	1036	If the callback returns something, it is sent back as if reply was being
851	called.	1037	called.
852		1038
853	=cut	1039	=cut
…		…
888		1074
889	cf::override;	1075	cf::override;
890	},	1076	},
891	);	1077	);
892		1078
893	sub load_extension {
894	my ($path) = @_;
895
896	$path =~ /([^\/\\]+)\.ext$/ or die "$path";
897	my $base = $1;
898	my $pkg = $1;
899	$pkg =~ s/[^[:word:]]/_/g;
900	$pkg = "ext::$pkg";
901
902	warn "... loading '$path' into '$pkg'\n";
903
904	open my $fh, "<:utf8", $path
905	or die "$path: $!";
906
907	my $source =
908	"package $pkg; use strict; use utf8;\n"
909	. "#line 1 \"$path\"\n{\n"
910	. (do { local $/; <$fh> })
911	. "\n};\n1";
912
913	unless (eval $source) {
914	my $msg = $@ ? "$path: $@\n"
915	: "extension disabled.\n";
916	if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
917	warn $@;
918	warn "mandatory extension failed to load, exiting.\n";
919	exit 1;
920	}
921	die $@;
922	}
923
924	push @EXTS, $pkg;
925	}
926
927	sub load_extensions {	1079	sub load_extensions {
		1080	cf::sync_job {
		1081	my %todo;
		1082
928	for my $ext (<$LIBDIR/*.ext>) {	1083	for my $path (<$LIBDIR/*.ext>) {
929	next unless -r $ext;	1084	next unless -r $path;
930	eval {	1085
931	load_extension $ext;	1086	$path =~ /([^\/\\]+)\.ext$/ or die "$path";
		1087	my $base = $1;
		1088	my $pkg = $1;
		1089	$pkg =~ s/[^[:word:]]/_/g;
		1090	$pkg = "ext::$pkg";
		1091
		1092	open my $fh, "<:utf8", $path
		1093	or die "$path: $!";
		1094
		1095	my $source = do { local $/; <$fh> };
		1096
		1097	my %ext = (
		1098	path => $path,
		1099	base => $base,
		1100	pkg => $pkg,
		1101	);
		1102
		1103	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
		1104	if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
		1105
		1106	$ext{source} =
		1107	"package $pkg; use strict; use utf8;\n"
		1108	. "#line 1 \"$path\"\n{\n"
		1109	. $source
		1110	. "\n};\n1";
		1111
		1112	$todo{$base} = \%ext;
		1113	}
		1114
		1115	my %done;
		1116	while (%todo) {
		1117	my $progress;
		1118
		1119	while (my ($k, $v) = each %todo) {
		1120	for (split /,\s*/, $v->{meta}{depends}) {
		1121	goto skip
		1122	unless exists $done{$_};
		1123	}
		1124
		1125	warn "... loading '$k' into '$v->{pkg}'\n";
		1126
		1127	unless (eval $v->{source}) {
		1128	my $msg = $@ ? "$v->{path}: $@\n"
		1129	: "$v->{base}: extension inactive.\n";
		1130
		1131	if (exists $v->{meta}{mandatory}) {
		1132	warn $msg;
		1133	warn "mandatory extension failed to load, exiting.\n";
		1134	exit 1;
		1135	}
		1136
		1137	warn $msg;
		1138	}
		1139
		1140	$done{$k} = delete $todo{$k};
		1141	push @EXTS, $v->{pkg};
		1142	$progress = 1;
932	1	1143	}
933	} or warn "$ext not loaded: $@";	1144
		1145	skip:
		1146	die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
		1147	unless $progress;
		1148	}
934	}	1149	};
935	}	1150	}
936		1151
937	#############################################################################	1152	#############################################################################
938		1153
		1154	=back
		1155
939	=head2 CORE EXTENSIONS	1156	=head2 CORE EXTENSIONS
940		1157
941	Functions and methods that extend core crossfire objects.	1158	Functions and methods that extend core crossfire objects.
942		1159
943	=cut	1160	=cut
…		…
955	Returns the given player object, loading it if necessary (might block).	1172	Returns the given player object, loading it if necessary (might block).
956		1173
957	=cut	1174	=cut
958		1175
959	sub playerdir($) {	1176	sub playerdir($) {
960	cf::localdir	1177	"$PLAYERDIR/"
961	. "/"
962	. cf::playerdir
963	. "/"
964	. (ref $_[0] ? $_[0]->ob->name : $_[0])	1178	. (ref $_[0] ? $_[0]->ob->name : $_[0])
965	}	1179	}
966		1180
967	sub path($) {	1181	sub path($) {
968	my $login = ref $_[0] ? $_[0]->ob->name : $_[0];	1182	my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
…		…
1088	while and may block, so not sync_job-capable, ever.	1302	while and may block, so not sync_job-capable, ever.
1089		1303
1090	=cut	1304	=cut
1091		1305
1092	sub list_logins {	1306	sub list_logins {
1093	my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir	1307	my $dirs = aio_readdir $PLAYERDIR
1094	or return [];	1308	or return [];
1095		1309
1096	my @logins;	1310	my @logins;
1097		1311
1098	for my $login (@$dirs) {	1312	for my $login (@$dirs) {
…		…
1169		1383
1170	package cf::region;	1384	package cf::region;
1171		1385
1172	=item cf::region::find_by_path $path	1386	=item cf::region::find_by_path $path
1173		1387
1174	Tries to decuce the probable region for a map knowing only its path.	1388	Tries to decuce the likely region for a map knowing only its path.
1175		1389
1176	=cut	1390	=cut
1177		1391
1178	sub find_by_path($) {	1392	sub find_by_path($) {
1179	my ($path) = @_;	1393	my ($path) = @_;
…		…
1253	my ($self, $merge) = @_;	1467	my ($self, $merge) = @_;
1254		1468
1255	# we have to keep some variables in memory intact	1469	# we have to keep some variables in memory intact
1256	local $self->{path};	1470	local $self->{path};
1257	local $self->{load_path};	1471	local $self->{load_path};
1258	local $self->{deny_save};
1259	local $self->{deny_reset};
1260		1472
1261	$self->SUPER::thawer_merge ($merge);	1473	$self->SUPER::thawer_merge ($merge);
1262	}	1474	}
1263		1475
1264	sub normalise {	1476	sub normalise {
…		…
1336		1548
1337	# the original (read-only) location	1549	# the original (read-only) location
1338	sub load_path {	1550	sub load_path {
1339	my ($self) = @_;	1551	my ($self) = @_;
1340		1552
1341	sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path}	1553	"$MAPDIR/$self->{path}.map"
1342	}	1554	}
1343		1555
1344	# the temporary/swap location	1556	# the temporary/swap location
1345	sub save_path {	1557	sub save_path {
1346	my ($self) = @_;	1558	my ($self) = @_;
1347		1559
1348	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;	1560	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1349	sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path	1561	"$TMPDIR/$path.map"
1350	}	1562	}
1351		1563
1352	# the unique path, undef == no special unique path	1564	# the unique path, undef == no special unique path
1353	sub uniq_path {	1565	sub uniq_path {
1354	my ($self) = @_;	1566	my ($self) = @_;
1355		1567
1356	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;	1568	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1357	sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path	1569	"$UNIQUEDIR/$path"
1358	}	1570	}
1359		1571
1360	# and all this just because we cannot iterate over	1572	# and all this just because we cannot iterate over
1361	# all maps in C++...	1573	# all maps in C++...
1362	sub change_all_map_light {	1574	sub change_all_map_light {
1363	my ($change) = @_;	1575	my ($change) = @_;
1364		1576
1365	$_->change_map_light ($change)	1577	$_->change_map_light ($change)
1366	for grep $_->outdoor, values %cf::MAP;	1578	for grep $_->outdoor, values %cf::MAP;
		1579	}
		1580
		1581	sub decay_objects {
		1582	my ($self) = @_;
		1583
		1584	return if $self->{deny_reset};
		1585
		1586	$self->do_decay_objects;
1367	}	1587	}
1368		1588
1369	sub unlink_save {	1589	sub unlink_save {
1370	my ($self) = @_;	1590	my ($self) = @_;
1371		1591
…		…
1429	$self->load_header_orig	1649	$self->load_header_orig
1430	or return;	1650	or return;
1431	$self->prepare_orig;	1651	$self->prepare_orig;
1432	}	1652	}
1433		1653
		1654	$self->{deny_reset} = 1
		1655	if $self->no_reset;
		1656
1434	$self->default_region (cf::region::find_by_path $self->{path})	1657	$self->default_region (cf::region::find_by_path $self->{path})
1435	unless $self->default_region;	1658	unless $self->default_region;
1436		1659
1437	1	1660	1
1438	}	1661	}
…		…
1453	$map->{last_save} = $cf::RUNTIME;	1676	$map->{last_save} = $cf::RUNTIME;
1454		1677
1455	$map->load_header	1678	$map->load_header
1456	or return;	1679	or return;
1457		1680
1458	if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?)	1681	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1459	# doing this can freeze the server in a sync job, obviously	1682	# doing this can freeze the server in a sync job, obviously
1460	#$cf::WAIT_FOR_TICK->wait;	1683	#$cf::WAIT_FOR_TICK->wait;
1461	$map->reset;	1684	$map->reset;
1462	undef $guard;	1685	undef $guard;
1463	return find $path;	1686	return find $path;
…		…
1474	my ($self) = @_;	1697	my ($self) = @_;
1475		1698
1476	local $self->{deny_reset} = 1; # loading can take a long time	1699	local $self->{deny_reset} = 1; # loading can take a long time
1477		1700
1478	my $path = $self->{path};	1701	my $path = $self->{path};
		1702
		1703	{
1479	my $guard = cf::lock_acquire "map_load:$path";	1704	my $guard = cf::lock_acquire "map_load:$path";
1480		1705
1481	return if $self->in_memory != cf::MAP_SWAPPED;	1706	return if $self->in_memory != cf::MAP_SWAPPED;
1482		1707
1483	$self->in_memory (cf::MAP_LOADING);	1708	$self->in_memory (cf::MAP_LOADING);
1484		1709
1485	$self->alloc;	1710	$self->alloc;
1486		1711
1487	$self->pre_load;	1712	$self->pre_load;
1488	Coro::cede;
1489
1490	$self->_load_objects ($self->{load_path}, 1)
1491	or return;
1492
1493	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1494	if delete $self->{load_original};
1495
1496	if (my $uniq = $self->uniq_path) {
1497	utf8::encode $uniq;
1498	if (aio_open $uniq, O_RDONLY, 0) {
1499	$self->clear_unique_items;
1500	$self->_load_objects ($uniq, 0);
1501	}
1502	}
1503
1504	Coro::cede;
1505	# now do the right thing for maps
1506	$self->link_multipart_objects;
1507	Coro::cede;
1508
1509	unless ($self->{deny_activate}) {
1510	$self->decay_objects;
1511	$self->fix_auto_apply;
1512	$self->update_buttons;
1513	Coro::cede;	1713	Coro::cede;
1514	$self->set_darkness_map;	1714
		1715	$self->_load_objects ($self->{load_path}, 1)
		1716	or return;
		1717
		1718	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
		1719	if delete $self->{load_original};
		1720
		1721	if (my $uniq = $self->uniq_path) {
		1722	utf8::encode $uniq;
		1723	if (aio_open $uniq, O_RDONLY, 0) {
		1724	$self->clear_unique_items;
		1725	$self->_load_objects ($uniq, 0);
		1726	}
		1727	}
		1728
		1729	Coro::cede;
		1730	# now do the right thing for maps
		1731	$self->link_multipart_objects;
1515	$self->difficulty ($self->estimate_difficulty)	1732	$self->difficulty ($self->estimate_difficulty)
1516	unless $self->difficulty;	1733	unless $self->difficulty;
1517	Coro::cede;	1734	Coro::cede;
		1735
		1736	unless ($self->{deny_activate}) {
		1737	$self->decay_objects;
		1738	$self->fix_auto_apply;
		1739	$self->update_buttons;
		1740	Coro::cede;
		1741	$self->set_darkness_map;
		1742	Coro::cede;
1518	$self->activate;	1743	$self->activate;
1519	Coro::cede;	1744	}
		1745
		1746	$self->in_memory (cf::MAP_IN_MEMORY);
1520	}	1747	}
1521		1748
1522	$self->post_load;	1749	$self->post_load;
1523	Coro::cede;
1524
1525	$self->in_memory (cf::MAP_IN_MEMORY);
1526	}	1750	}
1527		1751
1528	sub customise_for {	1752	sub customise_for {
1529	my ($self, $ob) = @_;	1753	my ($self, $ob) = @_;
1530		1754
1531	return find "~" . $ob->name . "/" . $self->{path}	1755	return find "~" . $ob->name . "/" . $self->{path}
1532	if $self->per_player;	1756	if $self->per_player;
		1757
		1758	# return find "?party/" . $ob->name . "/" . $self->{path}
		1759	# if $self->per_party;
1533		1760
1534	$self	1761	$self
1535	}	1762	}
1536		1763
1537	# find and load all maps in the 3x3 area around a map	1764	# find and load all maps in the 3x3 area around a map
…		…
1648		1875
1649	sub reset_at {	1876	sub reset_at {
1650	my ($self) = @_;	1877	my ($self) = @_;
1651		1878
1652	# TODO: safety, remove and allow resettable per-player maps	1879	# TODO: safety, remove and allow resettable per-player maps
1653	return 1e99 if $self->isa ("ext::map_per_player");#d#
1654	return 1e99 if $self->{deny_reset};	1880	return 1e99 if $self->{deny_reset};
1655		1881
1656	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;	1882	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1657	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;	1883	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1658		1884
…		…
1669	my ($self) = @_;	1895	my ($self) = @_;
1670		1896
1671	my $lock = cf::lock_acquire "map_data:$self->{path}";	1897	my $lock = cf::lock_acquire "map_data:$self->{path}";
1672		1898
1673	return if $self->players;	1899	return if $self->players;
1674	return if $self->isa ("ext::map_per_player");#d#
1675		1900
1676	warn "resetting map ", $self->path;#d#	1901	warn "resetting map ", $self->path;
1677		1902
1678	$self->in_memory (cf::MAP_SWAPPED);	1903	$self->in_memory (cf::MAP_SWAPPED);
1679		1904
1680	# need to save uniques path	1905	# need to save uniques path
1681	unless ($self->{deny_save}) {	1906	unless ($self->{deny_save}) {
…		…
1713	$cf::MAP{$self->path} = $self;	1938	$cf::MAP{$self->path} = $self;
1714		1939
1715	$self->reset; # polite request, might not happen	1940	$self->reset; # polite request, might not happen
1716	}	1941	}
1717		1942
		1943	=item $maps = cf::map::tmp_maps
		1944
		1945	Returns an arrayref with all map paths of currently instantiated and saved
		1946	maps. May block.
		1947
		1948	=cut
		1949
		1950	sub tmp_maps() {
		1951	[
		1952	map {
		1953	utf8::decode $_;
		1954	/\.map$/
		1955	? normalise $_
		1956	: ()
		1957	} @{ aio_readdir $TMPDIR or [] }
		1958	]
		1959	}
		1960
		1961	=item $maps = cf::map::random_maps
		1962
		1963	Returns an arrayref with all map paths of currently instantiated and saved
		1964	random maps. May block.
		1965
		1966	=cut
		1967
		1968	sub random_maps() {
		1969	[
		1970	map {
		1971	utf8::decode $_;
		1972	/\.map$/
		1973	? normalise "?random/$_"
		1974	: ()
		1975	} @{ aio_readdir $RANDOMDIR or [] }
		1976	]
		1977	}
		1978
1718	=item cf::map::unique_maps	1979	=item cf::map::unique_maps
1719		1980
1720	Returns an arrayref of paths of all shared maps that have	1981	Returns an arrayref of paths of all shared maps that have
1721	instantiated unique items. May block.	1982	instantiated unique items. May block.
1722		1983
1723	=cut	1984	=cut
1724		1985
1725	sub unique_maps() {	1986	sub unique_maps() {
1726	my $files = aio_readdir cf::localdir . "/" . cf::uniquedir	1987	[
1727	or return;	1988	map {
1728
1729	my @paths;
1730
1731	for (@$files) {
1732	utf8::decode $_;	1989	utf8::decode $_;
1733	next if /\.pst$/;	1990	/\.map$/
1734	next unless /^$PATH_SEP/o;	1991	? normalise $_
1735		1992	: ()
1736	push @paths, cf::map::normalise $_;	1993	} @{ aio_readdir $UNIQUEDIR or [] }
1737	}	1994	]
1738
1739	\@paths
1740	}	1995	}
1741		1996
1742	package cf;	1997	package cf;
1743		1998
1744	=back	1999	=back
…		…
1790		2045
1791	$flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;	2046	$flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1792		2047
1793	if ($self->{record_replies}) {	2048	if ($self->{record_replies}) {
1794	push @{ $self->{record_replies} }, [$npc, $msg, $flags];	2049	push @{ $self->{record_replies} }, [$npc, $msg, $flags];
		2050
1795	} else {	2051	} else {
		2052	my $pl = $self->contr;
		2053
		2054	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
		2055	my $diag = $pl->{npc_dialog};
		2056	$diag->{pl}->ext_reply (
		2057	$diag->{id}, msgtype => "reply", msg => $msg, add_topics => []
		2058	);
		2059
		2060	} else {
1796	$msg = $npc->name . " says: $msg" if $npc;	2061	$msg = $npc->name . " says: $msg" if $npc;
1797	$self->message ($msg, $flags);	2062	$self->message ($msg, $flags);
		2063	}
1798	}	2064	}
1799	}	2065	}
1800		2066
1801	=item $player_object->may ("access")	2067	=item $player_object->may ("access")
1802		2068
…		…
1850	$self->deactivate_recursive;	2116	$self->deactivate_recursive;
1851		2117
1852	return if UNIVERSAL::isa $self->map, "ext::map_link";	2118	return if UNIVERSAL::isa $self->map, "ext::map_link";
1853		2119
1854	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]	2120	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1855	if $self->map;	2121	if $self->map && $self->map->{path} ne "{link}";
1856		2122
1857	$self->enter_map ($LINK_MAP || link_map, 10, 10);	2123	$self->enter_map ($LINK_MAP || link_map, 10, 10);
1858	}	2124	}
1859		2125
1860	sub cf::object::player::leave_link {	2126	sub cf::object::player::leave_link {
1861	my ($self, $map, $x, $y) = @_;	2127	my ($self, $map, $x, $y) = @_;
		2128
		2129	return unless $self->contr->active;
1862		2130
1863	my $link_pos = delete $self->{_link_pos};	2131	my $link_pos = delete $self->{_link_pos};
1864		2132
1865	unless ($map) {	2133	unless ($map) {
1866	# restore original map position	2134	# restore original map position
…		…
1889		2157
1890	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2158	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1891	$self->enter_map ($map, $x, $y);	2159	$self->enter_map ($map, $x, $y);
1892	}	2160	}
1893		2161
1894	cf::player->attach (
1895	on_logout => sub {
1896	my ($pl) = @_;
1897
1898	# abort map switching before logout
1899	if ($pl->ob->{_link_pos}) {
1900	cf::sync_job {
1901	$pl->ob->leave_link
1902	};
1903	}
1904	},
1905	on_login => sub {
1906	my ($pl) = @_;
1907
1908	# try to abort aborted map switching on player login :)
1909	# should happen only on crashes
1910	if ($pl->ob->{_link_pos}) {
1911	$pl->ob->enter_link;
1912	(async {
1913	$pl->ob->reply (undef,
1914	"There was an internal problem at your last logout, "
1915	. "the server will try to bring you to your intended destination in a second.",
1916	cf::NDI_RED);
1917	# we need this sleep as the login has a concurrent enter_exit running
1918	# and this sleep increases chances of the player not ending up in scorn
1919	Coro::Timer::sleep 1;
1920	$pl->ob->leave_link;
1921	})->prio (2);
1922	}
1923	},
1924	);
1925
1926	=item $player_object->goto ($path, $x, $y)	2162	=item $player_object->goto ($path, $x, $y[, $check->($map)])
1927		2163
		2164	Moves the player to the given map-path and coordinates by first freezing
		2165	her, loading and preparing them map, calling the provided $check callback
		2166	that has to return the map if sucecssful, and then unfreezes the player on
		2167	the new (success) or old (failed) map position.
		2168
1928	=cut	2169	=cut
		2170
		2171	our $GOTOGEN;
1929		2172
1930	sub cf::object::player::goto {	2173	sub cf::object::player::goto {
1931	my ($self, $path, $x, $y) = @_;	2174	my ($self, $path, $x, $y, $check) = @_;
		2175
		2176	# do generation counting so two concurrent goto's will be executed in-order
		2177	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1932		2178
1933	$self->enter_link;	2179	$self->enter_link;
1934		2180
1935	(async {	2181	(async {
1936	my $map = eval {	2182	my $map = eval {
1937	my $map = cf::map::find $path;	2183	my $map = cf::map::find $path;
		2184
		2185	if ($map) {
1938	$map = $map->customise_for ($self) if $map;	2186	$map = $map->customise_for ($self);
		2187	$map = $check->($map) if $check && $map;
		2188	} else {
		2189	$self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
		2190	}
		2191
1939	$map	2192	$map
		2193	};
		2194
		2195	if ($@) {
		2196	$self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
		2197	LOG llevError | logBacktrace, Carp::longmess $@;
1940	} or	2198	}
1941	$self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1942		2199
		2200	if ($gen == $self->{_goto_generation}) {
		2201	delete $self->{_goto_generation};
1943	$self->leave_link ($map, $x, $y);	2202	$self->leave_link ($map, $x, $y);
		2203	}
1944	})->prio (1);	2204	})->prio (1);
1945	}	2205	}
1946		2206
1947	=item $player_object->enter_exit ($exit_object)	2207	=item $player_object->enter_exit ($exit_object)
1948		2208
…		…
1987		2247
1988	$rmp->{random_seed} ||= $exit->random_seed;	2248	$rmp->{random_seed} ||= $exit->random_seed;
1989		2249
1990	my $data = cf::to_json $rmp;	2250	my $data = cf::to_json $rmp;
1991	my $md5 = Digest::MD5::md5_hex $data;	2251	my $md5 = Digest::MD5::md5_hex $data;
1992	my $meta = "$cf::RANDOM_MAPS/$md5.meta";	2252	my $meta = "$RANDOMDIR/$md5.meta";
1993		2253
1994	if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {	2254	if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1995	aio_write $fh, 0, (length $data), $data, 0;	2255	aio_write $fh, 0, (length $data), $data, 0;
1996	undef $fh;	2256	undef $fh;
1997	aio_rename "$meta~", $meta;	2257	aio_rename "$meta~", $meta;
…		…
2262	=back	2522	=back
2263		2523
2264	=cut	2524	=cut
2265		2525
2266	#############################################################################	2526	#############################################################################
2267
2268	=head2 EXTENSION DATABASE SUPPORT
2269
2270	Crossfire maintains a very simple database for extension use. It can
2271	currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2272	convert to/from binary).
2273
2274	The parameter C<$family> should best start with the name of the extension
2275	using it, it should be unique.
2276
2277	=over 4
2278
2279	=item $value = cf::db_get $family => $key
2280
2281	Returns a single value from the database.
2282
2283	=item cf::db_put $family => $key => $value
2284
2285	Stores the given C<$value> in the family.
2286
2287	=cut
2288
2289	our $DB;
2290
2291	sub db_init {
2292	unless ($DB) {
2293	$DB = BDB::db_create $DB_ENV;
2294
2295	cf::sync_job {
2296	eval {
2297	$DB->set_flags (BDB::CHKSUM);
2298
2299	BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2300	BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2301	cf::cleanup "db_open(db): $!" if $!;
2302	};
2303	cf::cleanup "db_open(db): $@" if $@;
2304	};
2305	}
2306	}
2307
2308	sub db_get($$) {
2309	my $key = "$_[0]/$_[1]";
2310
2311	cf::sync_job {
2312	BDB::db_get $DB, undef, $key, my $data;
2313
2314	$! ? ()
2315	: $data
2316	}
2317	}
2318
2319	sub db_put($$$) {
2320	BDB::dbreq_pri 4;
2321	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2322	}
2323
2324	=item cf::cache $id => [$paths...], $processversion => $process
2325
2326	Generic caching function that returns the value of the resource $id,
2327	caching and regenerating as required.
2328
2329	This function can block.
2330
2331	=cut
2332
2333	sub cache {
2334	my ($id, $src, $processversion, $process) = @_;
2335
2336	my $meta =
2337	join "\x00",
2338	$processversion,
2339	map {
2340	aio_stat $_
2341	and Carp::croak "$_: $!";
2342
2343	($_, (stat _)[7,9])
2344	} @$src;
2345
2346	my $dbmeta = db_get cache => "$id/meta";
2347	if ($dbmeta ne $meta) {
2348	# changed, we may need to process
2349
2350	my @data;
2351	my $md5;
2352
2353	for (0 .. $#$src) {
2354	0 <= aio_load $src->[$_], $data[$_]
2355	or Carp::croak "$src->[$_]: $!";
2356	}
2357
2358	# if processing is expensive, check
2359	# checksum first
2360	if (1) {
2361	$md5 =
2362	join "\x00",
2363	$processversion,
2364	map {
2365	Coro::cede;
2366	($src->[$_], Digest::MD5::md5_hex $data[$_])
2367	} 0.. $#$src;
2368
2369
2370	my $dbmd5 = db_get cache => "$id/md5";
2371	if ($dbmd5 eq $md5) {
2372	db_put cache => "$id/meta", $meta;
2373
2374	return db_get cache => "$id/data";
2375	}
2376	}
2377
2378	my $data = $process->(\@data);
2379
2380	db_put cache => "$id/data", $data;
2381	db_put cache => "$id/md5" , $md5;
2382	db_put cache => "$id/meta", $meta;
2383
2384	return $data;
2385	}
2386
2387	db_get cache => "$id/data"
2388	}
2389
2390	=item fork_call { }, $args
2391
2392	Executes the given code block with the given arguments in a seperate
2393	process, returning the results. Everything must be serialisable with
2394	Coro::Storable. May, of course, block. Note that the executed sub may
2395	never block itself or use any form of Event handling.
2396
2397	=cut
2398
2399	sub fork_call(&@) {
2400	my ($cb, @args) = @_;
2401
2402	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2403	# or die "socketpair: $!";
2404	pipe my $fh1, my $fh2
2405	or die "pipe: $!";
2406
2407	if (my $pid = fork) {
2408	close $fh2;
2409
2410	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2411	$res = Coro::Storable::thaw $res;
2412
2413	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2414
2415	die $$res unless "ARRAY" eq ref $res;
2416
2417	return wantarray ? @$res : $res->[-1];
2418	} else {
2419	eval {
2420	local $SIG{__DIE__};
2421	local $SIG{__WARN__};
2422	close $fh1;
2423
2424	my @res = eval { $cb->(@args) };
2425	syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2426	};
2427
2428	_exit 0;
2429	}
2430	}
2431
2432
2433
2434	#############################################################################
2435	# the server's init and main functions	2527	# the server's init and main functions
2436		2528
2437	sub load_facedata($) {	2529	sub load_facedata($) {
2438	my ($path) = @_;	2530	my ($path) = @_;
2439		2531
…		…
2484	}	2576	}
2485		2577
2486	1	2578	1
2487	}	2579	}
2488		2580
		2581	sub reload_regions {
		2582	load_resource_file "$MAPDIR/regions"
		2583	or die "unable to load regions file\n";
		2584	}
		2585
2489	sub reload_facedata {	2586	sub reload_facedata {
2490	load_facedata sprintf "%s/facedata", cf::datadir	2587	load_facedata "$DATADIR/facedata"
2491	or die "unable to load facedata\n";	2588	or die "unable to load facedata\n";
2492	}	2589	}
2493		2590
2494	sub reload_regions {
2495	load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir
2496	or die "unable to load regions file\n";
2497	}
2498
2499	sub reload_archetypes {	2591	sub reload_archetypes {
2500	load_resource_file sprintf "%s/archetypes", cf::datadir	2592	load_resource_file "$DATADIR/archetypes"
2501	or die "unable to load archetypes\n";	2593	or die "unable to load archetypes\n";
2502	}	2594	}
2503		2595
2504	sub reload_treasures {	2596	sub reload_treasures {
2505	load_resource_file sprintf "%s/treasures", cf::datadir	2597	load_resource_file "$DATADIR/treasures"
2506	or die "unable to load treasurelists\n";	2598	or die "unable to load treasurelists\n";
2507	}	2599	}
2508		2600
2509	sub reload_resources {	2601	sub reload_resources {
2510	warn "reloading resource files...\n";	2602	warn "reloading resource files...\n";
2511		2603
2512	reload_regions;	2604	reload_regions;
2513	reload_facedata;	2605	reload_facedata;
		2606	#reload_archetypes;#d#
2514	reload_archetypes;	2607	reload_archetypes;
2515	reload_treasures;	2608	reload_treasures;
2516		2609
2517	warn "finished reloading resource files\n";	2610	warn "finished reloading resource files\n";
2518	}	2611	}
…		…
2520	sub init {	2613	sub init {
2521	reload_resources;	2614	reload_resources;
2522	}	2615	}
2523		2616
2524	sub cfg_load {	2617	sub cfg_load {
2525	open my $fh, "<:utf8", cf::confdir . "/config"	2618	open my $fh, "<:utf8", "$CONFDIR/config"
2526	or return;	2619	or return;
2527		2620
2528	local $/;	2621	local $/;
2529	*CFG = YAML::Syck::Load <$fh>;	2622	*CFG = YAML::Syck::Load <$fh>;
2530		2623
…		…
2575	},	2668	},
2576	);	2669	);
2577	}	2670	}
2578	}	2671	}
2579		2672
		2673	sub write_runtime {
		2674	my $runtime = "$LOCALDIR/runtime";
		2675
		2676	# first touch the runtime file to show we are still running:
		2677	# the fsync below can take a very very long time.
		2678
		2679	IO::AIO::aio_utime $runtime, undef, undef;
		2680
		2681	my $guard = cf::lock_acquire "write_runtime";
		2682
		2683	my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
		2684	or return;
		2685
		2686	my $value = $cf::RUNTIME + 90 + 10;
		2687	# 10 is the runtime save interval, for a monotonic clock
		2688	# 60 allows for the watchdog to kill the server.
		2689
		2690	(aio_write $fh, 0, (length $value), $value, 0) <= 0
		2691	and return;
		2692
		2693	# always fsync - this file is important
		2694	aio_fsync $fh
		2695	and return;
		2696
		2697	# touch it again to show we are up-to-date
		2698	aio_utime $fh, undef, undef;
		2699
		2700	close $fh
		2701	or return;
		2702
		2703	aio_rename "$runtime~", $runtime
		2704	and return;
		2705
		2706	warn "runtime file written.\n";
		2707
		2708	1
		2709	}
		2710
2580	sub emergency_save() {	2711	sub emergency_save() {
2581	my $freeze_guard = cf::freeze_mainloop;	2712	my $freeze_guard = cf::freeze_mainloop;
2582		2713
2583	warn "enter emergency perl save\n";	2714	warn "enter emergency perl save\n";
2584		2715
…		…
2700	Symbol::delete_package "safe::$_"	2831	Symbol::delete_package "safe::$_"
2701	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	2832	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2702		2833
2703	warn "unloading cf.pm \"a bit\"";	2834	warn "unloading cf.pm \"a bit\"";
2704	delete $INC{"cf.pm"};	2835	delete $INC{"cf.pm"};
		2836	delete $INC{"cf/pod.pm"};
2705		2837
2706	# don't, removes xs symbols, too,	2838	# don't, removes xs symbols, too,
2707	# and global variables created in xs	2839	# and global variables created in xs
2708	#Symbol::delete_package __PACKAGE__;	2840	#Symbol::delete_package __PACKAGE__;
2709		2841
…		…
2787	my $signal = new Coro::Signal;	2919	my $signal = new Coro::Signal;
2788	push @WAIT_FOR_TICK_BEGIN, $signal;	2920	push @WAIT_FOR_TICK_BEGIN, $signal;
2789	$signal->wait;	2921	$signal->wait;
2790	}	2922	}
2791		2923
		2924	my $min = 1e6;#d#
		2925	my $avg = 10;
2792	$TICK_WATCHER = Event->timer (	2926	$TICK_WATCHER = Event->timer (
2793	reentrant => 0,	2927	reentrant => 0,
2794	parked => 1,	2928	parked => 1,
2795	prio => 0,	2929	prio => 0,
2796	at => $NEXT_TICK || $TICK,	2930	at => $NEXT_TICK || $TICK,
…		…
2800	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"	2934	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2801	unless ++$bug_warning > 10;	2935	unless ++$bug_warning > 10;
2802	return;	2936	return;
2803	}	2937	}
2804		2938
2805	$NOW = Event::time;	2939	$NOW = $tick_start = Event::time;
2806		2940
2807	cf::server_tick; # one server iteration	2941	cf::server_tick; # one server iteration
		2942
		2943	0 && sync_job {#d#
		2944	for(1..10) {
		2945	my $t = Event::time;
		2946	my $map = my $map = new_from_path cf::map "/tmp/x.map"
		2947	or die;
		2948
		2949	$map->width (50);
		2950	$map->height (50);
		2951	$map->alloc;
		2952	$map->_load_objects ("/tmp/x.map", 1);
		2953	my $t = Event::time - $t;
		2954
		2955	#next unless $t < 0.0013;#d#
		2956	if ($t < $min) {
		2957	$min = $t;
		2958	}
		2959	$avg = $avg * 0.99 + $t * 0.01;
		2960	}
		2961	warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
		2962	exit 0;
		2963	# 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
		2964	};
2808		2965
2809	$RUNTIME += $TICK;	2966	$RUNTIME += $TICK;
2810	$NEXT_TICK += $TICK;	2967	$NEXT_TICK += $TICK;
2811		2968
2812	if ($NOW >= $NEXT_RUNTIME_WRITE) {	2969	if ($NOW >= $NEXT_RUNTIME_WRITE) {
…		…
2818	}	2975	}
2819		2976
2820	# my $AFTER = Event::time;	2977	# my $AFTER = Event::time;
2821	# warn $AFTER - $NOW;#d#	2978	# warn $AFTER - $NOW;#d#
2822		2979
		2980	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
		2981	$sig->send;
		2982	}
		2983	while (my $sig = shift @WAIT_FOR_TICK) {
		2984	$sig->send;
		2985	}
		2986
		2987	$NOW = Event::time;
		2988
2823	# if we are delayed by four ticks or more, skip them all	2989	# if we are delayed by four ticks or more, skip them all
2824	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;	2990	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2825		2991
2826	$TICK_WATCHER->at ($NEXT_TICK);	2992	$TICK_WATCHER->at ($NEXT_TICK);
2827	$TICK_WATCHER->start;	2993	$TICK_WATCHER->start;
2828		2994
2829	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	2995	$LOAD = ($NOW - $tick_start) / $TICK;
2830	$sig->send;	2996	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2831	}
2832	while (my $sig = shift @WAIT_FOR_TICK) {
2833	$sig->send;
2834	}
2835		2997
2836	_post_tick;	2998	_post_tick;
		2999
		3000
2837	},	3001	},
2838	);	3002	);
2839		3003
2840	{	3004	{
2841	BDB::max_poll_time $TICK * 0.1;	3005	BDB::max_poll_time $TICK * 0.1;
…		…
2869		3033
2870	cf::sync_job {	3034	cf::sync_job {
2871	eval {	3035	eval {
2872	BDB::db_env_open	3036	BDB::db_env_open
2873	$DB_ENV,	3037	$DB_ENV,
2874	$BDB_ENV_DIR,	3038	$BDBDIR,
2875	BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN	3039	BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2876	| BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,	3040	| BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2877	0666;	3041	0666;
2878		3042
2879	cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!;	3043	cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2880		3044
2881	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);	3045	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2882	$DB_ENV->set_lk_detect;	3046	$DB_ENV->set_lk_detect;
2883	};	3047	};
2884		3048
…		…
2900	prio => 6,	3064	prio => 6,
2901	cb => \&IO::AIO::poll_cb,	3065	cb => \&IO::AIO::poll_cb,
2902	);	3066	);
2903	}	3067	}
2904		3068
		3069	my $_log_backtrace;
		3070
		3071	sub _log_backtrace {
		3072	my ($msg, @addr) = @_;
		3073
		3074	$msg =~ s/\n//;
		3075
		3076	# limit the # of concurrent backtraces
		3077	if ($_log_backtrace < 2) {
		3078	++$_log_backtrace;
		3079	async {
		3080	my @bt = fork_call {
		3081	@addr = map { sprintf "%x", $_ } @addr;
		3082	my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
		3083	open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
		3084	or die "addr2line: $!";
		3085
		3086	my @funcs;
		3087	my @res = <$fh>;
		3088	chomp for @res;
		3089	while (@res) {
		3090	my ($func, $line) = splice @res, 0, 2, ();
		3091	push @funcs, "[$func] $line";
		3092	}
		3093
		3094	@funcs
		3095	};
		3096
		3097	LOG llevInfo, "[ABT] $msg\n";
		3098	LOG llevInfo, "[ABT] $_\n" for @bt;
		3099	--$_log_backtrace;
		3100	};
		3101	} else {
		3102	LOG llevInfo, "[ABT] $msg\n";
		3103	LOG llevInfo, "[ABT] [suppressed]\n";
		3104	}
		3105	}
		3106
2905	# load additional modules	3107	# load additional modules
2906	use cf::pod;	3108	use cf::pod;
2907		3109
2908	END { cf::emergency_save }	3110	END { cf::emergency_save }
2909		3111

Diff Legend

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