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.238 by root, Sat Apr 14 07:23:00 2007 UTC vs.
Revision 1.286 by root, Sun Jun 24 04:27:20 2007 UTC

…		…
3	use utf8;	3	use utf8;
4	use strict;	4	use strict;
5		5
6	use Symbol;	6	use Symbol;
7	use List::Util;	7	use List::Util;
		8	use Socket;
8	use Storable;	9	use Storable;
9	use Event;	10	use Event;
10	use Opcode;	11	use Opcode;
11	use Safe;	12	use Safe;
12	use Safe::Hole;	13	use Safe::Hole;
13		14
14	use Coro 3.52 ();	15	use Coro 3.61 ();
15	use Coro::State;	16	use Coro::State;
		17	use Coro::Handle;
16	use Coro::Event;	18	use Coro::Event;
17	use Coro::Timer;	19	use Coro::Timer;
18	use Coro::Signal;	20	use Coro::Signal;
19	use Coro::Semaphore;	21	use Coro::Semaphore;
20	use Coro::AIO;	22	use Coro::AIO;
…		…
52	our %EXT_CORO = (); # coroutines bound to extensions	54	our %EXT_CORO = (); # coroutines bound to extensions
53	our %EXT_MAP = (); # pluggable maps	55	our %EXT_MAP = (); # pluggable maps
54		56
55	our $RELOAD; # number of reloads so far	57	our $RELOAD; # number of reloads so far
56	our @EVENT;	58	our @EVENT;
57	our $LIBDIR = datadir . "/ext";
58		59
59	our $TICK = MAX_TIME * 1e-6;	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";
		71
		72	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
60	our $TICK_WATCHER;	73	our $TICK_WATCHER;
61	our $AIO_POLL_WATCHER;	74	our $AIO_POLL_WATCHER;
62	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	75	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
63	our $NEXT_TICK;	76	our $NEXT_TICK;
64	our $NOW;	77	our $NOW;
…		…
73	our $RUNTIME;	86	our $RUNTIME;
74		87
75	our %PLAYER; # all users	88	our %PLAYER; # all users
76	our %MAP; # all maps	89	our %MAP; # all maps
77	our $LINK_MAP; # the special {link} map, which is always available	90	our $LINK_MAP; # the special {link} map, which is always available
78	our $RANDOM_MAPS = cf::localdir . "/random";
79	our $BDB_ENV_DIR = cf::localdir . "/db";
80
81	our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
82	our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
83		91
84	# 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 ∕
85	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons	93	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
86		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
87	binmode STDOUT;	99	binmode STDOUT;
88	binmode STDERR;	100	binmode STDERR;
89		101
90	# read virtual server time, if available	102	# read virtual server time, if available
91	unless ($RUNTIME || !-e cf::localdir . "/runtime") {	103	unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
92	open my $fh, "<", cf::localdir . "/runtime"	104	open my $fh, "<", "$LOCALDIR/runtime"
93	or die "unable to read runtime file: $!";	105	or die "unable to read runtime file: $!";
94	$RUNTIME = <$fh> + 0.;	106	$RUNTIME = <$fh> + 0.;
95	}	107	}
96		108
97	mkdir cf::localdir;	109	mkdir $_
98	mkdir cf::localdir . "/" . cf::playerdir;	110	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
99	mkdir cf::localdir . "/" . cf::tmpdir;
100	mkdir cf::localdir . "/" . cf::uniquedir;
101	mkdir $RANDOM_MAPS;
102	mkdir $BDB_ENV_DIR;
103		111
104	our $EMERGENCY_POSITION;	112	our $EMERGENCY_POSITION;
105		113
106	sub cf::map::normalise;	114	sub cf::map::normalise;
107		115
…		…
118	=item $cf::RUNTIME	126	=item $cf::RUNTIME
119		127
120	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
121	every server tick.	129	every server tick.
122		130
123	=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
124		134
125	The perl library directory, where extensions and cf-specific modules can	135	Various directories - "/etc", read-only install directory, perl-library
126	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.
127		139
128	=item $cf::NOW	140	=item $cf::NOW
129		141
130	The time of the last (current) server tick.	142	The time of the last (current) server tick.
131		143
132	=item $cf::TICK	144	=item $cf::TICK
133		145
134	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.
135		157
136	=item %cf::CFG	158	=item %cf::CFG
137		159
138	Configuration for the server, loaded from C</etc/crossfire/config>, or	160	Configuration for the server, loaded from C</etc/crossfire/config>, or
139	from wherever your confdir points to.	161	from wherever your confdir points to.
140		162
141	=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE	163	=item cf::wait_for_tick, cf::wait_for_tick_begin
142		164
143	These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)	165	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
144	or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick	166	returns directly I<after> the tick processing (and consequently, can only wake one process
145	processing has been done. Call C<< ->wait >> on them to maximise the	167	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
146	window of cpu time available, or simply to synchronise to the server tick.
147		168
148	=back	169	=back
149		170
150	=cut	171	=cut
151		172
152	BEGIN {	173	BEGIN {
153	*CORE::GLOBAL::warn = sub {	174	*CORE::GLOBAL::warn = sub {
154	my $msg = join "", @_;	175	my $msg = join "", @_;
155	utf8::encode $msg;
156		176
157	$msg .= "\n"	177	$msg .= "\n"
158	unless $msg =~ /\n$/;	178	unless $msg =~ /\n$/;
159		179
		180	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
		181
		182	utf8::encode $msg;
160	LOG llevError, $msg;	183	LOG llevError, $msg;
161	};	184	};
162	}	185	}
163		186
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) {
…		…
1133	}	1347	}
1134		1348
1135	\@paths	1349	\@paths
1136	}	1350	}
1137		1351
		1352	=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
		1353
		1354	Expand crossfire pod fragments into protocol xml.
		1355
		1356	=cut
		1357
		1358	sub expand_cfpod {
		1359	((my $self), (local $_)) = @_;
		1360
		1361	# escape & and <
		1362	s/&/&amp;/g;
		1363	s/(?<![BIUGH])</&lt;/g;
		1364
		1365	# this is buggy, it needs to properly take care of nested <'s
		1366
		1367	1 while
		1368	# replace B<>, I<>, U<> etc.
		1369	s/B<([^\>]*)>/<b>$1<\/b>/
		1370	|| s/I<([^\>]*)>/<i>$1<\/i>/
		1371	|| s/U<([^\>]*)>/<u>$1<\/u>/
		1372	# replace G<male|female> tags
		1373	|| s{G<([^>|]*)\|([^>]*)>}{
		1374	$self->gender ? $2 : $1
		1375	}ge
		1376	# replace H<hint text>
		1377	|| s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g;
		1378
		1379	# create single paragraphs (very hackish)
		1380	s/(?<=\S)\n(?=\w)/ /g;
		1381
		1382	$_
		1383	}
		1384
1138	=item $player->ext_reply ($msgid, %msg)	1385	=item $player->ext_reply ($msgid, %msg)
1139		1386
1140	Sends an ext reply to the player.	1387	Sends an ext reply to the player.
1141		1388
1142	=cut	1389	=cut
…		…
1169		1416
1170	package cf::region;	1417	package cf::region;
1171		1418
1172	=item cf::region::find_by_path $path	1419	=item cf::region::find_by_path $path
1173		1420
1174	Tries to decuce the probable region for a map knowing only its path.	1421	Tries to decuce the likely region for a map knowing only its path.
1175		1422
1176	=cut	1423	=cut
1177		1424
1178	sub find_by_path($) {	1425	sub find_by_path($) {
1179	my ($path) = @_;	1426	my ($path) = @_;
…		…
1253	my ($self, $merge) = @_;	1500	my ($self, $merge) = @_;
1254		1501
1255	# we have to keep some variables in memory intact	1502	# we have to keep some variables in memory intact
1256	local $self->{path};	1503	local $self->{path};
1257	local $self->{load_path};	1504	local $self->{load_path};
1258	local $self->{deny_save};
1259	local $self->{deny_reset};
1260		1505
1261	$self->SUPER::thawer_merge ($merge);	1506	$self->SUPER::thawer_merge ($merge);
1262	}	1507	}
1263		1508
1264	sub normalise {	1509	sub normalise {
…		…
1336		1581
1337	# the original (read-only) location	1582	# the original (read-only) location
1338	sub load_path {	1583	sub load_path {
1339	my ($self) = @_;	1584	my ($self) = @_;
1340		1585
1341	sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path}	1586	"$MAPDIR/$self->{path}.map"
1342	}	1587	}
1343		1588
1344	# the temporary/swap location	1589	# the temporary/swap location
1345	sub save_path {	1590	sub save_path {
1346	my ($self) = @_;	1591	my ($self) = @_;
1347		1592
1348	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;	1593	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1349	sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path	1594	"$TMPDIR/$path.map"
1350	}	1595	}
1351		1596
1352	# the unique path, undef == no special unique path	1597	# the unique path, undef == no special unique path
1353	sub uniq_path {	1598	sub uniq_path {
1354	my ($self) = @_;	1599	my ($self) = @_;
1355		1600
1356	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;	1601	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1357	sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path	1602	"$UNIQUEDIR/$path"
1358	}	1603	}
1359		1604
1360	# and all this just because we cannot iterate over	1605	# and all this just because we cannot iterate over
1361	# all maps in C++...	1606	# all maps in C++...
1362	sub change_all_map_light {	1607	sub change_all_map_light {
1363	my ($change) = @_;	1608	my ($change) = @_;
1364		1609
1365	$_->change_map_light ($change)	1610	$_->change_map_light ($change)
1366	for grep $_->outdoor, values %cf::MAP;	1611	for grep $_->outdoor, values %cf::MAP;
		1612	}
		1613
		1614	sub decay_objects {
		1615	my ($self) = @_;
		1616
		1617	return if $self->{deny_reset};
		1618
		1619	$self->do_decay_objects;
1367	}	1620	}
1368		1621
1369	sub unlink_save {	1622	sub unlink_save {
1370	my ($self) = @_;	1623	my ($self) = @_;
1371		1624
…		…
1429	$self->load_header_orig	1682	$self->load_header_orig
1430	or return;	1683	or return;
1431	$self->prepare_orig;	1684	$self->prepare_orig;
1432	}	1685	}
1433		1686
		1687	$self->{deny_reset} = 1
		1688	if $self->no_reset;
		1689
1434	$self->default_region (cf::region::find_by_path $self->{path})	1690	$self->default_region (cf::region::find_by_path $self->{path})
1435	unless $self->default_region;	1691	unless $self->default_region;
1436		1692
1437	1	1693	1
1438	}	1694	}
…		…
1453	$map->{last_save} = $cf::RUNTIME;	1709	$map->{last_save} = $cf::RUNTIME;
1454		1710
1455	$map->load_header	1711	$map->load_header
1456	or return;	1712	or return;
1457		1713
1458	if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?)	1714	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1459	# doing this can freeze the server in a sync job, obviously	1715	# doing this can freeze the server in a sync job, obviously
1460	#$cf::WAIT_FOR_TICK->wait;	1716	#$cf::WAIT_FOR_TICK->wait;
1461	$map->reset;	1717	$map->reset;
1462	undef $guard;	1718	undef $guard;
1463	return find $path;	1719	return find $path;
…		…
1474	my ($self) = @_;	1730	my ($self) = @_;
1475		1731
1476	local $self->{deny_reset} = 1; # loading can take a long time	1732	local $self->{deny_reset} = 1; # loading can take a long time
1477		1733
1478	my $path = $self->{path};	1734	my $path = $self->{path};
		1735
		1736	{
1479	my $guard = cf::lock_acquire "map_load:$path";	1737	my $guard = cf::lock_acquire "map_load:$path";
1480		1738
1481	return if $self->in_memory != cf::MAP_SWAPPED;	1739	return if $self->in_memory != cf::MAP_SWAPPED;
1482		1740
1483	$self->in_memory (cf::MAP_LOADING);	1741	$self->in_memory (cf::MAP_LOADING);
1484		1742
1485	$self->alloc;	1743	$self->alloc;
1486		1744
1487	$self->pre_load;	1745	$self->pre_load;
1488
1489	$self->_load_objects ($self->{load_path}, 1)
1490	or return;
1491
1492	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1493	if delete $self->{load_original};
1494
1495	if (my $uniq = $self->uniq_path) {
1496	utf8::encode $uniq;
1497	if (aio_open $uniq, O_RDONLY, 0) {
1498	$self->clear_unique_items;
1499	$self->_load_objects ($uniq, 0);
1500	}
1501	}
1502
1503	Coro::cede;
1504
1505	# now do the right thing for maps
1506	$self->link_multipart_objects;
1507
1508	unless ($self->{deny_activate}) {
1509	$self->decay_objects;
1510	$self->fix_auto_apply;
1511	$self->update_buttons;
1512	Coro::cede;	1746	Coro::cede;
1513	$self->set_darkness_map;	1747
		1748	$self->_load_objects ($self->{load_path}, 1)
		1749	or return;
		1750
		1751	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
		1752	if delete $self->{load_original};
		1753
		1754	if (my $uniq = $self->uniq_path) {
		1755	utf8::encode $uniq;
		1756	if (aio_open $uniq, O_RDONLY, 0) {
		1757	$self->clear_unique_items;
		1758	$self->_load_objects ($uniq, 0);
		1759	}
		1760	}
		1761
		1762	Coro::cede;
		1763	# now do the right thing for maps
		1764	$self->link_multipart_objects;
1514	$self->difficulty ($self->estimate_difficulty)	1765	$self->difficulty ($self->estimate_difficulty)
1515	unless $self->difficulty;	1766	unless $self->difficulty;
1516	Coro::cede;	1767	Coro::cede;
		1768
		1769	unless ($self->{deny_activate}) {
		1770	$self->decay_objects;
		1771	$self->fix_auto_apply;
		1772	$self->update_buttons;
		1773	Coro::cede;
		1774	$self->set_darkness_map;
		1775	Coro::cede;
1517	$self->activate;	1776	$self->activate;
		1777	}
		1778
		1779	$self->in_memory (cf::MAP_IN_MEMORY);
1518	}	1780	}
1519		1781
1520	$self->post_load;	1782	$self->post_load;
1521
1522	$self->in_memory (cf::MAP_IN_MEMORY);
1523	}	1783	}
1524		1784
1525	sub customise_for {	1785	sub customise_for {
1526	my ($self, $ob) = @_;	1786	my ($self, $ob) = @_;
1527		1787
1528	return find "~" . $ob->name . "/" . $self->{path}	1788	return find "~" . $ob->name . "/" . $self->{path}
1529	if $self->per_player;	1789	if $self->per_player;
		1790
		1791	# return find "?party/" . $ob->name . "/" . $self->{path}
		1792	# if $self->per_party;
1530		1793
1531	$self	1794	$self
1532	}	1795	}
1533		1796
1534	# find and load all maps in the 3x3 area around a map	1797	# find and load all maps in the 3x3 area around a map
…		…
1645		1908
1646	sub reset_at {	1909	sub reset_at {
1647	my ($self) = @_;	1910	my ($self) = @_;
1648		1911
1649	# TODO: safety, remove and allow resettable per-player maps	1912	# TODO: safety, remove and allow resettable per-player maps
1650	return 1e99 if $self->isa ("ext::map_per_player");#d#
1651	return 1e99 if $self->{deny_reset};	1913	return 1e99 if $self->{deny_reset};
1652		1914
1653	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;	1915	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1654	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;	1916	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1655		1917
…		…
1666	my ($self) = @_;	1928	my ($self) = @_;
1667		1929
1668	my $lock = cf::lock_acquire "map_data:$self->{path}";	1930	my $lock = cf::lock_acquire "map_data:$self->{path}";
1669		1931
1670	return if $self->players;	1932	return if $self->players;
1671	return if $self->isa ("ext::map_per_player");#d#
1672		1933
1673	warn "resetting map ", $self->path;#d#	1934	warn "resetting map ", $self->path;
1674		1935
1675	$self->in_memory (cf::MAP_SWAPPED);	1936	$self->in_memory (cf::MAP_SWAPPED);
1676		1937
1677	# need to save uniques path	1938	# need to save uniques path
1678	unless ($self->{deny_save}) {	1939	unless ($self->{deny_save}) {
…		…
1710	$cf::MAP{$self->path} = $self;	1971	$cf::MAP{$self->path} = $self;
1711		1972
1712	$self->reset; # polite request, might not happen	1973	$self->reset; # polite request, might not happen
1713	}	1974	}
1714		1975
		1976	=item $maps = cf::map::tmp_maps
		1977
		1978	Returns an arrayref with all map paths of currently instantiated and saved
		1979	maps. May block.
		1980
		1981	=cut
		1982
		1983	sub tmp_maps() {
		1984	[
		1985	map {
		1986	utf8::decode $_;
		1987	/\.map$/
		1988	? normalise $_
		1989	: ()
		1990	} @{ aio_readdir $TMPDIR or [] }
		1991	]
		1992	}
		1993
		1994	=item $maps = cf::map::random_maps
		1995
		1996	Returns an arrayref with all map paths of currently instantiated and saved
		1997	random maps. May block.
		1998
		1999	=cut
		2000
		2001	sub random_maps() {
		2002	[
		2003	map {
		2004	utf8::decode $_;
		2005	/\.map$/
		2006	? normalise "?random/$_"
		2007	: ()
		2008	} @{ aio_readdir $RANDOMDIR or [] }
		2009	]
		2010	}
		2011
1715	=item cf::map::unique_maps	2012	=item cf::map::unique_maps
1716		2013
1717	Returns an arrayref of paths of all shared maps that have	2014	Returns an arrayref of paths of all shared maps that have
1718	instantiated unique items. May block.	2015	instantiated unique items. May block.
1719		2016
1720	=cut	2017	=cut
1721		2018
1722	sub unique_maps() {	2019	sub unique_maps() {
1723	my $files = aio_readdir cf::localdir . "/" . cf::uniquedir	2020	[
1724	or return;	2021	map {
1725
1726	my @paths;
1727
1728	for (@$files) {
1729	utf8::decode $_;	2022	utf8::decode $_;
1730	next if /\.pst$/;	2023	/\.map$/
1731	next unless /^$PATH_SEP/o;	2024	? normalise $_
1732		2025	: ()
1733	push @paths, cf::map::normalise $_;	2026	} @{ aio_readdir $UNIQUEDIR or [] }
1734	}	2027	]
1735
1736	\@paths
1737	}	2028	}
1738		2029
1739	package cf;	2030	package cf;
1740		2031
1741	=back	2032	=back
…		…
1787		2078
1788	$flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;	2079	$flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1789		2080
1790	if ($self->{record_replies}) {	2081	if ($self->{record_replies}) {
1791	push @{ $self->{record_replies} }, [$npc, $msg, $flags];	2082	push @{ $self->{record_replies} }, [$npc, $msg, $flags];
		2083
1792	} else {	2084	} else {
		2085	my $pl = $self->contr;
		2086
		2087	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
		2088	my $diag = $pl->{npc_dialog};
		2089	$diag->{pl}->ext_reply (
		2090	$diag->{id},
		2091	msgtype => "reply",
		2092	msg => $diag->{pl}->expand_cfpod ($msg),
		2093	add_topics => []
		2094	);
		2095
		2096	} else {
1793	$msg = $npc->name . " says: $msg" if $npc;	2097	$msg = $npc->name . " says: $msg" if $npc;
1794	$self->message ($msg, $flags);	2098	$self->message ($msg, $flags);
		2099	}
1795	}	2100	}
1796	}	2101	}
1797		2102
1798	=item $player_object->may ("access")	2103	=item $player_object->may ("access")
1799		2104
…		…
1847	$self->deactivate_recursive;	2152	$self->deactivate_recursive;
1848		2153
1849	return if UNIVERSAL::isa $self->map, "ext::map_link";	2154	return if UNIVERSAL::isa $self->map, "ext::map_link";
1850		2155
1851	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]	2156	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1852	if $self->map;	2157	if $self->map && $self->map->{path} ne "{link}";
1853		2158
1854	$self->enter_map ($LINK_MAP || link_map, 10, 10);	2159	$self->enter_map ($LINK_MAP || link_map, 10, 10);
1855	}	2160	}
1856		2161
1857	sub cf::object::player::leave_link {	2162	sub cf::object::player::leave_link {
1858	my ($self, $map, $x, $y) = @_;	2163	my ($self, $map, $x, $y) = @_;
		2164
		2165	return unless $self->contr->active;
1859		2166
1860	my $link_pos = delete $self->{_link_pos};	2167	my $link_pos = delete $self->{_link_pos};
1861		2168
1862	unless ($map) {	2169	unless ($map) {
1863	# restore original map position	2170	# restore original map position
…		…
1886		2193
1887	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2194	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1888	$self->enter_map ($map, $x, $y);	2195	$self->enter_map ($map, $x, $y);
1889	}	2196	}
1890		2197
1891	cf::player->attach (
1892	on_logout => sub {
1893	my ($pl) = @_;
1894
1895	# abort map switching before logout
1896	if ($pl->ob->{_link_pos}) {
1897	cf::sync_job {
1898	$pl->ob->leave_link
1899	};
1900	}
1901	},
1902	on_login => sub {
1903	my ($pl) = @_;
1904
1905	# try to abort aborted map switching on player login :)
1906	# should happen only on crashes
1907	if ($pl->ob->{_link_pos}) {
1908	$pl->ob->enter_link;
1909	(async {
1910	$pl->ob->reply (undef,
1911	"There was an internal problem at your last logout, "
1912	. "the server will try to bring you to your intended destination in a second.",
1913	cf::NDI_RED);
1914	# we need this sleep as the login has a concurrent enter_exit running
1915	# and this sleep increases chances of the player not ending up in scorn
1916	Coro::Timer::sleep 1;
1917	$pl->ob->leave_link;
1918	})->prio (2);
1919	}
1920	},
1921	);
1922
1923	=item $player_object->goto ($path, $x, $y)	2198	=item $player_object->goto ($path, $x, $y[, $check->($map)])
1924		2199
		2200	Moves the player to the given map-path and coordinates by first freezing
		2201	her, loading and preparing them map, calling the provided $check callback
		2202	that has to return the map if sucecssful, and then unfreezes the player on
		2203	the new (success) or old (failed) map position.
		2204
1925	=cut	2205	=cut
		2206
		2207	our $GOTOGEN;
1926		2208
1927	sub cf::object::player::goto {	2209	sub cf::object::player::goto {
1928	my ($self, $path, $x, $y) = @_;	2210	my ($self, $path, $x, $y, $check) = @_;
		2211
		2212	# do generation counting so two concurrent goto's will be executed in-order
		2213	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1929		2214
1930	$self->enter_link;	2215	$self->enter_link;
1931		2216
1932	(async {	2217	(async {
1933	my $map = eval {	2218	my $map = eval {
1934	my $map = cf::map::find $path;	2219	my $map = cf::map::find $path;
		2220
		2221	if ($map) {
1935	$map = $map->customise_for ($self) if $map;	2222	$map = $map->customise_for ($self);
		2223	$map = $check->($map) if $check && $map;
		2224	} else {
		2225	$self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
		2226	}
		2227
1936	$map	2228	$map
		2229	};
		2230
		2231	if ($@) {
		2232	$self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
		2233	LOG llevError | logBacktrace, Carp::longmess $@;
1937	} or	2234	}
1938	$self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1939		2235
		2236	if ($gen == $self->{_goto_generation}) {
		2237	delete $self->{_goto_generation};
1940	$self->leave_link ($map, $x, $y);	2238	$self->leave_link ($map, $x, $y);
		2239	}
1941	})->prio (1);	2240	})->prio (1);
1942	}	2241	}
1943		2242
1944	=item $player_object->enter_exit ($exit_object)	2243	=item $player_object->enter_exit ($exit_object)
1945		2244
…		…
1984		2283
1985	$rmp->{random_seed} ||= $exit->random_seed;	2284	$rmp->{random_seed} ||= $exit->random_seed;
1986		2285
1987	my $data = cf::to_json $rmp;	2286	my $data = cf::to_json $rmp;
1988	my $md5 = Digest::MD5::md5_hex $data;	2287	my $md5 = Digest::MD5::md5_hex $data;
1989	my $meta = "$cf::RANDOM_MAPS/$md5.meta";	2288	my $meta = "$RANDOMDIR/$md5.meta";
1990		2289
1991	if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {	2290	if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1992	aio_write $fh, 0, (length $data), $data, 0;	2291	aio_write $fh, 0, (length $data), $data, 0;
1993	undef $fh;	2292	undef $fh;
1994	aio_rename "$meta~", $meta;	2293	aio_rename "$meta~", $meta;
…		…
2048	sub cf::client::send_drawinfo {	2347	sub cf::client::send_drawinfo {
2049	my ($self, $text, $flags) = @_;	2348	my ($self, $text, $flags) = @_;
2050		2349
2051	utf8::encode $text;	2350	utf8::encode $text;
2052	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);	2351	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
		2352	}
		2353
		2354	=item $client->send_msg ($color, $type, $msg, [extra...])
		2355
		2356	Send a drawinfo or msg packet to the client, formatting the msg for the
		2357	client if neccessary. C<$type> should be a string identifying the type of
		2358	the message, with C<log> being the default. If C<$color> is negative, suppress
		2359	the message unless the client supports the msg packet.
		2360
		2361	=cut
		2362
		2363	sub cf::client::send_msg {
		2364	my ($self, $color, $type, $msg, @extra) = @_;
		2365
		2366	$msg = $self->pl->expand_cfpod ($msg);
		2367
		2368	if ($self->can_msg) {
		2369	$self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]);
		2370	} else {
		2371	# replace some tags by gcfclient-compatible ones
		2372	for ($msg) {
		2373	1 while
		2374	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2375	|| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2376	|| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2377	|| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2378	|| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2379	}
		2380
		2381	if ($color >= 0) {
		2382	if (0 && $msg =~ /\[/) {
		2383	$self->send_packet ("drawextinfo $color 4 0 $msg")
		2384	} else {
		2385	$msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
		2386	$self->send_packet ("drawinfo $color $msg")
		2387	}
		2388	}
		2389	}
2053	}	2390	}
2054		2391
2055	=item $client->ext_event ($type, %msg)	2392	=item $client->ext_event ($type, %msg)
2056		2393
2057	Sends an exti event to the client.	2394	Sends an exti event to the client.
…		…
2259	=back	2596	=back
2260		2597
2261	=cut	2598	=cut
2262		2599
2263	#############################################################################	2600	#############################################################################
2264
2265	=head2 EXTENSION DATABASE SUPPORT
2266
2267	Crossfire maintains a very simple database for extension use. It can
2268	currently store anything that can be serialised using Storable, which
2269	excludes objects.
2270
2271	The parameter C<$family> should best start with the name of the extension
2272	using it, it should be unique.
2273
2274	=over 4
2275
2276	=item $value = cf::db_get $family => $key
2277
2278	Returns a single value from the database.
2279
2280	=item cf::db_put $family => $key => $value
2281
2282	Stores the given C<$value> in the family.
2283
2284	=cut
2285
2286	our $DB;
2287
2288	sub db_init {
2289	unless ($DB) {
2290	$DB = BDB::db_create $DB_ENV;
2291
2292	cf::sync_job {
2293	eval {
2294	$DB->set_flags (BDB::CHKSUM);
2295
2296	BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2297	BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2298	cf::cleanup "db_open(db): $!" if $!;
2299	};
2300	cf::cleanup "db_open(db): $@" if $@;
2301	};
2302
2303	my $path = cf::localdir . "/database.pst";
2304	if (stat $path) {
2305	cf::sync_job {
2306	my $pst = Storable::retrieve $path;
2307
2308	cf::db_put (board => data => $pst->{board});
2309	cf::db_put (guildrules => data => $pst->{guildrules});
2310	cf::db_put (rent => balance => $pst->{rent}{balance});
2311	BDB::db_env_txn_checkpoint $DB_ENV;
2312
2313	unlink $path;
2314	};
2315	}
2316	}
2317	}
2318
2319	sub db_get($$) {
2320	my $key = "$_[0]/$_[1]";
2321
2322	cf::sync_job {
2323	BDB::db_get $DB, undef, $key, my $data;
2324
2325	$! ? ()
2326	: Compress::LZF::sthaw $data
2327	}
2328	}
2329
2330	sub db_put($$$) {
2331	BDB::dbreq_pri 4;
2332	BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2333	}
2334
2335	#############################################################################
2336	# the server's init and main functions	2601	# the server's init and main functions
2337		2602
2338	sub load_facedata {	2603	sub load_facedata($) {
2339	my $path = sprintf "%s/facedata", cf::datadir;	2604	my ($path) = @_;
2340		2605
2341	warn "loading facedata from $path\n";	2606	warn "loading facedata from $path\n";
2342		2607
2343	my $facedata;	2608	my $facedata;
2344	0 < aio_load $path, $facedata	2609	0 < aio_load $path, $facedata
…		…
2385	}	2650	}
2386		2651
2387	1	2652	1
2388	}	2653	}
2389		2654
		2655	sub reload_regions {
		2656	load_resource_file "$MAPDIR/regions"
		2657	or die "unable to load regions file\n";
		2658	}
		2659
		2660	sub reload_facedata {
		2661	load_facedata "$DATADIR/facedata"
		2662	or die "unable to load facedata\n";
		2663	}
		2664
		2665	sub reload_archetypes {
		2666	load_resource_file "$DATADIR/archetypes"
		2667	or die "unable to load archetypes\n";
		2668	}
		2669
		2670	sub reload_treasures {
		2671	load_resource_file "$DATADIR/treasures"
		2672	or die "unable to load treasurelists\n";
		2673	}
		2674
2390	sub reload_resources {	2675	sub reload_resources {
2391	load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir	2676	warn "reloading resource files...\n";
2392	or die "unable to load regions file\n";#d#	2677
		2678	reload_regions;
2393	load_facedata	2679	reload_facedata;
2394	or die "unable to load facedata\n";#d#	2680	#reload_archetypes;#d#
		2681	reload_archetypes;
		2682	reload_treasures;
		2683
		2684	warn "finished reloading resource files\n";
2395	}	2685	}
2396		2686
2397	sub init {	2687	sub init {
2398	reload_resources;	2688	reload_resources;
2399	}	2689	}
2400		2690
2401	sub cfg_load {	2691	sub cfg_load {
2402	open my $fh, "<:utf8", cf::confdir . "/config"	2692	open my $fh, "<:utf8", "$CONFDIR/config"
2403	or return;	2693	or return;
2404		2694
2405	local $/;	2695	local $/;
2406	*CFG = YAML::Syck::Load <$fh>;	2696	*CFG = YAML::Syck::Load <$fh>;
2407		2697
…		…
2452	},	2742	},
2453	);	2743	);
2454	}	2744	}
2455	}	2745	}
2456		2746
		2747	sub write_runtime {
		2748	my $runtime = "$LOCALDIR/runtime";
		2749
		2750	# first touch the runtime file to show we are still running:
		2751	# the fsync below can take a very very long time.
		2752
		2753	IO::AIO::aio_utime $runtime, undef, undef;
		2754
		2755	my $guard = cf::lock_acquire "write_runtime";
		2756
		2757	my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
		2758	or return;
		2759
		2760	my $value = $cf::RUNTIME + 90 + 10;
		2761	# 10 is the runtime save interval, for a monotonic clock
		2762	# 60 allows for the watchdog to kill the server.
		2763
		2764	(aio_write $fh, 0, (length $value), $value, 0) <= 0
		2765	and return;
		2766
		2767	# always fsync - this file is important
		2768	aio_fsync $fh
		2769	and return;
		2770
		2771	# touch it again to show we are up-to-date
		2772	aio_utime $fh, undef, undef;
		2773
		2774	close $fh
		2775	or return;
		2776
		2777	aio_rename "$runtime~", $runtime
		2778	and return;
		2779
		2780	warn "runtime file written.\n";
		2781
		2782	1
		2783	}
		2784
2457	sub emergency_save() {	2785	sub emergency_save() {
2458	my $freeze_guard = cf::freeze_mainloop;	2786	my $freeze_guard = cf::freeze_mainloop;
2459		2787
2460	warn "enter emergency perl save\n";	2788	warn "enter emergency perl save\n";
2461		2789
…		…
2492		2820
2493	warn Carp::longmess "post_cleanup backtrace"	2821	warn Carp::longmess "post_cleanup backtrace"
2494	if $make_core;	2822	if $make_core;
2495	}	2823	}
2496		2824
2497	sub reload() {	2825	sub do_reload_perl() {
2498	# can/must only be called in main	2826	# can/must only be called in main
2499	if ($Coro::current != $Coro::main) {	2827	if ($Coro::current != $Coro::main) {
2500	warn "can only reload from main coroutine";	2828	warn "can only reload from main coroutine";
2501	return;	2829	return;
2502	}	2830	}
…		…
2577	Symbol::delete_package "safe::$_"	2905	Symbol::delete_package "safe::$_"
2578	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	2906	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2579		2907
2580	warn "unloading cf.pm \"a bit\"";	2908	warn "unloading cf.pm \"a bit\"";
2581	delete $INC{"cf.pm"};	2909	delete $INC{"cf.pm"};
		2910	delete $INC{"cf/pod.pm"};
2582		2911
2583	# don't, removes xs symbols, too,	2912	# don't, removes xs symbols, too,
2584	# and global variables created in xs	2913	# and global variables created in xs
2585	#Symbol::delete_package __PACKAGE__;	2914	#Symbol::delete_package __PACKAGE__;
2586		2915
…		…
2601	warn "reattaching attachments to maps";	2930	warn "reattaching attachments to maps";
2602	reattach $_ for values %MAP;	2931	reattach $_ for values %MAP;
2603	warn "reattaching attachments to players";	2932	warn "reattaching attachments to players";
2604	reattach $_ for values %PLAYER;	2933	reattach $_ for values %PLAYER;
2605		2934
2606	warn "loading reloadable resources";
2607	reload_resources;
2608
2609	warn "leaving sync_job";	2935	warn "leaving sync_job";
2610		2936
2611	1	2937	1
2612	} or do {	2938	} or do {
2613	warn $@;	2939	warn $@;
…		…
2618	warn "reloaded";	2944	warn "reloaded";
2619	};	2945	};
2620		2946
2621	our $RELOAD_WATCHER; # used only during reload	2947	our $RELOAD_WATCHER; # used only during reload
2622		2948
		2949	sub reload_perl() {
		2950	# doing reload synchronously and two reloads happen back-to-back,
		2951	# coro crashes during coro_state_free->destroy here.
		2952
		2953	$RELOAD_WATCHER ||= Event->timer (
		2954	reentrant => 0,
		2955	after => 0,
		2956	data => WF_AUTOCANCEL,
		2957	cb => sub {
		2958	do_reload_perl;
		2959	undef $RELOAD_WATCHER;
		2960	},
		2961	);
		2962	}
		2963
2623	register_command "reload" => sub {	2964	register_command "reload" => sub {
2624	my ($who, $arg) = @_;	2965	my ($who, $arg) = @_;
2625		2966
2626	if ($who->flag (FLAG_WIZ)) {	2967	if ($who->flag (FLAG_WIZ)) {
2627	$who->message ("reloading server.");	2968	$who->message ("reloading server.");
2628		2969	async { reload_perl };
2629	# doing reload synchronously and two reloads happen back-to-back,
2630	# coro crashes during coro_state_free->destroy here.
2631
2632	$RELOAD_WATCHER ||= Event->timer (
2633	reentrant => 0,
2634	after => 0,
2635	data => WF_AUTOCANCEL,
2636	cb => sub {
2637	reload;
2638	undef $RELOAD_WATCHER;
2639	},
2640	);
2641	}	2970	}
2642	};	2971	};
2643		2972
2644	unshift @INC, $LIBDIR;	2973	unshift @INC, $LIBDIR;
2645		2974
2646	my $bug_warning = 0;	2975	my $bug_warning = 0;
2647		2976
		2977	our @WAIT_FOR_TICK;
		2978	our @WAIT_FOR_TICK_BEGIN;
		2979
		2980	sub wait_for_tick {
		2981	return unless $TICK_WATCHER->is_active;
		2982	return if $Coro::current == $Coro::main;
		2983
		2984	my $signal = new Coro::Signal;
		2985	push @WAIT_FOR_TICK, $signal;
		2986	$signal->wait;
		2987	}
		2988
		2989	sub wait_for_tick_begin {
		2990	return unless $TICK_WATCHER->is_active;
		2991	return if $Coro::current == $Coro::main;
		2992
		2993	my $signal = new Coro::Signal;
		2994	push @WAIT_FOR_TICK_BEGIN, $signal;
		2995	$signal->wait;
		2996	}
		2997
		2998	my $min = 1e6;#d#
		2999	my $avg = 10;
2648	$TICK_WATCHER = Event->timer (	3000	$TICK_WATCHER = Event->timer (
2649	reentrant => 0,	3001	reentrant => 0,
2650	parked => 1,	3002	parked => 1,
2651	prio => 0,	3003	prio => 0,
2652	at => $NEXT_TICK || $TICK,	3004	at => $NEXT_TICK || $TICK,
…		…
2656	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"	3008	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2657	unless ++$bug_warning > 10;	3009	unless ++$bug_warning > 10;
2658	return;	3010	return;
2659	}	3011	}
2660		3012
2661	$NOW = Event::time;	3013	$NOW = $tick_start = Event::time;
2662		3014
2663	cf::server_tick; # one server iteration	3015	cf::server_tick; # one server iteration
		3016
		3017	0 && sync_job {#d#
		3018	for(1..10) {
		3019	my $t = Event::time;
		3020	my $map = my $map = new_from_path cf::map "/tmp/x.map"
		3021	or die;
		3022
		3023	$map->width (50);
		3024	$map->height (50);
		3025	$map->alloc;
		3026	$map->_load_objects ("/tmp/x.map", 1);
		3027	my $t = Event::time - $t;
		3028
		3029	#next unless $t < 0.0013;#d#
		3030	if ($t < $min) {
		3031	$min = $t;
		3032	}
		3033	$avg = $avg * 0.99 + $t * 0.01;
		3034	}
		3035	warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
		3036	exit 0;
		3037	# 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
		3038	};
		3039
2664	$RUNTIME += $TICK;	3040	$RUNTIME += $TICK;
2665	$NEXT_TICK += $TICK;	3041	$NEXT_TICK += $TICK;
2666		3042
2667	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3043	if ($NOW >= $NEXT_RUNTIME_WRITE) {
2668	$NEXT_RUNTIME_WRITE = $NOW + 10;	3044	$NEXT_RUNTIME_WRITE = $NOW + 10;
…		…
2670	write_runtime	3046	write_runtime
2671	or warn "ERROR: unable to write runtime file: $!";	3047	or warn "ERROR: unable to write runtime file: $!";
2672	};	3048	};
2673	}	3049	}
2674		3050
2675	$WAIT_FOR_TICK->broadcast;
2676	$WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2677
2678	# my $AFTER = Event::time;	3051	# my $AFTER = Event::time;
2679	# warn $AFTER - $NOW;#d#	3052	# warn $AFTER - $NOW;#d#
2680		3053
		3054	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
		3055	$sig->send;
		3056	}
		3057	while (my $sig = shift @WAIT_FOR_TICK) {
		3058	$sig->send;
		3059	}
		3060
		3061	$NOW = Event::time;
		3062
2681	# if we are delayed by four ticks or more, skip them all	3063	# if we are delayed by four ticks or more, skip them all
2682	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;	3064	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2683		3065
2684	$TICK_WATCHER->at ($NEXT_TICK);	3066	$TICK_WATCHER->at ($NEXT_TICK);
2685	$TICK_WATCHER->start;	3067	$TICK_WATCHER->start;
		3068
		3069	$LOAD = ($NOW - $tick_start) / $TICK;
		3070	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
		3071
		3072	_post_tick;
		3073
		3074
2686	},	3075	},
2687	);	3076	);
2688		3077
2689	{	3078	{
2690	BDB::max_poll_time $TICK * 0.1;	3079	BDB::max_poll_time $TICK * 0.1;
…		…
2718		3107
2719	cf::sync_job {	3108	cf::sync_job {
2720	eval {	3109	eval {
2721	BDB::db_env_open	3110	BDB::db_env_open
2722	$DB_ENV,	3111	$DB_ENV,
2723	$BDB_ENV_DIR,	3112	$BDBDIR,
2724	BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN	3113	BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2725	| BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,	3114	| BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2726	0666;	3115	0666;
2727		3116
2728	cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!;	3117	cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2729		3118
2730	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);	3119	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2731	$DB_ENV->set_lk_detect;	3120	$DB_ENV->set_lk_detect;
2732	};	3121	};
2733		3122
…		…
2749	prio => 6,	3138	prio => 6,
2750	cb => \&IO::AIO::poll_cb,	3139	cb => \&IO::AIO::poll_cb,
2751	);	3140	);
2752	}	3141	}
2753		3142
		3143	my $_log_backtrace;
		3144
		3145	sub _log_backtrace {
		3146	my ($msg, @addr) = @_;
		3147
		3148	$msg =~ s/\n//;
		3149
		3150	# limit the # of concurrent backtraces
		3151	if ($_log_backtrace < 2) {
		3152	++$_log_backtrace;
		3153	async {
		3154	my @bt = fork_call {
		3155	@addr = map { sprintf "%x", $_ } @addr;
		3156	my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
		3157	open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
		3158	or die "addr2line: $!";
		3159
		3160	my @funcs;
		3161	my @res = <$fh>;
		3162	chomp for @res;
		3163	while (@res) {
		3164	my ($func, $line) = splice @res, 0, 2, ();
		3165	push @funcs, "[$func] $line";
		3166	}
		3167
		3168	@funcs
		3169	};
		3170
		3171	LOG llevInfo, "[ABT] $msg\n";
		3172	LOG llevInfo, "[ABT] $_\n" for @bt;
		3173	--$_log_backtrace;
		3174	};
		3175	} else {
		3176	LOG llevInfo, "[ABT] $msg\n";
		3177	LOG llevInfo, "[ABT] [suppressed]\n";
		3178	}
		3179	}
		3180
		3181	# load additional modules
		3182	use cf::pod;
		3183
2754	END { cf::emergency_save }	3184	END { cf::emergency_save }
2755		3185
2756	1	3186	1
2757		3187

Diff Legend

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