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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.251 by root, Wed Apr 18 14:45:13 2007 UTC vs.
Revision 1.285 by root, Sun Jun 24 04:21:42 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) {
…		…
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/&/&/g;
		1363	s/(?<![BIUGH])</</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	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;	1746	Coro::cede;
1514	$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;
1515	$self->difficulty ($self->estimate_difficulty)	1765	$self->difficulty ($self->estimate_difficulty)
1516	unless $self->difficulty;	1766	unless $self->difficulty;
1517	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;
1518	$self->activate;	1776	$self->activate;
1519	Coro::cede;	1777	}
		1778
		1779	$self->in_memory (cf::MAP_IN_MEMORY);
1520	}	1780	}
1521		1781
1522	$self->post_load;	1782	$self->post_load;
1523	Coro::cede;
1524
1525	$self->in_memory (cf::MAP_IN_MEMORY);
1526	}	1783	}
1527		1784
1528	sub customise_for {	1785	sub customise_for {
1529	my ($self, $ob) = @_;	1786	my ($self, $ob) = @_;
1530		1787
1531	return find "~" . $ob->name . "/" . $self->{path}	1788	return find "~" . $ob->name . "/" . $self->{path}
1532	if $self->per_player;	1789	if $self->per_player;
		1790
		1791	# return find "?party/" . $ob->name . "/" . $self->{path}
		1792	# if $self->per_party;
1533		1793
1534	$self	1794	$self
1535	}	1795	}
1536		1796
1537	# 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
…		…
1648		1908
1649	sub reset_at {	1909	sub reset_at {
1650	my ($self) = @_;	1910	my ($self) = @_;
1651		1911
1652	# TODO: safety, remove and allow resettable per-player maps	1912	# 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};	1913	return 1e99 if $self->{deny_reset};
1655		1914
1656	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;	1915	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1657	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;
1658		1917
…		…
1669	my ($self) = @_;	1928	my ($self) = @_;
1670		1929
1671	my $lock = cf::lock_acquire "map_data:$self->{path}";	1930	my $lock = cf::lock_acquire "map_data:$self->{path}";
1672		1931
1673	return if $self->players;	1932	return if $self->players;
1674	return if $self->isa ("ext::map_per_player");#d#
1675		1933
1676	warn "resetting map ", $self->path;#d#	1934	warn "resetting map ", $self->path;
1677		1935
1678	$self->in_memory (cf::MAP_SWAPPED);	1936	$self->in_memory (cf::MAP_SWAPPED);
1679		1937
1680	# need to save uniques path	1938	# need to save uniques path
1681	unless ($self->{deny_save}) {	1939	unless ($self->{deny_save}) {
…		…
1713	$cf::MAP{$self->path} = $self;	1971	$cf::MAP{$self->path} = $self;
1714		1972
1715	$self->reset; # polite request, might not happen	1973	$self->reset; # polite request, might not happen
1716	}	1974	}
1717		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
1718	=item cf::map::unique_maps	2012	=item cf::map::unique_maps
1719		2013
1720	Returns an arrayref of paths of all shared maps that have	2014	Returns an arrayref of paths of all shared maps that have
1721	instantiated unique items. May block.	2015	instantiated unique items. May block.
1722		2016
1723	=cut	2017	=cut
1724		2018
1725	sub unique_maps() {	2019	sub unique_maps() {
1726	my $files = aio_readdir cf::localdir . "/" . cf::uniquedir	2020	[
1727	or return;	2021	map {
1728
1729	my @paths;
1730
1731	for (@$files) {
1732	utf8::decode $_;	2022	utf8::decode $_;
1733	next if /\.pst$/;	2023	/\.map$/
1734	next unless /^$PATH_SEP/o;	2024	? normalise $_
1735		2025	: ()
1736	push @paths, cf::map::normalise $_;	2026	} @{ aio_readdir $UNIQUEDIR or [] }
1737	}	2027	]
1738
1739	\@paths
1740	}	2028	}
1741		2029
1742	package cf;	2030	package cf;
1743		2031
1744	=back	2032	=back
…		…
1790		2078
1791	$flags = cf::NDI_BROWN \| cf::NDI_UNIQUE unless @_ >= 4;	2079	$flags = cf::NDI_BROWN \| cf::NDI_UNIQUE unless @_ >= 4;
1792		2080
1793	if ($self->{record_replies}) {	2081	if ($self->{record_replies}) {
1794	push @{ $self->{record_replies} }, [$npc, $msg, $flags];	2082	push @{ $self->{record_replies} }, [$npc, $msg, $flags];
		2083
1795	} 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 {
1796	$msg = $npc->name . " says: $msg" if $npc;	2097	$msg = $npc->name . " says: $msg" if $npc;
1797	$self->message ($msg, $flags);	2098	$self->message ($msg, $flags);
		2099	}
1798	}	2100	}
1799	}	2101	}
1800		2102
1801	=item $player_object->may ("access")	2103	=item $player_object->may ("access")
1802		2104
…		…
1850	$self->deactivate_recursive;	2152	$self->deactivate_recursive;
1851		2153
1852	return if UNIVERSAL::isa $self->map, "ext::map_link";	2154	return if UNIVERSAL::isa $self->map, "ext::map_link";
1853		2155
1854	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]	2156	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]
1855	if $self->map;	2157	if $self->map && $self->map->{path} ne "{link}";
1856		2158
1857	$self->enter_map ($LINK_MAP \|\| link_map, 10, 10);	2159	$self->enter_map ($LINK_MAP \|\| link_map, 10, 10);
1858	}	2160	}
1859		2161
1860	sub cf::object::player::leave_link {	2162	sub cf::object::player::leave_link {
1861	my ($self, $map, $x, $y) = @_;	2163	my ($self, $map, $x, $y) = @_;
		2164
		2165	return unless $self->contr->active;
1862		2166
1863	my $link_pos = delete $self->{_link_pos};	2167	my $link_pos = delete $self->{_link_pos};
1864		2168
1865	unless ($map) {	2169	unless ($map) {
1866	# restore original map position	2170	# restore original map position
…		…
1889		2193
1890	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2194	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1891	$self->enter_map ($map, $x, $y);	2195	$self->enter_map ($map, $x, $y);
1892	}	2196	}
1893		2197
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)	2198	=item $player_object->goto ($path, $x, $y[, $check->($map)])
1927		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
1928	=cut	2205	=cut
		2206
		2207	our $GOTOGEN;
1929		2208
1930	sub cf::object::player::goto {	2209	sub cf::object::player::goto {
1931	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;
1932		2214
1933	$self->enter_link;	2215	$self->enter_link;
1934		2216
1935	(async {	2217	(async {
1936	my $map = eval {	2218	my $map = eval {
1937	my $map = cf::map::find $path;	2219	my $map = cf::map::find $path;
		2220
		2221	if ($map) {
1938	$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
1939	$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 $@;
1940	} or	2234	}
1941	$self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE \| cf::NDI_RED);
1942		2235
		2236	if ($gen == $self->{_goto_generation}) {
		2237	delete $self->{_goto_generation};
1943	$self->leave_link ($map, $x, $y);	2238	$self->leave_link ($map, $x, $y);
		2239	}
1944	})->prio (1);	2240	})->prio (1);
1945	}	2241	}
1946		2242
1947	=item $player_object->enter_exit ($exit_object)	2243	=item $player_object->enter_exit ($exit_object)
1948		2244
…		…
1987		2283
1988	$rmp->{random_seed} \|\|= $exit->random_seed;	2284	$rmp->{random_seed} \|\|= $exit->random_seed;
1989		2285
1990	my $data = cf::to_json $rmp;	2286	my $data = cf::to_json $rmp;
1991	my $md5 = Digest::MD5::md5_hex $data;	2287	my $md5 = Digest::MD5::md5_hex $data;
1992	my $meta = "$cf::RANDOM_MAPS/$md5.meta";	2288	my $meta = "$RANDOMDIR/$md5.meta";
1993		2289
1994	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {	2290	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {
1995	aio_write $fh, 0, (length $data), $data, 0;	2291	aio_write $fh, 0, (length $data), $data, 0;
1996	undef $fh;	2292	undef $fh;
1997	aio_rename "$meta~", $meta;	2293	aio_rename "$meta~", $meta;
…		…
2051	sub cf::client::send_drawinfo {	2347	sub cf::client::send_drawinfo {
2052	my ($self, $text, $flags) = @_;	2348	my ($self, $text, $flags) = @_;
2053		2349
2054	utf8::encode $text;	2350	utf8::encode $text;
2055	$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	s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
		2386	$self->send_packet ("drawinfo $color $msg")
		2387	}
		2388	}
		2389	}
2056	}	2390	}
2057		2391
2058	=item $client->ext_event ($type, %msg)	2392	=item $client->ext_event ($type, %msg)
2059		2393
2060	Sends an exti event to the client.	2394	Sends an exti event to the client.
…		…
2262	=back	2596	=back
2263		2597
2264	=cut	2598	=cut
2265		2599
2266	#############################################################################	2600	#############################################################################
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	local $SIG{__WARN__};
2420	eval {
2421	local $SIG{__DIE__};
2422	close $fh1;
2423
2424	my @res = eval { $cb->(@args) };
2425	syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2426	};
2427
2428	warn $@ if $@;
2429	_exit 0;
2430	}
2431	}
2432
2433
2434
2435	#############################################################################
2436	# the server's init and main functions	2601	# the server's init and main functions
2437		2602
2438	sub load_facedata($) {	2603	sub load_facedata($) {
2439	my ($path) = @_;	2604	my ($path) = @_;
2440		2605
…		…
2485	}	2650	}
2486		2651
2487	1	2652	1
2488	}	2653	}
2489		2654
		2655	sub reload_regions {
		2656	load_resource_file "$MAPDIR/regions"
		2657	or die "unable to load regions file\n";
		2658	}
		2659
2490	sub reload_facedata {	2660	sub reload_facedata {
2491	load_facedata sprintf "%s/facedata", cf::datadir	2661	load_facedata "$DATADIR/facedata"
2492	or die "unable to load facedata\n";	2662	or die "unable to load facedata\n";
2493	}	2663	}
2494		2664
2495	sub reload_regions {
2496	load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir
2497	or die "unable to load regions file\n";
2498	}
2499
2500	sub reload_archetypes {	2665	sub reload_archetypes {
2501	load_resource_file sprintf "%s/archetypes", cf::datadir	2666	load_resource_file "$DATADIR/archetypes"
2502	or die "unable to load archetypes\n";	2667	or die "unable to load archetypes\n";
2503	}	2668	}
2504		2669
2505	sub reload_treasures {	2670	sub reload_treasures {
2506	load_resource_file sprintf "%s/treasures", cf::datadir	2671	load_resource_file "$DATADIR/treasures"
2507	or die "unable to load treasurelists\n";	2672	or die "unable to load treasurelists\n";
2508	}	2673	}
2509		2674
2510	sub reload_resources {	2675	sub reload_resources {
2511	warn "reloading resource files...\n";	2676	warn "reloading resource files...\n";
2512		2677
2513	reload_regions;	2678	reload_regions;
2514	reload_facedata;	2679	reload_facedata;
		2680	#reload_archetypes;#d#
2515	reload_archetypes;	2681	reload_archetypes;
2516	reload_treasures;	2682	reload_treasures;
2517		2683
2518	warn "finished reloading resource files\n";	2684	warn "finished reloading resource files\n";
2519	}	2685	}
…		…
2521	sub init {	2687	sub init {
2522	reload_resources;	2688	reload_resources;
2523	}	2689	}
2524		2690
2525	sub cfg_load {	2691	sub cfg_load {
2526	open my $fh, "<:utf8", cf::confdir . "/config"	2692	open my $fh, "<:utf8", "$CONFDIR/config"
2527	or return;	2693	or return;
2528		2694
2529	local $/;	2695	local $/;
2530	*CFG = YAML::Syck::Load <$fh>;	2696	*CFG = YAML::Syck::Load <$fh>;
2531		2697
…		…
2576	},	2742	},
2577	);	2743	);
2578	}	2744	}
2579	}	2745	}
2580		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
2581	sub emergency_save() {	2785	sub emergency_save() {
2582	my $freeze_guard = cf::freeze_mainloop;	2786	my $freeze_guard = cf::freeze_mainloop;
2583		2787
2584	warn "enter emergency perl save\n";	2788	warn "enter emergency perl save\n";
2585		2789
…		…
2701	Symbol::delete_package "safe::$_"	2905	Symbol::delete_package "safe::$_"
2702	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);
2703		2907
2704	warn "unloading cf.pm \"a bit\"";	2908	warn "unloading cf.pm \"a bit\"";
2705	delete $INC{"cf.pm"};	2909	delete $INC{"cf.pm"};
		2910	delete $INC{"cf/pod.pm"};
2706		2911
2707	# don't, removes xs symbols, too,	2912	# don't, removes xs symbols, too,
2708	# and global variables created in xs	2913	# and global variables created in xs
2709	#Symbol::delete_package __PACKAGE__;	2914	#Symbol::delete_package __PACKAGE__;
2710		2915
…		…
2788	my $signal = new Coro::Signal;	2993	my $signal = new Coro::Signal;
2789	push @WAIT_FOR_TICK_BEGIN, $signal;	2994	push @WAIT_FOR_TICK_BEGIN, $signal;
2790	$signal->wait;	2995	$signal->wait;
2791	}	2996	}
2792		2997
		2998	my $min = 1e6;#d#
		2999	my $avg = 10;
2793	$TICK_WATCHER = Event->timer (	3000	$TICK_WATCHER = Event->timer (
2794	reentrant => 0,	3001	reentrant => 0,
2795	parked => 1,	3002	parked => 1,
2796	prio => 0,	3003	prio => 0,
2797	at => $NEXT_TICK \|\| $TICK,	3004	at => $NEXT_TICK \|\| $TICK,
…		…
2801	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"
2802	unless ++$bug_warning > 10;	3009	unless ++$bug_warning > 10;
2803	return;	3010	return;
2804	}	3011	}
2805		3012
2806	$NOW = Event::time;	3013	$NOW = $tick_start = Event::time;
2807		3014
2808	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	};
2809		3039
2810	$RUNTIME += $TICK;	3040	$RUNTIME += $TICK;
2811	$NEXT_TICK += $TICK;	3041	$NEXT_TICK += $TICK;
2812		3042
2813	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3043	if ($NOW >= $NEXT_RUNTIME_WRITE) {
…		…
2819	}	3049	}
2820		3050
2821	# my $AFTER = Event::time;	3051	# my $AFTER = Event::time;
2822	# warn $AFTER - $NOW;#d#	3052	# warn $AFTER - $NOW;#d#
2823		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
2824	# 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
2825	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;	3064	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2826		3065
2827	$TICK_WATCHER->at ($NEXT_TICK);	3066	$TICK_WATCHER->at ($NEXT_TICK);
2828	$TICK_WATCHER->start;	3067	$TICK_WATCHER->start;
2829		3068
2830	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3069	$LOAD = ($NOW - $tick_start) / $TICK;
2831	$sig->send;	3070	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2832	}
2833	while (my $sig = shift @WAIT_FOR_TICK) {
2834	$sig->send;
2835	}
2836		3071
2837	_post_tick;	3072	_post_tick;
		3073
		3074
2838	},	3075	},
2839	);	3076	);
2840		3077
2841	{	3078	{
2842	BDB::max_poll_time $TICK * 0.1;	3079	BDB::max_poll_time $TICK * 0.1;
…		…
2870		3107
2871	cf::sync_job {	3108	cf::sync_job {
2872	eval {	3109	eval {
2873	BDB::db_env_open	3110	BDB::db_env_open
2874	$DB_ENV,	3111	$DB_ENV,
2875	$BDB_ENV_DIR,	3112	$BDBDIR,
2876	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
2877	\| BDB::RECOVER \| BDB::REGISTER \| BDB::USE_ENVIRON \| BDB::CREATE,	3114	\| BDB::RECOVER \| BDB::REGISTER \| BDB::USE_ENVIRON \| BDB::CREATE,
2878	0666;	3115	0666;
2879		3116
2880	cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!;	3117	cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2881		3118
2882	$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);
2883	$DB_ENV->set_lk_detect;	3120	$DB_ENV->set_lk_detect;
2884	};	3121	};
2885		3122
…		…
2901	prio => 6,	3138	prio => 6,
2902	cb => \&IO::AIO::poll_cb,	3139	cb => \&IO::AIO::poll_cb,
2903	);	3140	);
2904	}	3141	}
2905		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
2906	# load additional modules	3181	# load additional modules
2907	use cf::pod;	3182	use cf::pod;
2908		3183
2909	END { cf::emergency_save }	3184	END { cf::emergency_save }
2910		3185

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.251 by root, Wed Apr 18 14:45:13 2007 UTC vs. Revision 1.285 by root, Sun Jun 24 04:21:42 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.251 by root, Wed Apr 18 14:45:13 2007 UTC vs.
Revision 1.285 by root, Sun Jun 24 04:21:42 2007 UTC