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.108 by root, Sun Dec 31 21:02:05 2006 UTC vs.
Revision 1.290 by root, Mon Jul 2 03:15:30 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;
		10	use Event;
9	use Opcode;	11	use Opcode;
10	use Safe;	12	use Safe;
11	use Safe::Hole;	13	use Safe::Hole;
12		14
13	use Coro 3.3;	15	use Coro 3.61 ();
		16	use Coro::State;
		17	use Coro::Handle;
14	use Coro::Event;	18	use Coro::Event;
15	use Coro::Timer;	19	use Coro::Timer;
16	use Coro::Signal;	20	use Coro::Signal;
17	use Coro::Semaphore;	21	use Coro::Semaphore;
18	use Coro::AIO;	22	use Coro::AIO;
		23	use Coro::Storable;
19		24
		25	use JSON::XS 1.4 ();
		26	use BDB ();
		27	use Data::Dumper;
20	use Digest::MD5;	28	use Digest::MD5;
21	use Fcntl;	29	use Fcntl;
22	use IO::AIO 2.31 ();
23	use YAML::Syck ();	30	use YAML::Syck ();
		31	use IO::AIO 2.32 ();
24	use Time::HiRes;	32	use Time::HiRes;
		33	use Compress::LZF;
25		34
		35	# configure various modules to our taste
		36	#
		37	$Storable::canonical = 1; # reduce rsync transfers
		38	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
		39	Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
		40
26	use Event; $Event::Eval = 1; # no idea why this is required, but it is	41	$Event::Eval = 1; # no idea why this is required, but it is
27		42
28	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?	43	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29	$YAML::Syck::ImplicitUnicode = 1;	44	$YAML::Syck::ImplicitUnicode = 1;
30		45
31	$Coro::main->prio (2); # run main coroutine ("the server") with very high priority	46	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32		47
33	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	48	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34		49
35	our %COMMAND = ();	50	our %COMMAND = ();
36	our %COMMAND_TIME = ();	51	our %COMMAND_TIME = ();
		52
		53	our @EXTS = (); # list of extension package names
37	our %EXTCMD = ();	54	our %EXTCMD = ();
		55	our %EXTICMD = ();
		56	our %EXT_CORO = (); # coroutines bound to extensions
		57	our %EXT_MAP = (); # pluggable maps
38		58
		59	our $RELOAD; # number of reloads so far
39	our @EVENT;	60	our @EVENT;
40	our $LIBDIR = datadir . "/ext";
41		61
42	our $TICK = MAX_TIME * 1e-6;	62	our $CONFDIR = confdir;
		63	our $DATADIR = datadir;
		64	our $LIBDIR = "$DATADIR/ext";
		65	our $PODDIR = "$DATADIR/pod";
		66	our $MAPDIR = "$DATADIR/" . mapdir;
		67	our $LOCALDIR = localdir;
		68	our $TMPDIR = "$LOCALDIR/" . tmpdir;
		69	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
		70	our $PLAYERDIR = "$LOCALDIR/" . playerdir;
		71	our $RANDOMDIR = "$LOCALDIR/random";
		72	our $BDBDIR = "$LOCALDIR/db";
		73
		74	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
43	our $TICK_WATCHER;	75	our $TICK_WATCHER;
		76	our $AIO_POLL_WATCHER;
		77	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
44	our $NEXT_TICK;	78	our $NEXT_TICK;
45	our $NOW;	79	our $NOW;
		80	our $USE_FSYNC = 1; # use fsync to write maps - default off
		81
		82	our $BDB_POLL_WATCHER;
		83	our $DB_ENV;
46		84
47	our %CFG;	85	our %CFG;
48		86
49	our $UPTIME; $UPTIME ||= time;	87	our $UPTIME; $UPTIME ||= time;
50	our $RUNTIME;	88	our $RUNTIME;
51		89
		90	our %PLAYER; # all users
52	our %MAP; # all maps	91	our %MAP; # all maps
53	our $LINK_MAP; # the special {link} map	92	our $LINK_MAP; # the special {link} map, which is always available
54	our $FREEZE;	93
55	our $RANDOM_MAPS = cf::localdir . "/random";	94	# used to convert map paths into valid unix filenames by replacing / by ∕
56	our %EXT_CORO;	95	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
		96
		97	our $LOAD; # a number between 0 (idle) and 1 (too many objects)
		98	our $LOADAVG; # same thing, but with alpha-smoothing
		99	our $tick_start; # for load detecting purposes
57		100
58	binmode STDOUT;	101	binmode STDOUT;
59	binmode STDERR;	102	binmode STDERR;
60		103
61	# read virtual server time, if available	104	# read virtual server time, if available
62	unless ($RUNTIME || !-e cf::localdir . "/runtime") {	105	unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
63	open my $fh, "<", cf::localdir . "/runtime"	106	open my $fh, "<", "$LOCALDIR/runtime"
64	or die "unable to read runtime file: $!";	107	or die "unable to read runtime file: $!";
65	$RUNTIME = <$fh> + 0.;	108	$RUNTIME = <$fh> + 0.;
66	}	109	}
67		110
68	mkdir cf::localdir;	111	mkdir $_
69	mkdir cf::localdir . "/" . cf::playerdir;	112	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
70	mkdir cf::localdir . "/" . cf::tmpdir;
71	mkdir cf::localdir . "/" . cf::uniquedir;
72	mkdir $RANDOM_MAPS;
73		113
74	# a special map that is always available	114	our $EMERGENCY_POSITION;
75	our $LINK_MAP;	115
		116	sub cf::map::normalise;
76		117
77	#############################################################################	118	#############################################################################
78		119
79	=head2 GLOBAL VARIABLES	120	=head2 GLOBAL VARIABLES
80		121
…		…
87	=item $cf::RUNTIME	128	=item $cf::RUNTIME
88		129
89	The time this server has run, starts at 0 and is increased by $cf::TICK on	130	The time this server has run, starts at 0 and is increased by $cf::TICK on
90	every server tick.	131	every server tick.
91		132
92	=item $cf::LIBDIR	133	=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
		134	$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
		135	$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
93		136
94	The perl library directory, where extensions and cf-specific modules can	137	Various directories - "/etc", read-only install directory, perl-library
95	be found. It will be added to C<@INC> automatically.	138	directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
		139	unique-items directory, player file directory, random maps directory and
		140	database environment.
96		141
97	=item $cf::NOW	142	=item $cf::NOW
98		143
99	The time of the last (current) server tick.	144	The time of the last (current) server tick.
100		145
101	=item $cf::TICK	146	=item $cf::TICK
102		147
103	The interval between server ticks, in seconds.	148	The interval between server ticks, in seconds.
		149
		150	=item $cf::LOADAVG
		151
		152	The current CPU load on the server (alpha-smoothed), as a value between 0
		153	(none) and 1 (overloaded), indicating how much time is spent on processing
		154	objects per tick. Healthy values are < 0.5.
		155
		156	=item $cf::LOAD
		157
		158	The raw value load value from the last tick.
104		159
105	=item %cf::CFG	160	=item %cf::CFG
106		161
107	Configuration for the server, loaded from C</etc/crossfire/config>, or	162	Configuration for the server, loaded from C</etc/crossfire/config>, or
108	from wherever your confdir points to.	163	from wherever your confdir points to.
		164
		165	=item cf::wait_for_tick, cf::wait_for_tick_begin
		166
		167	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
		168	returns directly I<after> the tick processing (and consequently, can only wake one process
		169	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
109		170
110	=back	171	=back
111		172
112	=cut	173	=cut
113		174
114	BEGIN {	175	BEGIN {
115	*CORE::GLOBAL::warn = sub {	176	*CORE::GLOBAL::warn = sub {
116	my $msg = join "", @_;	177	my $msg = join "", @_;
117	utf8::encode $msg;
118		178
119	$msg .= "\n"	179	$msg .= "\n"
120	unless $msg =~ /\n$/;	180	unless $msg =~ /\n$/;
121		181
		182	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
		183
		184	utf8::encode $msg;
122	LOG llevError, "cfperl: $msg";	185	LOG llevError, $msg;
123	};	186	};
124	}	187	}
125		188
126	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	189	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
127	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';	190	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
128	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';	191	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
129	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';	192	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
130	@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';	193	@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
		194	@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
131	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';	195	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
132		196
133	# we bless all objects into (empty) derived classes to force a method lookup	197	# we bless all objects into (empty) derived classes to force a method lookup
134	# within the Safe compartment.	198	# within the Safe compartment.
135	for my $pkg (qw(	199	for my $pkg (qw(
136	cf::global cf::attachable	200	cf::global cf::attachable
…		…
145		209
146	$Event::DIED = sub {	210	$Event::DIED = sub {
147	warn "error in event callback: @_";	211	warn "error in event callback: @_";
148	};	212	};
149		213
150	my %ext_pkg;	214	#############################################################################
151	my @exts;
152	my @hook;
153		215
154	=head2 UTILITY FUNCTIONS	216	=head2 UTILITY FUNCTIONS
155		217
156	=over 4	218	=over 4
157		219
158	=cut	220	=item dumpval $ref
159		221
160	use JSON::Syck (); # TODO# replace by JSON::PC once working	222	=cut
		223
		224	sub dumpval {
		225	eval {
		226	local $SIG{__DIE__};
		227	my $d;
		228	if (1) {
		229	$d = new Data::Dumper([$_[0]], ["*var"]);
		230	$d->Terse(1);
		231	$d->Indent(2);
		232	$d->Quotekeys(0);
		233	$d->Useqq(1);
		234	#$d->Bless(...);
		235	$d->Seen($_[1]) if @_ > 1;
		236	$d = $d->Dump();
		237	}
		238	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
		239	$d
		240	} || "[unable to dump $_[0]: '$@']";
		241	}
161		242
162	=item $ref = cf::from_json $json	243	=item $ref = cf::from_json $json
163		244
164	Converts a JSON string into the corresponding perl data structure.	245	Converts a JSON string into the corresponding perl data structure.
165		246
166	=cut
167
168	sub from_json($) {
169	$JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
170	JSON::Syck::Load $_[0]
171	}
172
173	=item $json = cf::to_json $ref	247	=item $json = cf::to_json $ref
174		248
175	Converts a perl data structure into its JSON representation.	249	Converts a perl data structure into its JSON representation.
176		250
177	=cut	251	=cut
178		252
179	sub to_json($) {	253	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
180	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs	254
181	JSON::Syck::Dump $_[0]	255	sub to_json ($) { $json_coder->encode ($_[0]) }
		256	sub from_json ($) { $json_coder->decode ($_[0]) }
		257
		258	=item cf::lock_wait $string
		259
		260	Wait until the given lock is available. See cf::lock_acquire.
		261
		262	=item my $lock = cf::lock_acquire $string
		263
		264	Wait until the given lock is available and then acquires it and returns
		265	a Coro::guard object. If the guard object gets destroyed (goes out of scope,
		266	for example when the coroutine gets canceled), the lock is automatically
		267	returned.
		268
		269	Lock names should begin with a unique identifier (for example, cf::map::find
		270	uses map_find and cf::map::load uses map_load).
		271
		272	=item $locked = cf::lock_active $string
		273
		274	Return true if the lock is currently active, i.e. somebody has locked it.
		275
		276	=cut
		277
		278	our %LOCK;
		279
		280	sub lock_wait($) {
		281	my ($key) = @_;
		282
		283	# wait for lock, if any
		284	while ($LOCK{$key}) {
		285	push @{ $LOCK{$key} }, $Coro::current;
		286	Coro::schedule;
		287	}
182	}	288	}
		289
		290	sub lock_acquire($) {
		291	my ($key) = @_;
		292
		293	# wait, to be sure we are not locked
		294	lock_wait $key;
		295
		296	$LOCK{$key} = [];
		297
		298	Coro::guard {
		299	# wake up all waiters, to be on the safe side
		300	$_->ready for @{ delete $LOCK{$key} };
		301	}
		302	}
		303
		304	sub lock_active($) {
		305	my ($key) = @_;
		306
		307	! ! $LOCK{$key}
		308	}
		309
		310	sub freeze_mainloop {
		311	return unless $TICK_WATCHER->is_active;
		312
		313	my $guard = Coro::guard {
		314	$TICK_WATCHER->start;
		315	};
		316	$TICK_WATCHER->stop;
		317	$guard
		318	}
		319
		320	=item cf::async { BLOCK }
		321
		322	Currently the same as Coro::async_pool, meaning you cannot use
		323	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
		324	thing you are allowed to do is call C<prio> on it.
		325
		326	=cut
		327
		328	BEGIN { *async = \&Coro::async_pool }
183		329
184	=item cf::sync_job { BLOCK }	330	=item cf::sync_job { BLOCK }
185		331
186	The design of crossfire+ requires that the main coro ($Coro::main) is	332	The design of Crossfire TRT requires that the main coroutine ($Coro::main)
187	always able to handle events or runnable, as crossfire+ is only partly	333	is always able to handle events or runnable, as Crossfire TRT is only
188	reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.	334	partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
		335	acceptable.
189		336
190	If it must be done, put the blocking parts into C<sync_job>. This will run	337	If it must be done, put the blocking parts into C<sync_job>. This will run
191	the given BLOCK in another coroutine while waiting for the result. The	338	the given BLOCK in another coroutine while waiting for the result. The
192	server will be frozen during this time, so the block should either finish	339	server will be frozen during this time, so the block should either finish
193	fast or be very important.	340	fast or be very important.
…		…
195	=cut	342	=cut
196		343
197	sub sync_job(&) {	344	sub sync_job(&) {
198	my ($job) = @_;	345	my ($job) = @_;
199		346
200	my $busy = 1;
201	my @res;
202
203	# TODO: use suspend/resume instead
204	local $FREEZE = 1;
205
206	my $coro = Coro::async {
207	@res = eval { $job->() };
208	warn $@ if $@;
209	undef $busy;
210	};
211
212	if ($Coro::current == $Coro::main) {	347	if ($Coro::current == $Coro::main) {
		348	my $time = Event::time;
		349
		350	# this is the main coro, too bad, we have to block
		351	# till the operation succeeds, freezing the server :/
		352
		353	# TODO: use suspend/resume instead
		354	# (but this is cancel-safe)
		355	my $freeze_guard = freeze_mainloop;
		356
		357	my $busy = 1;
		358	my @res;
		359
		360	(async {
		361	@res = eval { $job->() };
		362	warn $@ if $@;
		363	undef $busy;
213	$coro->prio (Coro::PRIO_MAX);	364	})->prio (Coro::PRIO_MAX);
		365
214	while ($busy) {	366	while ($busy) {
215	Coro::cede_notself;	367	Coro::cede or Event::one_event;
216	Event::one_event unless Coro::nready;
217	}	368	}
		369
		370	$time = Event::time - $time;
		371
		372	LOG llevError | logBacktrace, Carp::longmess "long sync job"
		373	if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
		374
		375	$tick_start += $time; # do not account sync jobs to server load
		376
		377	wantarray ? @res : $res[0]
218	} else {	378	} else {
219	$coro->join;	379	# we are in another coroutine, how wonderful, everything just works
		380
		381	$job->()
220	}	382	}
221
222	wantarray ? @res : $res[0]
223	}	383	}
224		384
225	=item $coro = cf::coro { BLOCK }	385	=item $coro = cf::async_ext { BLOCK }
226		386
227	Creates and returns a new coro. This coro is automcatially being canceled	387	Like async, but this coro is automatically being canceled when the
228	when the extension calling this is being unloaded.	388	extension calling this is being unloaded.
229		389
230	=cut	390	=cut
231		391
232	sub coro(&) {	392	sub async_ext(&) {
233	my $cb = shift;	393	my $cb = shift;
234		394
235	my $coro; $coro = async {	395	my $coro = &Coro::async ($cb);
236	eval {
237	$cb->();
238	};
239	warn $@ if $@;
240	};
241		396
242	$coro->on_destroy (sub {	397	$coro->on_destroy (sub {
243	delete $EXT_CORO{$coro+0};	398	delete $EXT_CORO{$coro+0};
244	});	399	});
245	$EXT_CORO{$coro+0} = $coro;	400	$EXT_CORO{$coro+0} = $coro;
246		401
247	$coro	402	$coro
248	}	403	}
249		404
250	sub write_runtime {	405	=item fork_call { }, $args
251	my $runtime = cf::localdir . "/runtime";
252		406
253	my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644	407	Executes the given code block with the given arguments in a seperate
254	or return;	408	process, returning the results. Everything must be serialisable with
		409	Coro::Storable. May, of course, block. Note that the executed sub may
		410	never block itself or use any form of Event handling.
255		411
256	my $value = $cf::RUNTIME;	412	=cut
257	(aio_write $fh, 0, (length $value), $value, 0) <= 0
258	and return;
259		413
260	aio_fsync $fh	414	sub fork_call(&@) {
261	and return;	415	my ($cb, @args) = @_;
262		416
		417	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
		418	# or die "socketpair: $!";
		419	pipe my $fh1, my $fh2
		420	or die "pipe: $!";
		421
		422	if (my $pid = fork) {
263	close $fh	423	close $fh2;
264	or return;
265		424
266	aio_rename "$runtime~", $runtime	425	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
267	and return;	426	$res = Coro::Storable::thaw $res;
268		427
		428	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
		429
		430	die $$res unless "ARRAY" eq ref $res;
		431
		432	return wantarray ? @$res : $res->[-1];
		433	} else {
		434	reset_signals;
		435	local $SIG{__WARN__};
		436	local $SIG{__DIE__};
		437	eval {
		438	close $fh1;
		439
		440	my @res = eval { $cb->(@args) };
		441	syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
		442	};
		443
		444	warn $@ if $@;
		445	_exit 0;
269	1	446	}
		447	}
		448
		449	=item $value = cf::db_get $family => $key
		450
		451	Returns a single value from the environment database.
		452
		453	=item cf::db_put $family => $key => $value
		454
		455	Stores the given C<$value> in the family. It can currently store binary
		456	data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
		457
		458	=cut
		459
		460	our $DB;
		461
		462	sub db_init {
		463	unless ($DB) {
		464	$DB = BDB::db_create $DB_ENV;
		465
		466	cf::sync_job {
		467	eval {
		468	$DB->set_flags (BDB::CHKSUM);
		469
		470	BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
		471	BDB::CREATE | BDB::AUTO_COMMIT, 0666;
		472	cf::cleanup "db_open(db): $!" if $!;
		473	};
		474	cf::cleanup "db_open(db): $@" if $@;
		475	};
		476	}
		477	}
		478
		479	sub db_get($$) {
		480	my $key = "$_[0]/$_[1]";
		481
		482	cf::sync_job {
		483	BDB::db_get $DB, undef, $key, my $data;
		484
		485	$! ? ()
		486	: $data
		487	}
		488	}
		489
		490	sub db_put($$$) {
		491	BDB::dbreq_pri 4;
		492	BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
		493	}
		494
		495	=item cf::cache $id => [$paths...], $processversion => $process
		496
		497	Generic caching function that returns the value of the resource $id,
		498	caching and regenerating as required.
		499
		500	This function can block.
		501
		502	=cut
		503
		504	sub cache {
		505	my ($id, $src, $processversion, $process) = @_;
		506
		507	my $meta =
		508	join "\x00",
		509	$processversion,
		510	map {
		511	aio_stat $_
		512	and Carp::croak "$_: $!";
		513
		514	($_, (stat _)[7,9])
		515	} @$src;
		516
		517	my $dbmeta = db_get cache => "$id/meta";
		518	if ($dbmeta ne $meta) {
		519	# changed, we may need to process
		520
		521	my @data;
		522	my $md5;
		523
		524	for (0 .. $#$src) {
		525	0 <= aio_load $src->[$_], $data[$_]
		526	or Carp::croak "$src->[$_]: $!";
		527	}
		528
		529	# if processing is expensive, check
		530	# checksum first
		531	if (1) {
		532	$md5 =
		533	join "\x00",
		534	$processversion,
		535	map {
		536	Coro::cede;
		537	($src->[$_], Digest::MD5::md5_hex $data[$_])
		538	} 0.. $#$src;
		539
		540
		541	my $dbmd5 = db_get cache => "$id/md5";
		542	if ($dbmd5 eq $md5) {
		543	db_put cache => "$id/meta", $meta;
		544
		545	return db_get cache => "$id/data";
		546	}
		547	}
		548
		549	my $t1 = Time::HiRes::time;
		550	my $data = $process->(\@data);
		551	my $t2 = Time::HiRes::time;
		552
		553	warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
		554
		555	db_put cache => "$id/data", $data;
		556	db_put cache => "$id/md5" , $md5;
		557	db_put cache => "$id/meta", $meta;
		558
		559	return $data;
		560	}
		561
		562	db_get cache => "$id/data"
		563	}
		564
		565	=item cf::datalog type => key => value, ...
		566
		567	Log a datalog packet of the given type with the given key-value pairs.
		568
		569	=cut
		570
		571	sub datalog($@) {
		572	my ($type, %kv) = @_;
		573	warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
270	}	574	}
271		575
272	=back	576	=back
273		577
274	=cut	578	=cut
275
276	#############################################################################
277
278	package cf::path;
279
280	sub new {
281	my ($class, $path, $base) = @_;
282
283	my $self = bless { }, $class;
284
285	if ($path =~ s{^\?random/}{}) {
286	$self->{random} = cf::from_json $path;
287	} else {
288	if ($path =~ s{^~([^/]+)?}{}) {
289	$self->{user_rel} = 1;
290
291	if (defined $1) {
292	$self->{user} = $1;
293	} elsif ($base =~ m{^~([^/]+)/}) {
294	$self->{user} = $1;
295	} else {
296	warn "cannot resolve user-relative path without user <$path,$base>\n";
297	}
298	} elsif ($path =~ /^\//) {
299	# already absolute
300	} else {
301	$base =~ s{[^/]+/?$}{};
302	return $class->new ("$base/$path");
303	}
304
305	for ($path) {
306	redo if s{/\.?/}{/};
307	redo if s{/[^/]+/\.\./}{/};
308	}
309	}
310
311	$self->{path} = $path;
312
313	$self
314	}
315
316	# the name / primary key / in-game path
317	sub as_string {
318	my ($self) = @_;
319
320	$self->{user_rel} ? "~$self->{user}$self->{path}"
321	: $self->{random} ? "?random/$self->{path}"
322	: $self->{path}
323	}
324
325	# the displayed name, this is a one way mapping
326	sub visible_name {
327	my ($self) = @_;
328
329	$self->{random} ? "?random/$self->{random}{origin_map}+$self->{random}{origin_x}+$self->{random}{origin_y}/$self->{random}{dungeon_level}"
330	: $self->as_string
331	}
332
333	# escape the /'s in the path
334	sub _escaped_path {
335	# ∕ is U+2215
336	(my $path = $_[0]{path}) =~ s/\//∕/g;
337	$path
338	}
339
340	# the original (read-only) location
341	sub load_path {
342	my ($self) = @_;
343
344	sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
345	}
346
347	# the temporary/swap location
348	sub save_path {
349	my ($self) = @_;
350
351	$self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
352	: $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, Digest::MD5::md5_hex $self->{path}
353	: sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
354	}
355
356	# the unique path, might be eq to save_path
357	sub uniq_path {
358	my ($self) = @_;
359
360	$self->{user_rel} || $self->{random}
361	? undef
362	: sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
363	}
364
365	# return random map parameters, or undef
366	sub random_map_params {
367	my ($self) = @_;
368
369	$self->{random}
370	}
371
372	# this is somewhat ugly, but style maps do need special treatment
373	sub is_style_map {
374	$_[0]{path} =~ m{^/styles/}
375	}
376
377	package cf;
378		579
379	#############################################################################	580	#############################################################################
380		581
381	=head2 ATTACHABLE OBJECTS	582	=head2 ATTACHABLE OBJECTS
382		583
…		…
384	attach callbacks/event handlers (a collection of which is called an "attachment")	585	attach callbacks/event handlers (a collection of which is called an "attachment")
385	to it. All such attachable objects support the following methods.	586	to it. All such attachable objects support the following methods.
386		587
387	In the following description, CLASS can be any of C<global>, C<object>	588	In the following description, CLASS can be any of C<global>, C<object>
388	C<player>, C<client> or C<map> (i.e. the attachable objects in	589	C<player>, C<client> or C<map> (i.e. the attachable objects in
389	crossfire+).	590	Crossfire TRT).
390		591
391	=over 4	592	=over 4
392		593
393	=item $attachable->attach ($attachment, key => $value...)	594	=item $attachable->attach ($attachment, key => $value...)
394		595
…		…
508	our @CB_TYPE = (); # registry for type (cf-object class) based events	709	our @CB_TYPE = (); # registry for type (cf-object class) based events
509	our @CB_MAP = ();	710	our @CB_MAP = ();
510		711
511	my %attachment;	712	my %attachment;
512		713
		714	sub cf::attachable::thawer_merge {
		715	# simply override everything except _meta
		716	local $_[0]{_meta};
		717	%{$_[0]} = %{$_[1]};
		718	}
		719
513	sub _attach_cb($$$$) {	720	sub _attach_cb($$$$) {
514	my ($registry, $event, $prio, $cb) = @_;	721	my ($registry, $event, $prio, $cb) = @_;
515		722
516	use sort 'stable';	723	use sort 'stable';
517		724
…		…
551	$registry = $CB_TYPE[$object_type] ||= [];	758	$registry = $CB_TYPE[$object_type] ||= [];
552		759
553	} elsif ($type eq "subtype") {	760	} elsif ($type eq "subtype") {
554	defined $object_type or Carp::croak "subtype specified without type";	761	defined $object_type or Carp::croak "subtype specified without type";
555	my $object_subtype = shift @arg;	762	my $object_subtype = shift @arg;
556	$registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];	763	$registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
557		764
558	} elsif ($type eq "package") {	765	} elsif ($type eq "package") {
559	my $pkg = shift @arg;	766	my $pkg = shift @arg;
560		767
561	while (my ($name, $id) = each %cb_id) {	768	while (my ($name, $id) = each %cb_id) {
…		…
590	_attach $registry, $klass, @attach;	797	_attach $registry, $klass, @attach;
591	}	798	}
592		799
593	$obj->{$name} = \%arg;	800	$obj->{$name} = \%arg;
594	} else {	801	} else {
595	warn "object uses attachment '$name' that is not available, postponing.\n";	802	warn "object uses attachment '$name' which is not available, postponing.\n";
596	}	803	}
597		804
598	$obj->{_attachment}{$name} = undef;	805	$obj->{_attachment}{$name} = undef;
599	}	806	}
600		807
…		…
602	if (ref $_[0]) {	809	if (ref $_[0]) {
603	_object_attach @_;	810	_object_attach @_;
604	} else {	811	} else {
605	_attach shift->_attach_registry, @_;	812	_attach shift->_attach_registry, @_;
606	}	813	}
		814	_recalc_want;
607	};	815	};
608		816
609	# all those should be optimised	817	# all those should be optimised
610	sub cf::attachable::detach {	818	sub cf::attachable::detach {
611	my ($obj, $name) = @_;	819	my ($obj, $name) = @_;
…		…
614	delete $obj->{_attachment}{$name};	822	delete $obj->{_attachment}{$name};
615	reattach ($obj);	823	reattach ($obj);
616	} else {	824	} else {
617	Carp::croak "cannot, currently, detach class attachments";	825	Carp::croak "cannot, currently, detach class attachments";
618	}	826	}
		827	_recalc_want;
619	};	828	};
620		829
621	sub cf::attachable::attached {	830	sub cf::attachable::attached {
622	my ($obj, $name) = @_;	831	my ($obj, $name) = @_;
623		832
…		…
688	# object support	897	# object support
689		898
690	sub reattach {	899	sub reattach {
691	# basically do the same as instantiate, without calling instantiate	900	# basically do the same as instantiate, without calling instantiate
692	my ($obj) = @_;	901	my ($obj) = @_;
		902
		903	bless $obj, ref $obj; # re-bless in case extensions have been reloaded
693		904
694	my $registry = $obj->registry;	905	my $registry = $obj->registry;
695		906
696	@$registry = ();	907	@$registry = ();
697		908
…		…
744	$filename, length $$rdata, scalar @$objs;	955	$filename, length $$rdata, scalar @$objs;
745		956
746	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {	957	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
747	chmod SAVE_MODE, $fh;	958	chmod SAVE_MODE, $fh;
748	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	959	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
749	aio_fsync $fh;	960	aio_fsync $fh if $cf::USE_FSYNC;
750	close $fh;	961	close $fh;
751		962
752	if (@$objs) {	963	if (@$objs) {
753	if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {	964	if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
754	chmod SAVE_MODE, $fh;	965	chmod SAVE_MODE, $fh;
755	my $data = Storable::nfreeze { version => 1, objs => $objs };	966	my $data = Storable::nfreeze { version => 1, objs => $objs };
756	aio_write $fh, 0, (length $data), $data, 0;	967	aio_write $fh, 0, (length $data), $data, 0;
757	aio_fsync $fh;	968	aio_fsync $fh if $cf::USE_FSYNC;
758	close $fh;	969	close $fh;
759	aio_rename "$filename.pst~", "$filename.pst";	970	aio_rename "$filename.pst~", "$filename.pst";
760	}	971	}
761	} else {	972	} else {
762	aio_unlink "$filename.pst";	973	aio_unlink "$filename.pst";
…		…
790	or return;	1001	or return;
791		1002
792	unless (aio_stat "$filename.pst") {	1003	unless (aio_stat "$filename.pst") {
793	(aio_load "$filename.pst", $av) >= 0	1004	(aio_load "$filename.pst", $av) >= 0
794	or return;	1005	or return;
795	$av = eval { (Storable::thaw <$av>)->{objs} };	1006	$av = eval { (Storable::thaw $av)->{objs} };
796	}	1007	}
797		1008
		1009	warn sprintf "loading %s (%d)\n",
		1010	$filename, length $data, scalar @{$av || []};
798	return ($data, $av);	1011	return ($data, $av);
799	}	1012	}
		1013
		1014	=head2 COMMAND CALLBACKS
		1015
		1016	=over 4
		1017
		1018	=cut
800		1019
801	#############################################################################	1020	#############################################################################
802	# command handling &c	1021	# command handling &c
803		1022
804	=item cf::register_command $name => \&callback($ob,$args);	1023	=item cf::register_command $name => \&callback($ob,$args);
…		…
817	push @{ $COMMAND{$name} }, [$caller, $cb];	1036	push @{ $COMMAND{$name} }, [$caller, $cb];
818	}	1037	}
819		1038
820	=item cf::register_extcmd $name => \&callback($pl,$packet);	1039	=item cf::register_extcmd $name => \&callback($pl,$packet);
821		1040
822	Register a callbackf ro execution when the client sends an extcmd packet.	1041	Register a callback for execution when the client sends an (synchronous)
		1042	extcmd packet. Ext commands will be processed in the order they are
		1043	received by the server, like other user commands. The first argument is
		1044	the logged-in player. Ext commands can only be processed after a player
		1045	has logged in successfully.
823		1046
824	If the callback returns something, it is sent back as if reply was being	1047	If the callback returns something, it is sent back as if reply was being
825	called.	1048	called.
826		1049
		1050	=item cf::register_exticmd $name => \&callback($ns,$packet);
		1051
		1052	Register a callback for execution when the client sends an (asynchronous)
		1053	exticmd packet. Exti commands are processed by the server as soon as they
		1054	are received, i.e. out of order w.r.t. other commands. The first argument
		1055	is a client socket. Exti commands can be received anytime, even before
		1056	log-in.
		1057
		1058	If the callback returns something, it is sent back as if reply was being
		1059	called.
		1060
827	=cut	1061	=cut
828		1062
829	sub register_extcmd {	1063	sub register_extcmd {
830	my ($name, $cb) = @_;	1064	my ($name, $cb) = @_;
831		1065
832	my $caller = caller;
833	#warn "registering extcmd '$name' to '$caller'";
834
835	$EXTCMD{$name} = [$cb, $caller];	1066	$EXTCMD{$name} = $cb;
		1067	}
		1068
		1069	sub register_exticmd {
		1070	my ($name, $cb) = @_;
		1071
		1072	$EXTICMD{$name} = $cb;
836	}	1073	}
837		1074
838	cf::player->attach (	1075	cf::player->attach (
839	on_command => sub {	1076	on_command => sub {
840	my ($pl, $name, $params) = @_;	1077	my ($pl, $name, $params) = @_;
…		…
849	cf::override;	1086	cf::override;
850	},	1087	},
851	on_extcmd => sub {	1088	on_extcmd => sub {
852	my ($pl, $buf) = @_;	1089	my ($pl, $buf) = @_;
853		1090
854	my $msg = eval { from_json $buf };	1091	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
855		1092
856	if (ref $msg) {	1093	if (ref $msg) {
857	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1094	if (my $cb = $EXTCMD{$msg->{msgtype}}) {
858	if (my %reply = $cb->[0]->($pl, $msg)) {	1095	if (my %reply = $cb->($pl, $msg)) {
859	$pl->ext_reply ($msg->{msgid}, %reply);	1096	$pl->ext_reply ($msg->{msgid}, %reply);
860	}	1097	}
861	}	1098	}
862	} else {	1099	} else {
863	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1100	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
…		…
865		1102
866	cf::override;	1103	cf::override;
867	},	1104	},
868	);	1105	);
869		1106
		1107	sub load_extensions {
		1108	cf::sync_job {
		1109	my %todo;
		1110
		1111	for my $path (<$LIBDIR/*.ext>) {
		1112	next unless -r $path;
		1113
		1114	$path =~ /([^\/\\]+)\.ext$/ or die "$path";
		1115	my $base = $1;
		1116	my $pkg = $1;
		1117	$pkg =~ s/[^[:word:]]/_/g;
		1118	$pkg = "ext::$pkg";
		1119
		1120	open my $fh, "<:utf8", $path
		1121	or die "$path: $!";
		1122
		1123	my $source = do { local $/; <$fh> };
		1124
		1125	my %ext = (
		1126	path => $path,
		1127	base => $base,
		1128	pkg => $pkg,
		1129	);
		1130
		1131	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
		1132	if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
		1133
		1134	$ext{source} =
		1135	"package $pkg; use strict; use utf8;\n"
		1136	. "#line 1 \"$path\"\n{\n"
		1137	. $source
		1138	. "\n};\n1";
		1139
		1140	$todo{$base} = \%ext;
		1141	}
		1142
		1143	my %done;
		1144	while (%todo) {
		1145	my $progress;
		1146
		1147	while (my ($k, $v) = each %todo) {
		1148	for (split /,\s*/, $v->{meta}{depends}) {
		1149	goto skip
		1150	unless exists $done{$_};
		1151	}
		1152
		1153	warn "... loading '$k' into '$v->{pkg}'\n";
		1154
		1155	unless (eval $v->{source}) {
		1156	my $msg = $@ ? "$v->{path}: $@\n"
		1157	: "$v->{base}: extension inactive.\n";
		1158
		1159	if (exists $v->{meta}{mandatory}) {
		1160	warn $msg;
		1161	warn "mandatory extension failed to load, exiting.\n";
		1162	exit 1;
		1163	}
		1164
		1165	warn $msg;
		1166	}
		1167
		1168	$done{$k} = delete $todo{$k};
		1169	push @EXTS, $v->{pkg};
		1170	$progress = 1;
		1171	}
		1172
		1173	skip:
		1174	die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
		1175	unless $progress;
		1176	}
		1177	};
		1178	}
		1179
		1180	#############################################################################
		1181
		1182	=back
		1183
		1184	=head2 CORE EXTENSIONS
		1185
		1186	Functions and methods that extend core crossfire objects.
		1187
		1188	=cut
		1189
		1190	package cf::player;
		1191
		1192	use Coro::AIO;
		1193
		1194	=head3 cf::player
		1195
		1196	=over 4
		1197
		1198	=item cf::player::find $login
		1199
		1200	Returns the given player object, loading it if necessary (might block).
		1201
		1202	=cut
		1203
		1204	sub playerdir($) {
		1205	"$PLAYERDIR/"
		1206	. (ref $_[0] ? $_[0]->ob->name : $_[0])
		1207	}
		1208
		1209	sub path($) {
		1210	my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
		1211
		1212	(playerdir $login) . "/playerdata"
		1213	}
		1214
		1215	sub find_active($) {
		1216	$cf::PLAYER{$_[0]}
		1217	and $cf::PLAYER{$_[0]}->active
		1218	and $cf::PLAYER{$_[0]}
		1219	}
		1220
		1221	sub exists($) {
		1222	my ($login) = @_;
		1223
		1224	$cf::PLAYER{$login}
		1225	or cf::sync_job { !aio_stat path $login }
		1226	}
		1227
		1228	sub find($) {
		1229	return $cf::PLAYER{$_[0]} || do {
		1230	my $login = $_[0];
		1231
		1232	my $guard = cf::lock_acquire "user_find:$login";
		1233
		1234	$cf::PLAYER{$_[0]} || do {
		1235	# rename old playerfiles to new ones
		1236	#TODO: remove when no longer required
		1237	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
		1238	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
		1239	aio_unlink +(playerdir $login) . "/$login.pl.pst";
		1240	aio_unlink +(playerdir $login) . "/$login.pl";
		1241
		1242	my $pl = load_pl path $login
		1243	or return;
		1244	$cf::PLAYER{$login} = $pl
		1245	}
		1246	}
		1247	}
		1248
		1249	sub save($) {
		1250	my ($pl) = @_;
		1251
		1252	return if $pl->{deny_save};
		1253
		1254	my $path = path $pl;
		1255	my $guard = cf::lock_acquire "user_save:$path";
		1256
		1257	return if $pl->{deny_save};
		1258
		1259	aio_mkdir playerdir $pl, 0770;
		1260	$pl->{last_save} = $cf::RUNTIME;
		1261
		1262	$pl->save_pl ($path);
		1263	Coro::cede;
		1264	}
		1265
		1266	sub new($) {
		1267	my ($login) = @_;
		1268
		1269	my $self = create;
		1270
		1271	$self->ob->name ($login);
		1272	$self->{deny_save} = 1;
		1273
		1274	$cf::PLAYER{$login} = $self;
		1275
		1276	$self
		1277	}
		1278
		1279	=item $pl->quit_character
		1280
		1281	Nukes the player without looking back. If logged in, the connection will
		1282	be destroyed. May block for a long time.
		1283
		1284	=cut
		1285
		1286	sub quit_character {
		1287	my ($pl) = @_;
		1288
		1289	my $name = $pl->ob->name;
		1290
		1291	$pl->{deny_save} = 1;
		1292	$pl->password ("*"); # this should lock out the player until we nuked the dir
		1293
		1294	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
		1295	$pl->deactivate;
		1296	$pl->invoke (cf::EVENT_PLAYER_QUIT);
		1297	$pl->ns->destroy if $pl->ns;
		1298
		1299	my $path = playerdir $pl;
		1300	my $temp = "$path~$cf::RUNTIME~deleting~";
		1301	aio_rename $path, $temp;
		1302	delete $cf::PLAYER{$pl->ob->name};
		1303	$pl->destroy;
		1304
		1305	my $prefix = qr<^~\Q$name\E/>;
		1306
		1307	# nuke player maps
		1308	$cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
		1309
		1310	IO::AIO::aio_rmtree $temp;
		1311	}
		1312
		1313	=item $pl->kick
		1314
		1315	Kicks a player out of the game. This destroys the connection.
		1316
		1317	=cut
		1318
		1319	sub kick {
		1320	my ($pl, $kicker) = @_;
		1321
		1322	$pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
		1323	$pl->killer ("kicked");
		1324	$pl->ns->destroy;
		1325	}
		1326
		1327	=item cf::player::list_logins
		1328
		1329	Returns am arrayref of all valid playernames in the system, can take a
		1330	while and may block, so not sync_job-capable, ever.
		1331
		1332	=cut
		1333
		1334	sub list_logins {
		1335	my $dirs = aio_readdir $PLAYERDIR
		1336	or return [];
		1337
		1338	my @logins;
		1339
		1340	for my $login (@$dirs) {
		1341	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
		1342	aio_read $fh, 0, 512, my $buf, 0 or next;
		1343	$buf !~ /^password -------------$/m or next; # official not-valid tag
		1344
		1345	utf8::decode $login;
		1346	push @logins, $login;
		1347	}
		1348
		1349	\@logins
		1350	}
		1351
		1352	=item $player->maps
		1353
		1354	Returns an arrayref of map paths that are private for this
		1355	player. May block.
		1356
		1357	=cut
		1358
		1359	sub maps($) {
		1360	my ($pl) = @_;
		1361
		1362	$pl = ref $pl ? $pl->ob->name : $pl;
		1363
		1364	my $files = aio_readdir playerdir $pl
		1365	or return;
		1366
		1367	my @paths;
		1368
		1369	for (@$files) {
		1370	utf8::decode $_;
		1371	next if /\.(?:pl|pst)$/;
		1372	next unless /^$PATH_SEP/o;
		1373
		1374	push @paths, cf::map::normalise "~$pl/$_";
		1375	}
		1376
		1377	\@paths
		1378	}
		1379
		1380	=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
		1381
		1382	Expand crossfire pod fragments into protocol xml.
		1383
		1384	=cut
		1385
		1386	sub expand_cfpod {
		1387	((my $self), (local $_)) = @_;
		1388
		1389	# escape & and <
		1390	s/&/&amp;/g;
		1391	s/(?<![BIUGH])</&lt;/g;
		1392
		1393	# this is buggy, it needs to properly take care of nested <'s
		1394
		1395	1 while
		1396	# replace B<>, I<>, U<> etc.
		1397	s/B<([^\>]*)>/<b>$1<\/b>/
		1398	|| s/I<([^\>]*)>/<i>$1<\/i>/
		1399	|| s/U<([^\>]*)>/<u>$1<\/u>/
		1400	# replace G<male|female> tags
		1401	|| s{G<([^>|]*)\|([^>]*)>}{
		1402	$self->gender ? $2 : $1
		1403	}ge
		1404	# replace H<hint text>
		1405	|| s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g;
		1406
		1407	# create single paragraphs (very hackish)
		1408	s/(?<=\S)\n(?=\w)/ /g;
		1409
		1410	$_
		1411	}
		1412
		1413	=item $player->ext_reply ($msgid, %msg)
		1414
		1415	Sends an ext reply to the player.
		1416
		1417	=cut
		1418
		1419	sub ext_reply($$%) {
		1420	my ($self, $id, %msg) = @_;
		1421
		1422	$msg{msgid} = $id;
		1423	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
		1424	}
		1425
		1426	=item $player->ext_event ($type, %msg)
		1427
		1428	Sends an ext event to the client.
		1429
		1430	=cut
		1431
		1432	sub ext_event($$%) {
		1433	my ($self, $type, %msg) = @_;
		1434
		1435	$self->ns->ext_event ($type, %msg);
		1436	}
		1437
		1438	=head3 cf::region
		1439
		1440	=over 4
		1441
		1442	=cut
		1443
		1444	package cf::region;
		1445
		1446	=item cf::region::find_by_path $path
		1447
		1448	Tries to decuce the likely region for a map knowing only its path.
		1449
		1450	=cut
		1451
		1452	sub find_by_path($) {
		1453	my ($path) = @_;
		1454
		1455	my ($match, $specificity);
		1456
		1457	for my $region (list) {
		1458	if ($region->match && $path =~ $region->match) {
		1459	($match, $specificity) = ($region, $region->specificity)
		1460	if $region->specificity > $specificity;
		1461	}
		1462	}
		1463
		1464	$match
		1465	}
		1466
		1467	=back
		1468
		1469	=head3 cf::map
		1470
		1471	=over 4
		1472
		1473	=cut
		1474
		1475	package cf::map;
		1476
		1477	use Fcntl;
		1478	use Coro::AIO;
		1479
		1480	use overload
		1481	'""' => \&as_string,
		1482	fallback => 1;
		1483
		1484	our $MAX_RESET = 3600;
		1485	our $DEFAULT_RESET = 3000;
		1486
		1487	sub generate_random_map {
		1488	my ($self, $rmp) = @_;
		1489	# mit "rum" bekleckern, nicht
		1490	$self->_create_random_map (
		1491	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
		1492	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
		1493	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
		1494	$rmp->{exit_on_final_map},
		1495	$rmp->{xsize}, $rmp->{ysize},
		1496	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
		1497	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
		1498	$rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
		1499	$rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
		1500	$rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
		1501	(cf::region::find $rmp->{region}), $rmp->{custom}
		1502	)
		1503	}
		1504
		1505	=item cf::map->register ($regex, $prio)
		1506
		1507	Register a handler for the map path matching the given regex at the
		1508	givne priority (higher is better, built-in handlers have priority 0, the
		1509	default).
		1510
		1511	=cut
		1512
870	sub register {	1513	sub register {
		1514	my (undef, $regex, $prio) = @_;
		1515	my $pkg = caller;
		1516
		1517	no strict;
		1518	push @{"$pkg\::ISA"}, __PACKAGE__;
		1519
		1520	$EXT_MAP{$pkg} = [$prio, qr<$regex>];
		1521	}
		1522
		1523	# also paths starting with '/'
		1524	$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
		1525
		1526	sub thawer_merge {
871	my ($base, $pkg) = @_;	1527	my ($self, $merge) = @_;
872		1528
873	#TODO	1529	# we have to keep some variables in memory intact
874	}	1530	local $self->{path};
		1531	local $self->{load_path};
875		1532
876	sub load_extension {	1533	$self->SUPER::thawer_merge ($merge);
		1534	}
		1535
		1536	sub normalise {
877	my ($path) = @_;	1537	my ($path, $base) = @_;
878		1538
879	$path =~ /([^\/\\]+)\.ext$/ or die "$path";	1539	$path = "$path"; # make sure its a string
880	my $base = $1;
881	my $pkg = $1;
882	$pkg =~ s/[^[:word:]]/_/g;
883	$pkg = "ext::$pkg";
884		1540
885	warn "loading '$path' into '$pkg'\n";	1541	$path =~ s/\.map$//;
886		1542
887	open my $fh, "<:utf8", $path	1543	# map plan:
888	or die "$path: $!";	1544	#
		1545	# /! non-realised random map exit (special hack!)
		1546	# {... are special paths that are not being touched
		1547	# ?xxx/... are special absolute paths
		1548	# ?random/... random maps
		1549	# /... normal maps
		1550	# ~user/... per-player map of a specific user
889		1551
890	my $source =	1552	$path =~ s/$PATH_SEP/\//go;
891	"package $pkg; use strict; use utf8;\n"
892	. "#line 1 \"$path\"\n{\n"
893	. (do { local $/; <$fh> })
894	. "\n};\n1";
895		1553
896	eval $source	1554	# treat it as relative path if it starts with
897	or die $@ ? "$path: $@\n"	1555	# something that looks reasonable
898	: "extension disabled.\n";	1556	if ($path =~ m{^(?:\./|\.\./|\w)}) {
		1557	$base or Carp::carp "normalise called with relative path and no base: '$path'";
899		1558
900	push @exts, $pkg;	1559	$base =~ s{[^/]+/?$}{};
901	$ext_pkg{$base} = $pkg;	1560	$path = "$base/$path";
902
903	# no strict 'refs';
904	# @{"$pkg\::ISA"} = ext::;
905
906	register $base, $pkg;
907	}
908
909	sub unload_extension {
910	my ($pkg) = @_;
911
912	warn "removing extension $pkg\n";
913
914	# remove hooks
915	#TODO
916	# for my $idx (0 .. $#PLUGIN_EVENT) {
917	# delete $hook[$idx]{$pkg};
918	# }	1561	}
919		1562
920	# remove commands	1563	for ($path) {
921	for my $name (keys %COMMAND) {	1564	redo if s{//}{/};
922	my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };	1565	redo if s{/\.?/}{/};
		1566	redo if s{/[^/]+/\.\./}{/};
		1567	}
923		1568
924	if (@cb) {	1569	$path
925	$COMMAND{$name} = \@cb;	1570	}
		1571
		1572	sub new_from_path {
		1573	my (undef, $path, $base) = @_;
		1574
		1575	return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
		1576
		1577	$path = normalise $path, $base;
		1578
		1579	for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
		1580	if ($path =~ $EXT_MAP{$pkg}[1]) {
		1581	my $self = bless cf::map::new, $pkg;
		1582	$self->{path} = $path; $self->path ($path);
		1583	$self->init; # pass $1 etc.
		1584	return $self;
		1585	}
		1586	}
		1587
		1588	Carp::carp "unable to resolve path '$path' (base '$base').";
		1589	()
		1590	}
		1591
		1592	sub init {
		1593	my ($self) = @_;
		1594
		1595	$self
		1596	}
		1597
		1598	sub as_string {
		1599	my ($self) = @_;
		1600
		1601	"$self->{path}"
		1602	}
		1603
		1604	# the displayed name, this is a one way mapping
		1605	sub visible_name {
		1606	&as_string
		1607	}
		1608
		1609	# the original (read-only) location
		1610	sub load_path {
		1611	my ($self) = @_;
		1612
		1613	"$MAPDIR/$self->{path}.map"
		1614	}
		1615
		1616	# the temporary/swap location
		1617	sub save_path {
		1618	my ($self) = @_;
		1619
		1620	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
		1621	"$TMPDIR/$path.map"
		1622	}
		1623
		1624	# the unique path, undef == no special unique path
		1625	sub uniq_path {
		1626	my ($self) = @_;
		1627
		1628	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
		1629	"$UNIQUEDIR/$path"
		1630	}
		1631
		1632	# and all this just because we cannot iterate over
		1633	# all maps in C++...
		1634	sub change_all_map_light {
		1635	my ($change) = @_;
		1636
		1637	$_->change_map_light ($change)
		1638	for grep $_->outdoor, values %cf::MAP;
		1639	}
		1640
		1641	sub decay_objects {
		1642	my ($self) = @_;
		1643
		1644	return if $self->{deny_reset};
		1645
		1646	$self->do_decay_objects;
		1647	}
		1648
		1649	sub unlink_save {
		1650	my ($self) = @_;
		1651
		1652	utf8::encode (my $save = $self->save_path);
		1653	IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
		1654	IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
		1655	}
		1656
		1657	sub load_header_from($) {
		1658	my ($self, $path) = @_;
		1659
		1660	utf8::encode $path;
		1661	#aio_open $path, O_RDONLY, 0
		1662	# or return;
		1663
		1664	$self->_load_header ($path)
		1665	or return;
		1666
		1667	$self->{load_path} = $path;
		1668
		1669	1
		1670	}
		1671
		1672	sub load_header_orig {
		1673	my ($self) = @_;
		1674
		1675	$self->load_header_from ($self->load_path)
		1676	}
		1677
		1678	sub load_header_temp {
		1679	my ($self) = @_;
		1680
		1681	$self->load_header_from ($self->save_path)
		1682	}
		1683
		1684	sub prepare_temp {
		1685	my ($self) = @_;
		1686
		1687	$self->last_access ((delete $self->{last_access})
		1688	|| $cf::RUNTIME); #d#
		1689	# safety
		1690	$self->{instantiate_time} = $cf::RUNTIME
		1691	if $self->{instantiate_time} > $cf::RUNTIME;
		1692	}
		1693
		1694	sub prepare_orig {
		1695	my ($self) = @_;
		1696
		1697	$self->{load_original} = 1;
		1698	$self->{instantiate_time} = $cf::RUNTIME;
		1699	$self->last_access ($cf::RUNTIME);
		1700	$self->instantiate;
		1701	}
		1702
		1703	sub load_header {
		1704	my ($self) = @_;
		1705
		1706	if ($self->load_header_temp) {
		1707	$self->prepare_temp;
926	} else {	1708	} else {
927	delete $COMMAND{$name};	1709	$self->load_header_orig
928	}	1710	or return;
		1711	$self->prepare_orig;
		1712	}
		1713
		1714	$self->{deny_reset} = 1
		1715	if $self->no_reset;
		1716
		1717	$self->default_region (cf::region::find_by_path $self->{path})
		1718	unless $self->default_region;
		1719
929	}	1720	1
		1721	}
930		1722
931	# remove extcmds	1723	sub find;
932	for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {	1724	sub find {
933	delete $EXTCMD{$name};	1725	my ($path, $origin) = @_;
		1726
		1727	$path = normalise $path, $origin && $origin->path;
		1728
		1729	cf::lock_wait "map_find:$path";
		1730
		1731	$cf::MAP{$path} || do {
		1732	my $guard = cf::lock_acquire "map_find:$path";
		1733	my $map = new_from_path cf::map $path
		1734	or return;
		1735
		1736	$map->{last_save} = $cf::RUNTIME;
		1737
		1738	$map->load_header
		1739	or return;
		1740
		1741	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
		1742	# doing this can freeze the server in a sync job, obviously
		1743	#$cf::WAIT_FOR_TICK->wait;
		1744	$map->reset;
		1745	undef $guard;
		1746	return find $path;
		1747	}
		1748
		1749	$cf::MAP{$path} = $map
		1750	}
		1751	}
		1752
		1753	sub pre_load { }
		1754	sub post_load { }
		1755
		1756	sub load {
		1757	my ($self) = @_;
		1758
		1759	local $self->{deny_reset} = 1; # loading can take a long time
		1760
		1761	my $path = $self->{path};
		1762
934	}	1763	{
		1764	my $guard = cf::lock_acquire "map_load:$path";
935		1765
936	if (my $cb = $pkg->can ("unload")) {	1766	return if $self->in_memory != cf::MAP_SWAPPED;
937	eval {	1767
938	$cb->($pkg);	1768	$self->in_memory (cf::MAP_LOADING);
		1769
		1770	$self->alloc;
		1771
		1772	$self->pre_load;
		1773	Coro::cede;
		1774
		1775	$self->_load_objects ($self->{load_path}, 1)
		1776	or return;
		1777
		1778	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
		1779	if delete $self->{load_original};
		1780
		1781	if (my $uniq = $self->uniq_path) {
		1782	utf8::encode $uniq;
		1783	if (aio_open $uniq, O_RDONLY, 0) {
		1784	$self->clear_unique_items;
		1785	$self->_load_objects ($uniq, 0);
939	1	1786	}
940	} or warn "$pkg unloaded, but with errors: $@";	1787	}
941	}
942		1788
943	Symbol::delete_package $pkg;	1789	Coro::cede;
944	}	1790	# now do the right thing for maps
		1791	$self->link_multipart_objects;
		1792	$self->difficulty ($self->estimate_difficulty)
		1793	unless $self->difficulty;
		1794	Coro::cede;
945		1795
946	sub load_extensions {	1796	unless ($self->{deny_activate}) {
947	for my $ext (<$LIBDIR/*.ext>) {	1797	$self->decay_objects;
948	next unless -r $ext;	1798	$self->fix_auto_apply;
949	eval {	1799	$self->update_buttons;
950	load_extension $ext;	1800	Coro::cede;
951	1	1801	$self->set_darkness_map;
952	} or warn "$ext not loaded: $@";	1802	Coro::cede;
953	}	1803	$self->activate;
954	}	1804	}
955		1805
956	#############################################################################	1806	$self->in_memory (cf::MAP_IN_MEMORY);
957	# load/save/clean perl data associated with a map	1807	}
958		1808
959	*cf::mapsupport::on_clean = sub {	1809	$self->post_load;
		1810	}
		1811
		1812	sub customise_for {
		1813	my ($self, $ob) = @_;
		1814
		1815	return find "~" . $ob->name . "/" . $self->{path}
		1816	if $self->per_player;
		1817
		1818	# return find "?party/" . $ob->name . "/" . $self->{path}
		1819	# if $self->per_party;
		1820
		1821	$self
		1822	}
		1823
		1824	# find and load all maps in the 3x3 area around a map
		1825	sub load_diag {
960	my ($map) = @_;	1826	my ($map) = @_;
961		1827
962	my $path = $map->tmpname;	1828	my @diag; # diagonal neighbours
963	defined $path or return;
964		1829
965	unlink "$path.pst";	1830	for (0 .. 3) {
966	};	1831	my $neigh = $map->tile_path ($_)
		1832	or next;
		1833	$neigh = find $neigh, $map
		1834	or next;
		1835	$neigh->load;
967		1836
968	cf::map->attach (prio => -10000, package => cf::mapsupport::);	1837	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
		1838	[$neigh->tile_path (($_ + 1) % 4), $neigh];
		1839	}
969		1840
970	#############################################################################	1841	for (@diag) {
971	# load/save perl data associated with player->ob objects	1842	my $neigh = find @$_
972		1843	or next;
973	sub all_objects(@) {	1844	$neigh->load;
974	@_, map all_objects ($_->inv), @_	1845	}
975	}	1846	}
976		1847
977	# TODO: compatibility cruft, remove when no longer needed	1848	sub find_sync {
978	cf::player->attach (	1849	my ($path, $origin) = @_;
979	on_load => sub {
980	my ($pl, $path) = @_;
981		1850
982	for my $o (all_objects $pl->ob) {	1851	cf::sync_job { find $path, $origin }
983	if (my $value = $o->get_ob_key_value ("_perl_data")) {	1852	}
984	$o->set_ob_key_value ("_perl_data");
985		1853
986	%$o = %{ Storable::thaw pack "H*", $value };	1854	sub do_load_sync {
		1855	my ($map) = @_;
		1856
		1857	cf::sync_job { $map->load };
		1858	}
		1859
		1860	our %MAP_PREFETCH;
		1861	our $MAP_PREFETCHER = undef;
		1862
		1863	sub find_async {
		1864	my ($path, $origin) = @_;
		1865
		1866	$path = normalise $path, $origin && $origin->{path};
		1867
		1868	if (my $map = $cf::MAP{$path}) {
		1869	return $map if $map->in_memory == cf::MAP_IN_MEMORY;
		1870	}
		1871
		1872	undef $MAP_PREFETCH{$path};
		1873	$MAP_PREFETCHER ||= cf::async {
		1874	while (%MAP_PREFETCH) {
		1875	for my $path (keys %MAP_PREFETCH) {
		1876	my $map = find $path
		1877	or next;
		1878	$map->load;
		1879
		1880	delete $MAP_PREFETCH{$path};
987	}	1881	}
988	}	1882	}
		1883	undef $MAP_PREFETCHER;
		1884	};
		1885	$MAP_PREFETCHER->prio (6);
		1886
		1887	()
		1888	}
		1889
		1890	sub save {
		1891	my ($self) = @_;
		1892
		1893	my $lock = cf::lock_acquire "map_data:" . $self->path;
		1894
		1895	$self->{last_save} = $cf::RUNTIME;
		1896
		1897	return unless $self->dirty;
		1898
		1899	my $save = $self->save_path; utf8::encode $save;
		1900	my $uniq = $self->uniq_path; utf8::encode $uniq;
		1901
		1902	$self->{load_path} = $save;
		1903
		1904	return if $self->{deny_save};
		1905
		1906	local $self->{last_access} = $self->last_access;#d#
		1907
		1908	cf::async {
		1909	$_->contr->save for $self->players;
		1910	};
		1911
		1912	if ($uniq) {
		1913	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
		1914	$self->_save_objects ($uniq, cf::IO_UNIQUES);
		1915	} else {
		1916	$self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
989	},	1917	}
990	);	1918	}
991		1919
992	#############################################################################	1920	sub swap_out {
		1921	my ($self) = @_;
993		1922
994	=head2 CORE EXTENSIONS	1923	# save first because save cedes
		1924	$self->save;
995		1925
996	Functions and methods that extend core crossfire objects.	1926	my $lock = cf::lock_acquire "map_data:" . $self->path;
997		1927
998	=head3 cf::player	1928	return if $self->players;
		1929	return if $self->in_memory != cf::MAP_IN_MEMORY;
		1930	return if $self->{deny_save};
		1931
		1932	$self->clear;
		1933	$self->in_memory (cf::MAP_SWAPPED);
		1934	}
		1935
		1936	sub reset_at {
		1937	my ($self) = @_;
		1938
		1939	# TODO: safety, remove and allow resettable per-player maps
		1940	return 1e99 if $self->{deny_reset};
		1941
		1942	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
		1943	my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
		1944
		1945	$time + $to
		1946	}
		1947
		1948	sub should_reset {
		1949	my ($self) = @_;
		1950
		1951	$self->reset_at <= $cf::RUNTIME
		1952	}
		1953
		1954	sub reset {
		1955	my ($self) = @_;
		1956
		1957	my $lock = cf::lock_acquire "map_data:$self->{path}";
		1958
		1959	return if $self->players;
		1960
		1961	warn "resetting map ", $self->path;
		1962
		1963	$self->in_memory (cf::MAP_SWAPPED);
		1964
		1965	# need to save uniques path
		1966	unless ($self->{deny_save}) {
		1967	my $uniq = $self->uniq_path; utf8::encode $uniq;
		1968
		1969	$self->_save_objects ($uniq, cf::IO_UNIQUES)
		1970	if $uniq;
		1971	}
		1972
		1973	delete $cf::MAP{$self->path};
		1974
		1975	$self->clear;
		1976
		1977	$_->clear_links_to ($self) for values %cf::MAP;
		1978
		1979	$self->unlink_save;
		1980	$self->destroy;
		1981	}
		1982
		1983	my $nuke_counter = "aaaa";
		1984
		1985	sub nuke {
		1986	my ($self) = @_;
		1987
		1988	delete $cf::MAP{$self->path};
		1989
		1990	$self->unlink_save;
		1991
		1992	bless $self, "cf::map";
		1993	delete $self->{deny_reset};
		1994	$self->{deny_save} = 1;
		1995	$self->reset_timeout (1);
		1996	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
		1997
		1998	$cf::MAP{$self->path} = $self;
		1999
		2000	$self->reset; # polite request, might not happen
		2001	}
		2002
		2003	=item $maps = cf::map::tmp_maps
		2004
		2005	Returns an arrayref with all map paths of currently instantiated and saved
		2006	maps. May block.
		2007
		2008	=cut
		2009
		2010	sub tmp_maps() {
		2011	[
		2012	map {
		2013	utf8::decode $_;
		2014	/\.map$/
		2015	? normalise $_
		2016	: ()
		2017	} @{ aio_readdir $TMPDIR or [] }
		2018	]
		2019	}
		2020
		2021	=item $maps = cf::map::random_maps
		2022
		2023	Returns an arrayref with all map paths of currently instantiated and saved
		2024	random maps. May block.
		2025
		2026	=cut
		2027
		2028	sub random_maps() {
		2029	[
		2030	map {
		2031	utf8::decode $_;
		2032	/\.map$/
		2033	? normalise "?random/$_"
		2034	: ()
		2035	} @{ aio_readdir $RANDOMDIR or [] }
		2036	]
		2037	}
		2038
		2039	=item cf::map::unique_maps
		2040
		2041	Returns an arrayref of paths of all shared maps that have
		2042	instantiated unique items. May block.
		2043
		2044	=cut
		2045
		2046	sub unique_maps() {
		2047	[
		2048	map {
		2049	utf8::decode $_;
		2050	/\.map$/
		2051	? normalise $_
		2052	: ()
		2053	} @{ aio_readdir $UNIQUEDIR or [] }
		2054	]
		2055	}
		2056
		2057	package cf;
		2058
		2059	=back
		2060
		2061	=head3 cf::object
		2062
		2063	=cut
		2064
		2065	package cf::object;
999		2066
1000	=over 4	2067	=over 4
1001		2068
1002	=item cf::player::exists $login	2069	=item $ob->inv_recursive
1003		2070
1004	Returns true when the given account exists.	2071	Returns the inventory of the object _and_ their inventories, recursively.
1005		2072
1006	=cut	2073	=cut
1007		2074
1008	sub cf::player::exists($) {	2075	sub inv_recursive_;
1009	cf::player::find $_[0]	2076	sub inv_recursive_ {
1010	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;	2077	map { $_, inv_recursive_ $_->inv } @_
1011	}	2078	}
1012		2079
1013	=item $player->ext_reply ($msgid, $msgtype, %msg)	2080	sub inv_recursive {
1014		2081	inv_recursive_ inv $_[0]
1015	Sends an ext reply to the player.
1016
1017	=cut
1018
1019	sub cf::player::ext_reply($$$%) {
1020	my ($self, $id, %msg) = @_;
1021
1022	$msg{msgid} = $id;
1023
1024	$self->send ("ext " . to_json \%msg);
1025	}	2082	}
		2083
		2084	package cf;
1026		2085
1027	=back	2086	=back
1028		2087
1029	=head3 cf::object::player	2088	=head3 cf::object::player
1030		2089
…		…
1046		2105
1047	$flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;	2106	$flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1048		2107
1049	if ($self->{record_replies}) {	2108	if ($self->{record_replies}) {
1050	push @{ $self->{record_replies} }, [$npc, $msg, $flags];	2109	push @{ $self->{record_replies} }, [$npc, $msg, $flags];
		2110
1051	} else {	2111	} else {
		2112	my $pl = $self->contr;
		2113
		2114	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
		2115	my $diag = $pl->{npc_dialog};
		2116	$diag->{pl}->ext_reply (
		2117	$diag->{id},
		2118	msgtype => "reply",
		2119	msg => $diag->{pl}->expand_cfpod ($msg),
		2120	add_topics => []
		2121	);
		2122
		2123	} else {
1052	$msg = $npc->name . " says: $msg" if $npc;	2124	$msg = $npc->name . " says: $msg" if $npc;
1053	$self->message ($msg, $flags);	2125	$self->message ($msg, $flags);
		2126	}
1054	}	2127	}
1055	}	2128	}
1056		2129
1057	=item $player_object->may ("access")	2130	=item $player_object->may ("access")
1058		2131
…		…
1068	(ref $cf::CFG{"may_$access"}	2141	(ref $cf::CFG{"may_$access"}
1069	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}	2142	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
1070	: $cf::CFG{"may_$access"})	2143	: $cf::CFG{"may_$access"})
1071	}	2144	}
1072		2145
		2146	=item $player_object->enter_link
		2147
		2148	Freezes the player and moves him/her to a special map (C<{link}>).
		2149
		2150	The player should be reasonably safe there for short amounts of time. You
		2151	I<MUST> call C<leave_link> as soon as possible, though.
		2152
		2153	Will never block.
		2154
		2155	=item $player_object->leave_link ($map, $x, $y)
		2156
		2157	Moves the player out of the special C<{link}> map onto the specified
		2158	map. If the map is not valid (or omitted), the player will be moved back
		2159	to the location he/she was before the call to C<enter_link>, or, if that
		2160	fails, to the emergency map position.
		2161
		2162	Might block.
		2163
		2164	=cut
		2165
		2166	sub link_map {
		2167	unless ($LINK_MAP) {
		2168	$LINK_MAP = cf::map::find "{link}"
		2169	or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
		2170	$LINK_MAP->load;
		2171	}
		2172
		2173	$LINK_MAP
		2174	}
		2175
		2176	sub cf::object::player::enter_link {
		2177	my ($self) = @_;
		2178
		2179	$self->deactivate_recursive;
		2180
		2181	return if UNIVERSAL::isa $self->map, "ext::map_link";
		2182
		2183	$self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
		2184	if $self->map && $self->map->{path} ne "{link}";
		2185
		2186	$self->enter_map ($LINK_MAP || link_map, 10, 10);
		2187	}
		2188
		2189	sub cf::object::player::leave_link {
		2190	my ($self, $map, $x, $y) = @_;
		2191
		2192	return unless $self->contr->active;
		2193
		2194	my $link_pos = delete $self->{_link_pos};
		2195
		2196	unless ($map) {
		2197	# restore original map position
		2198	($map, $x, $y) = @{ $link_pos || [] };
		2199	$map = cf::map::find $map;
		2200
		2201	unless ($map) {
		2202	($map, $x, $y) = @$EMERGENCY_POSITION;
		2203	$map = cf::map::find $map
		2204	or die "FATAL: cannot load emergency map\n";
		2205	}
		2206	}
		2207
		2208	($x, $y) = (-1, -1)
		2209	unless (defined $x) && (defined $y);
		2210
		2211	# use -1 or undef as default coordinates, not 0, 0
		2212	($x, $y) = ($map->enter_x, $map->enter_y)
		2213	if $x <=0 && $y <= 0;
		2214
		2215	$map->load;
		2216	$map->load_diag;
		2217
		2218	return unless $self->contr->active;
		2219	$self->activate_recursive;
		2220
		2221	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
		2222	$self->enter_map ($map, $x, $y);
		2223	}
		2224
		2225	=item $player_object->goto ($path, $x, $y[, $check->($map)])
		2226
		2227	Moves the player to the given map-path and coordinates by first freezing
		2228	her, loading and preparing them map, calling the provided $check callback
		2229	that has to return the map if sucecssful, and then unfreezes the player on
		2230	the new (success) or old (failed) map position.
		2231
		2232	=cut
		2233
		2234	our $GOTOGEN;
		2235
		2236	sub cf::object::player::goto {
		2237	my ($self, $path, $x, $y, $check) = @_;
		2238
		2239	# do generation counting so two concurrent goto's will be executed in-order
		2240	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
		2241
		2242	$self->enter_link;
		2243
		2244	(async {
		2245	my $map = eval {
		2246	my $map = cf::map::find $path;
		2247
		2248	if ($map) {
		2249	$map = $map->customise_for ($self);
		2250	$map = $check->($map) if $check && $map;
		2251	} else {
		2252	$self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
		2253	}
		2254
		2255	$map
		2256	};
		2257
		2258	if ($@) {
		2259	$self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
		2260	LOG llevError | logBacktrace, Carp::longmess $@;
		2261	}
		2262
		2263	if ($gen == $self->{_goto_generation}) {
		2264	delete $self->{_goto_generation};
		2265	$self->leave_link ($map, $x, $y);
		2266	}
		2267	})->prio (1);
		2268	}
		2269
		2270	=item $player_object->enter_exit ($exit_object)
		2271
		2272	=cut
		2273
		2274	sub parse_random_map_params {
		2275	my ($spec) = @_;
		2276
		2277	my $rmp = { # defaults
		2278	xsize => (cf::rndm 15, 40),
		2279	ysize => (cf::rndm 15, 40),
		2280	symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
		2281	#layout => string,
		2282	};
		2283
		2284	for (split /\n/, $spec) {
		2285	my ($k, $v) = split /\s+/, $_, 2;
		2286
		2287	$rmp->{lc $k} = $v if (length $k) && (length $v);
		2288	}
		2289
		2290	$rmp
		2291	}
		2292
		2293	sub prepare_random_map {
		2294	my ($exit) = @_;
		2295
		2296	my $guard = cf::lock_acquire "exit_prepare:$exit";
		2297
		2298	# all this does is basically replace the /! path by
		2299	# a new random map path (?random/...) with a seed
		2300	# that depends on the exit object
		2301
		2302	my $rmp = parse_random_map_params $exit->msg;
		2303
		2304	if ($exit->map) {
		2305	$rmp->{region} = $exit->region->name;
		2306	$rmp->{origin_map} = $exit->map->path;
		2307	$rmp->{origin_x} = $exit->x;
		2308	$rmp->{origin_y} = $exit->y;
		2309	}
		2310
		2311	$rmp->{random_seed} ||= $exit->random_seed;
		2312
		2313	my $data = cf::to_json $rmp;
		2314	my $md5 = Digest::MD5::md5_hex $data;
		2315	my $meta = "$RANDOMDIR/$md5.meta";
		2316
		2317	if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
		2318	aio_write $fh, 0, (length $data), $data, 0;
		2319	undef $fh;
		2320	aio_rename "$meta~", $meta;
		2321
		2322	$exit->slaying ("?random/$md5");
		2323	$exit->msg (undef);
		2324	}
		2325	}
		2326
		2327	sub cf::object::player::enter_exit {
		2328	my ($self, $exit) = @_;
		2329
		2330	return unless $self->type == cf::PLAYER;
		2331
		2332	if ($exit->slaying eq "/!") {
		2333	#TODO: this should de-fi-ni-te-ly not be a sync-job
		2334	# the problem is that $exit might not survive long enough
		2335	# so it needs to be done right now, right here
		2336	cf::sync_job { prepare_random_map $exit };
		2337	}
		2338
		2339	my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
		2340	my $hp = $exit->stats->hp;
		2341	my $sp = $exit->stats->sp;
		2342
		2343	$self->enter_link;
		2344
		2345	(async {
		2346	$self->deactivate_recursive; # just to be sure
		2347	unless (eval {
		2348	$self->goto ($slaying, $hp, $sp);
		2349
		2350	1;
		2351	}) {
		2352	$self->message ("Something went wrong deep within the crossfire server. "
		2353	. "I'll try to bring you back to the map you were before. "
		2354	. "Please report this to the dungeon master!",
		2355	cf::NDI_UNIQUE | cf::NDI_RED);
		2356
		2357	warn "ERROR in enter_exit: $@";
		2358	$self->leave_link;
		2359	}
		2360	})->prio (1);
		2361	}
		2362
1073	=head3 cf::client	2363	=head3 cf::client
1074		2364
1075	=over 4	2365	=over 4
1076		2366
1077	=item $client->send_drawinfo ($text, $flags)	2367	=item $client->send_drawinfo ($text, $flags)
…		…
1083		2373
1084	sub cf::client::send_drawinfo {	2374	sub cf::client::send_drawinfo {
1085	my ($self, $text, $flags) = @_;	2375	my ($self, $text, $flags) = @_;
1086		2376
1087	utf8::encode $text;	2377	utf8::encode $text;
1088	$self->send_packet (sprintf "drawinfo %d %s", $flags, $text);	2378	$self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1089	}	2379	}
1090		2380
		2381	=item $client->send_msg ($color, $type, $msg, [extra...])
		2382
		2383	Send a drawinfo or msg packet to the client, formatting the msg for the
		2384	client if neccessary. C<$type> should be a string identifying the type of
		2385	the message, with C<log> being the default. If C<$color> is negative, suppress
		2386	the message unless the client supports the msg packet.
		2387
		2388	=cut
		2389
		2390	sub cf::client::send_msg {
		2391	my ($self, $color, $type, $msg, @extra) = @_;
		2392
		2393	$msg = $self->pl->expand_cfpod ($msg);
		2394
		2395	if ($self->can_msg) {
		2396	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));
		2397	} else {
		2398	# replace some tags by gcfclient-compatible ones
		2399	for ($msg) {
		2400	1 while
		2401	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2402	|| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2403	|| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2404	|| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2405	|| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2406	}
		2407
		2408	if ($color >= 0) {
		2409	if (0 && $msg =~ /\[/) {
		2410	$self->send_packet ("drawextinfo $color 4 0 $msg")
		2411	} else {
		2412	$msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
		2413	$self->send_packet ("drawinfo $color $msg")
		2414	}
		2415	}
		2416	}
		2417	}
		2418
		2419	=item $client->ext_event ($type, %msg)
		2420
		2421	Sends an ext event to the client.
		2422
		2423	=cut
		2424
		2425	sub cf::client::ext_event($$%) {
		2426	my ($self, $type, %msg) = @_;
		2427
		2428	$msg{msgtype} = "event_$type";
		2429	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
		2430	}
1091		2431
1092	=item $success = $client->query ($flags, "text", \&cb)	2432	=item $success = $client->query ($flags, "text", \&cb)
1093		2433
1094	Queues a query to the client, calling the given callback with	2434	Queues a query to the client, calling the given callback with
1095	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,	2435	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1096	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.	2436	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1097		2437
1098	Queries can fail, so check the return code. Or don't, as queries will become	2438	Queries can fail, so check the return code. Or don't, as queries will
1099	reliable at some point in the future.	2439	become reliable at some point in the future.
1100		2440
1101	=cut	2441	=cut
1102		2442
1103	sub cf::client::query {	2443	sub cf::client::query {
1104	my ($self, $flags, $text, $cb) = @_;	2444	my ($self, $flags, $text, $cb) = @_;
…		…
1112	utf8::encode $text;	2452	utf8::encode $text;
1113	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];	2453	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1114		2454
1115	$self->send_packet ($self->{query_queue}[0][0])	2455	$self->send_packet ($self->{query_queue}[0][0])
1116	if @{ $self->{query_queue} } == 1;	2456	if @{ $self->{query_queue} } == 1;
		2457
		2458	1
1117	}	2459	}
1118		2460
1119	cf::client->attach (	2461	cf::client->attach (
		2462	on_connect => sub {
		2463	my ($ns) = @_;
		2464
		2465	$ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
		2466	},
1120	on_reply => sub {	2467	on_reply => sub {
1121	my ($ns, $msg) = @_;	2468	my ($ns, $msg) = @_;
1122		2469
1123	# this weird shuffling is so that direct followup queries	2470	# this weird shuffling is so that direct followup queries
1124	# get handled first	2471	# get handled first
1125	my $queue = delete $ns->{query_queue};	2472	my $queue = delete $ns->{query_queue}
		2473	or return; # be conservative, not sure how that can happen, but we saw a crash here
1126		2474
1127	(shift @$queue)->[1]->($msg);	2475	(shift @$queue)->[1]->($msg);
		2476	return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1128		2477
1129	push @{ $ns->{query_queue} }, @$queue;	2478	push @{ $ns->{query_queue} }, @$queue;
1130		2479
1131	if (@{ $ns->{query_queue} } == @$queue) {	2480	if (@{ $ns->{query_queue} } == @$queue) {
1132	if (@$queue) {	2481	if (@$queue) {
…		…
1134	} else {	2483	} else {
1135	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;	2484	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1136	}	2485	}
1137	}	2486	}
1138	},	2487	},
		2488	on_exticmd => sub {
		2489	my ($ns, $buf) = @_;
		2490
		2491	my $msg = eval { $ns->{json_coder}->decode ($buf) };
		2492
		2493	if (ref $msg) {
		2494	if (my $cb = $EXTICMD{$msg->{msgtype}}) {
		2495	if (my %reply = $cb->($ns, $msg)) {
		2496	$reply{msgid} = $msg->{msgid};
		2497	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
		2498	}
		2499	}
		2500	} else {
		2501	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
		2502	}
		2503
		2504	cf::override;
		2505	},
1139	);	2506	);
1140		2507
1141	=item $client->coro (\&cb)	2508	=item $client->async (\&cb)
1142		2509
1143	Create a new coroutine, running the specified callback. The coroutine will	2510	Create a new coroutine, running the specified callback. The coroutine will
1144	be automatically cancelled when the client gets destroyed (e.g. on logout,	2511	be automatically cancelled when the client gets destroyed (e.g. on logout,
1145	or loss of connection).	2512	or loss of connection).
1146		2513
1147	=cut	2514	=cut
1148		2515
1149	sub cf::client::coro {	2516	sub cf::client::async {
1150	my ($self, $cb) = @_;	2517	my ($self, $cb) = @_;
1151		2518
1152	my $coro; $coro = async {	2519	my $coro = &Coro::async ($cb);
1153	eval {
1154	$cb->();
1155	};
1156	warn $@ if $@;
1157	};
1158		2520
1159	$coro->on_destroy (sub {	2521	$coro->on_destroy (sub {
1160	delete $self->{_coro}{$coro+0};	2522	delete $self->{_coro}{$coro+0};
1161	});	2523	});
1162		2524
…		…
1195		2557
1196	# here we export the classes and methods available to script code	2558	# here we export the classes and methods available to script code
1197		2559
1198	=pod	2560	=pod
1199		2561
1200	The following fucntions and emthods are available within a safe environment:	2562	The following functions and methods are available within a safe environment:
1201		2563
1202	cf::object contr pay_amount pay_player map	2564	cf::object contr pay_amount pay_player map
1203	cf::object::player player	2565	cf::object::player player
1204	cf::player peaceful	2566	cf::player peaceful
1205	cf::map trigger	2567	cf::map trigger
…		…
1286	=back	2648	=back
1287		2649
1288	=cut	2650	=cut
1289		2651
1290	#############################################################################	2652	#############################################################################
		2653	# the server's init and main functions
1291		2654
1292	=head2 EXTENSION DATABASE SUPPORT	2655	sub load_facedata($) {
		2656	my ($path) = @_;
1293		2657
1294	Crossfire maintains a very simple database for extension use. It can	2658	warn "loading facedata from $path\n";
1295	currently store anything that can be serialised using Storable, which
1296	excludes objects.
1297		2659
1298	The parameter C<$family> should best start with the name of the extension	2660	my $facedata;
1299	using it, it should be unique.	2661	0 < aio_load $path, $facedata
		2662	or die "$path: $!";
1300		2663
1301	=over 4	2664	$facedata = Coro::Storable::thaw $facedata;
1302		2665
1303	=item $hashref = cf::db_get $family	2666	$facedata->{version} == 2
		2667	or cf::cleanup "$path: version mismatch, cannot proceed.";
1304		2668
1305	Return a hashref for use by the extension C<$family>, which can be
1306	modified. After modifications, you have to call C<cf::db_dirty> or
1307	C<cf::db_sync>.
1308
1309	=item $value = cf::db_get $family => $key
1310
1311	Returns a single value from the database
1312
1313	=item cf::db_put $family => $hashref
1314
1315	Stores the given family hashref into the database. Updates are delayed, if
1316	you want the data to be synced to disk immediately, use C<cf::db_sync>.
1317
1318	=item cf::db_put $family => $key => $value
1319
1320	Stores the given C<$value> in the family hash. Updates are delayed, if you
1321	want the data to be synced to disk immediately, use C<cf::db_sync>.
1322
1323	=item cf::db_dirty
1324
1325	Marks the database as dirty, to be updated at a later time.
1326
1327	=item cf::db_sync
1328
1329	Immediately write the database to disk I<if it is dirty>.
1330
1331	=cut
1332
1333	our $DB;
1334
1335	{
1336	my $path = cf::localdir . "/database.pst";
1337
1338	sub db_load() {
1339	warn "loading database $path\n";#d# remove later
1340	$DB = stat $path ? Storable::retrieve $path : { };
1341	}	2669	{
		2670	my $faces = $facedata->{faceinfo};
1342		2671
1343	my $pid;	2672	while (my ($face, $info) = each %$faces) {
1344		2673	my $idx = (cf::face::find $face) || cf::face::alloc $face;
1345	sub db_save() {	2674	cf::face::set $idx, $info->{visibility}, $info->{magicmap};
1346	warn "saving database $path\n";#d# remove later	2675	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
1347	waitpid $pid, 0 if $pid;	2676	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
1348	if (0 == ($pid = fork)) {	2677	Coro::cede;
1349	$DB->{_meta}{version} = 1;
1350	Storable::nstore $DB, "$path~";
1351	rename "$path~", $path;
1352	cf::_exit 0 if defined $pid;
1353	}
1354	}
1355
1356	my $dirty;
1357
1358	sub db_sync() {
1359	db_save if $dirty;
1360	undef $dirty;
1361	}
1362
1363	my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1364	db_sync;
1365	});
1366
1367	sub db_dirty() {
1368	$dirty = 1;
1369	$idle->start;
1370	}
1371
1372	sub db_get($;$) {
1373	@_ >= 2
1374	? $DB->{$_[0]}{$_[1]}
1375	: ($DB->{$_[0]} ||= { })
1376	}
1377
1378	sub db_put($$;$) {
1379	if (@_ >= 3) {
1380	$DB->{$_[0]}{$_[1]} = $_[2];
1381	} else {
1382	$DB->{$_[0]} = $_[1];
1383	}
1384	db_dirty;
1385	}
1386
1387	cf::global->attach (
1388	prio => 10000,
1389	on_cleanup => sub {
1390	db_sync;
1391	},	2678	}
1392	);
1393	}
1394		2679
1395	#############################################################################	2680	while (my ($face, $info) = each %$faces) {
1396	# the server's main()	2681	next unless $info->{smooth};
		2682	my $idx = cf::face::find $face
		2683	or next;
		2684	if (my $smooth = cf::face::find $info->{smooth}) {
		2685	cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
		2686	} else {
		2687	warn "smooth face '$info->{smooth}' not found for face '$face'";
		2688	}
		2689	Coro::cede;
		2690	}
		2691	}
		2692
		2693	{
		2694	my $anims = $facedata->{animinfo};
		2695
		2696	while (my ($anim, $info) = each %$anims) {
		2697	cf::anim::set $anim, $info->{frames}, $info->{facings};
		2698	Coro::cede;
		2699	}
		2700
		2701	cf::anim::invalidate_all; # d'oh
		2702	}
		2703
		2704	1
		2705	}
		2706
		2707	sub reload_regions {
		2708	load_resource_file "$MAPDIR/regions"
		2709	or die "unable to load regions file\n";
		2710	}
		2711
		2712	sub reload_facedata {
		2713	load_facedata "$DATADIR/facedata"
		2714	or die "unable to load facedata\n";
		2715	}
		2716
		2717	sub reload_archetypes {
		2718	load_resource_file "$DATADIR/archetypes"
		2719	or die "unable to load archetypes\n";
		2720	#d# NEED to laod twice to resolve forward references
		2721	# this really needs to be done in an extra post-pass
		2722	# (which needs to be synchronous, so solve it differently)
		2723	load_resource_file "$DATADIR/archetypes"
		2724	or die "unable to load archetypes\n";
		2725	}
		2726
		2727	sub reload_treasures {
		2728	load_resource_file "$DATADIR/treasures"
		2729	or die "unable to load treasurelists\n";
		2730	}
		2731
		2732	sub reload_resources {
		2733	warn "reloading resource files...\n";
		2734
		2735	reload_regions;
		2736	reload_facedata;
		2737	#reload_archetypes;#d#
		2738	reload_archetypes;
		2739	reload_treasures;
		2740
		2741	warn "finished reloading resource files\n";
		2742	}
		2743
		2744	sub init {
		2745	reload_resources;
		2746	}
1397		2747
1398	sub cfg_load {	2748	sub cfg_load {
1399	open my $fh, "<:utf8", cf::confdir . "/config"	2749	open my $fh, "<:utf8", "$CONFDIR/config"
1400	or return;	2750	or return;
1401		2751
1402	local $/;	2752	local $/;
1403	*CFG = YAML::Syck::Load <$fh>;	2753	*CFG = YAML::Syck::Load <$fh>;
		2754
		2755	$EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
		2756
		2757	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
		2758	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
		2759
		2760	if (exists $CFG{mlockall}) {
		2761	eval {
		2762	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
		2763	and die "WARNING: m(un)lockall failed: $!\n";
		2764	};
		2765	warn $@ if $@;
		2766	}
1404	}	2767	}
1405		2768
1406	sub main {	2769	sub main {
1407	# we must not ever block the main coroutine	2770	# we must not ever block the main coroutine
1408	local $Coro::idle = sub {	2771	local $Coro::idle = sub {
1409	Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#	2772	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1410	(Coro::unblock_sub {	2773	(async {
1411	Event::one_event;	2774	Event::one_event;
1412	})->();	2775	})->prio (Coro::PRIO_MAX);
1413	};	2776	};
1414		2777
1415	cfg_load;	2778	cfg_load;
1416	db_load;	2779	db_init;
1417	load_extensions;	2780	load_extensions;
		2781
		2782	$TICK_WATCHER->start;
1418	Event::loop;	2783	Event::loop;
1419	}	2784	}
1420		2785
1421	#############################################################################	2786	#############################################################################
1422	# initialisation	2787	# initialisation and cleanup
1423		2788
1424	sub perl_reload() {	2789	# install some emergency cleanup handlers
		2790	BEGIN {
		2791	for my $signal (qw(INT HUP TERM)) {
		2792	Event->signal (
		2793	reentrant => 0,
		2794	data => WF_AUTOCANCEL,
		2795	signal => $signal,
		2796	prio => 0,
		2797	cb => sub {
		2798	cf::cleanup "SIG$signal";
		2799	},
		2800	);
		2801	}
		2802	}
		2803
		2804	sub write_runtime {
		2805	my $runtime = "$LOCALDIR/runtime";
		2806
		2807	# first touch the runtime file to show we are still running:
		2808	# the fsync below can take a very very long time.
		2809
		2810	IO::AIO::aio_utime $runtime, undef, undef;
		2811
		2812	my $guard = cf::lock_acquire "write_runtime";
		2813
		2814	my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
		2815	or return;
		2816
		2817	my $value = $cf::RUNTIME + 90 + 10;
		2818	# 10 is the runtime save interval, for a monotonic clock
		2819	# 60 allows for the watchdog to kill the server.
		2820
		2821	(aio_write $fh, 0, (length $value), $value, 0) <= 0
		2822	and return;
		2823
		2824	# always fsync - this file is important
		2825	aio_fsync $fh
		2826	and return;
		2827
		2828	# touch it again to show we are up-to-date
		2829	aio_utime $fh, undef, undef;
		2830
		2831	close $fh
		2832	or return;
		2833
		2834	aio_rename "$runtime~", $runtime
		2835	and return;
		2836
		2837	warn "runtime file written.\n";
		2838
		2839	1
		2840	}
		2841
		2842	sub emergency_save() {
		2843	my $freeze_guard = cf::freeze_mainloop;
		2844
		2845	warn "enter emergency perl save\n";
		2846
		2847	cf::sync_job {
		2848	# use a peculiar iteration method to avoid tripping on perl
		2849	# refcount bugs in for. also avoids problems with players
		2850	# and maps saved/destroyed asynchronously.
		2851	warn "begin emergency player save\n";
		2852	for my $login (keys %cf::PLAYER) {
		2853	my $pl = $cf::PLAYER{$login} or next;
		2854	$pl->valid or next;
		2855	$pl->save;
		2856	}
		2857	warn "end emergency player save\n";
		2858
		2859	warn "begin emergency map save\n";
		2860	for my $path (keys %cf::MAP) {
		2861	my $map = $cf::MAP{$path} or next;
		2862	$map->valid or next;
		2863	$map->save;
		2864	}
		2865	warn "end emergency map save\n";
		2866
		2867	warn "begin emergency database checkpoint\n";
		2868	BDB::db_env_txn_checkpoint $DB_ENV;
		2869	warn "end emergency database checkpoint\n";
		2870	};
		2871
		2872	warn "leave emergency perl save\n";
		2873	}
		2874
		2875	sub post_cleanup {
		2876	my ($make_core) = @_;
		2877
		2878	warn Carp::longmess "post_cleanup backtrace"
		2879	if $make_core;
		2880	}
		2881
		2882	sub do_reload_perl() {
1425	# can/must only be called in main	2883	# can/must only be called in main
1426	if ($Coro::current != $Coro::main) {	2884	if ($Coro::current != $Coro::main) {
1427	warn "can only reload from main coroutine\n";	2885	warn "can only reload from main coroutine";
1428	return;	2886	return;
1429	}	2887	}
1430		2888
1431	warn "reloading...";	2889	warn "reloading...";
1432		2890
1433	local $FREEZE = 1;	2891	warn "entering sync_job";
		2892
		2893	cf::sync_job {
		2894	cf::write_runtime; # external watchdog should not bark
1434	cf::emergency_save;	2895	cf::emergency_save;
		2896	cf::write_runtime; # external watchdog should not bark
1435		2897
1436	eval {	2898	warn "syncing database to disk";
		2899	BDB::db_env_txn_checkpoint $DB_ENV;
		2900
1437	# if anything goes wrong in here, we should simply crash as we already saved	2901	# if anything goes wrong in here, we should simply crash as we already saved
1438		2902
1439	# cancel all watchers	2903	warn "cancelling all WF_AUTOCANCEL watchers";
1440	for (Event::all_watchers) {	2904	for (Event::all_watchers) {
1441	$_->cancel if $_->data & WF_AUTOCANCEL;	2905	$_->cancel if $_->data & WF_AUTOCANCEL;
1442	}	2906	}
1443		2907
		2908	warn "flushing outstanding aio requests";
		2909	for (;;) {
		2910	BDB::flush;
		2911	IO::AIO::flush;
		2912	Coro::cede;
		2913	last unless IO::AIO::nreqs || BDB::nreqs;
		2914	warn "iterate...";
		2915	}
		2916
		2917	++$RELOAD;
		2918
1444	# cancel all extension coros	2919	warn "cancelling all extension coros";
1445	$_->cancel for values %EXT_CORO;	2920	$_->cancel for values %EXT_CORO;
1446	%EXT_CORO = ();	2921	%EXT_CORO = ();
1447		2922
1448	# unload all extensions	2923	warn "removing commands";
1449	for (@exts) {	2924	%COMMAND = ();
		2925
		2926	warn "removing ext/exti commands";
		2927	%EXTCMD = ();
		2928	%EXTICMD = ();
		2929
		2930	warn "unloading/nuking all extensions";
		2931	for my $pkg (@EXTS) {
1450	warn "unloading <$_>";	2932	warn "... unloading $pkg";
1451	unload_extension $_;	2933
		2934	if (my $cb = $pkg->can ("unload")) {
		2935	eval {
		2936	$cb->($pkg);
		2937	1
		2938	} or warn "$pkg unloaded, but with errors: $@";
1452	}	2939	}
1453		2940
		2941	warn "... nuking $pkg";
		2942	Symbol::delete_package $pkg;
		2943	}
		2944
1454	# unload all modules loaded from $LIBDIR	2945	warn "unloading all perl modules loaded from $LIBDIR";
1455	while (my ($k, $v) = each %INC) {	2946	while (my ($k, $v) = each %INC) {
1456	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;	2947	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1457		2948
1458	warn "removing <$k>";	2949	warn "... unloading $k";
1459	delete $INC{$k};	2950	delete $INC{$k};
1460		2951
1461	$k =~ s/\.pm$//;	2952	$k =~ s/\.pm$//;
1462	$k =~ s/\//::/g;	2953	$k =~ s/\//::/g;
1463		2954
…		…
1466	}	2957	}
1467		2958
1468	Symbol::delete_package $k;	2959	Symbol::delete_package $k;
1469	}	2960	}
1470		2961
1471	# sync database to disk
1472	cf::db_sync;
1473	IO::AIO::flush;
1474
1475	# get rid of safe::, as good as possible	2962	warn "getting rid of safe::, as good as possible";
1476	Symbol::delete_package "safe::$_"	2963	Symbol::delete_package "safe::$_"
1477	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	2964	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1478		2965
1479	# remove register_script_function callbacks
1480	# TODO
1481
1482	# unload cf.pm "a bit"	2966	warn "unloading cf.pm \"a bit\"";
1483	delete $INC{"cf.pm"};	2967	delete $INC{"cf.pm"};
		2968	delete $INC{"cf/pod.pm"};
1484		2969
1485	# don't, removes xs symbols, too,	2970	# don't, removes xs symbols, too,
1486	# and global variables created in xs	2971	# and global variables created in xs
1487	#Symbol::delete_package __PACKAGE__;	2972	#Symbol::delete_package __PACKAGE__;
1488		2973
1489	# reload cf.pm	2974	warn "unload completed, starting to reload now";
		2975
1490	warn "reloading cf.pm";	2976	warn "reloading cf.pm";
1491	require cf;	2977	require cf;
1492	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	2978	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1493		2979
1494	# load config and database again	2980	warn "loading config and database again";
1495	cf::cfg_load;	2981	cf::cfg_load;
1496	cf::db_load;
1497		2982
1498	# load extensions
1499	warn "load extensions";	2983	warn "loading extensions";
1500	cf::load_extensions;	2984	cf::load_extensions;
1501		2985
1502	# reattach attachments to objects	2986	warn "reattaching attachments to objects/players";
1503	warn "reattach";	2987	_global_reattach; # objects, sockets
1504	_global_reattach;	2988	warn "reattaching attachments to maps";
1505	};	2989	reattach $_ for values %MAP;
		2990	warn "reattaching attachments to players";
		2991	reattach $_ for values %PLAYER;
1506		2992
1507	if ($@) {	2993	warn "leaving sync_job";
		2994
		2995	1
		2996	} or do {
1508	warn $@;	2997	warn $@;
1509	warn "error while reloading, exiting.";	2998	warn "error while reloading, exiting.";
1510	exit 1;	2999	exit 1;
1511	}	3000	};
1512		3001
1513	warn "reloaded successfully";	3002	warn "reloaded";
1514	};	3003	};
1515		3004
1516	#############################################################################	3005	our $RELOAD_WATCHER; # used only during reload
1517		3006
1518	unless ($LINK_MAP) {	3007	sub reload_perl() {
1519	$LINK_MAP = cf::map::new;	3008	# doing reload synchronously and two reloads happen back-to-back,
		3009	# coro crashes during coro_state_free->destroy here.
1520		3010
1521	$LINK_MAP->width (41);	3011	$RELOAD_WATCHER ||= Event->timer (
1522	$LINK_MAP->height (41);	3012	reentrant => 0,
1523	$LINK_MAP->alloc;	3013	after => 0,
1524	$LINK_MAP->path ("{link}");	3014	data => WF_AUTOCANCEL,
1525	$LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";	3015	cb => sub {
1526	$LINK_MAP->in_memory (MAP_IN_MEMORY);	3016	do_reload_perl;
		3017	undef $RELOAD_WATCHER;
		3018	},
		3019	);
1527	}	3020	}
1528		3021
1529	register "<global>", __PACKAGE__;
1530
1531	register_command "perl-reload" => sub {	3022	register_command "reload" => sub {
1532	my ($who, $arg) = @_;	3023	my ($who, $arg) = @_;
1533		3024
1534	if ($who->flag (FLAG_WIZ)) {	3025	if ($who->flag (FLAG_WIZ)) {
1535	$who->message ("start of reload.");
1536	perl_reload;
1537	$who->message ("end of reload.");	3026	$who->message ("reloading server.");
		3027	async { reload_perl };
1538	}	3028	}
1539	};	3029	};
1540		3030
1541	unshift @INC, $LIBDIR;	3031	unshift @INC, $LIBDIR;
1542		3032
		3033	my $bug_warning = 0;
		3034
		3035	our @WAIT_FOR_TICK;
		3036	our @WAIT_FOR_TICK_BEGIN;
		3037
		3038	sub wait_for_tick {
		3039	return unless $TICK_WATCHER->is_active;
		3040	return if $Coro::current == $Coro::main;
		3041
		3042	my $signal = new Coro::Signal;
		3043	push @WAIT_FOR_TICK, $signal;
		3044	$signal->wait;
		3045	}
		3046
		3047	sub wait_for_tick_begin {
		3048	return unless $TICK_WATCHER->is_active;
		3049	return if $Coro::current == $Coro::main;
		3050
		3051	my $signal = new Coro::Signal;
		3052	push @WAIT_FOR_TICK_BEGIN, $signal;
		3053	$signal->wait;
		3054	}
		3055
		3056	my $min = 1e6;#d#
		3057	my $avg = 10;
1543	$TICK_WATCHER = Event->timer (	3058	$TICK_WATCHER = Event->timer (
1544	reentrant => 0,	3059	reentrant => 0,
		3060	parked => 1,
1545	prio => 0,	3061	prio => 0,
1546	at => $NEXT_TICK || $TICK,	3062	at => $NEXT_TICK || $TICK,
1547	data => WF_AUTOCANCEL,	3063	data => WF_AUTOCANCEL,
1548	cb => sub {	3064	cb => sub {
1549	unless ($FREEZE) {	3065	if ($Coro::current != $Coro::main) {
		3066	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
		3067	unless ++$bug_warning > 10;
		3068	return;
		3069	}
		3070
		3071	$NOW = $tick_start = Event::time;
		3072
1550	cf::server_tick; # one server iteration	3073	cf::server_tick; # one server iteration
1551	$RUNTIME += $TICK;	3074
		3075	0 && sync_job {#d#
		3076	for(1..10) {
		3077	my $t = Event::time;
		3078	my $map = my $map = new_from_path cf::map "/tmp/x.map"
		3079	or die;
		3080
		3081	$map->width (50);
		3082	$map->height (50);
		3083	$map->alloc;
		3084	$map->_load_objects ("/tmp/x.map", 1);
		3085	my $t = Event::time - $t;
		3086
		3087	#next unless $t < 0.0013;#d#
		3088	if ($t < $min) {
		3089	$min = $t;
		3090	}
		3091	$avg = $avg * 0.99 + $t * 0.01;
		3092	}
		3093	warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
		3094	exit 0;
		3095	# 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
1552	}	3096	};
1553		3097
		3098	$RUNTIME += $TICK;
1554	$NEXT_TICK += $TICK;	3099	$NEXT_TICK += $TICK;
1555		3100
		3101	if ($NOW >= $NEXT_RUNTIME_WRITE) {
		3102	$NEXT_RUNTIME_WRITE = $NOW + 10;
		3103	Coro::async_pool {
		3104	write_runtime
		3105	or warn "ERROR: unable to write runtime file: $!";
		3106	};
		3107	}
		3108
		3109	# my $AFTER = Event::time;
		3110	# warn $AFTER - $NOW;#d#
		3111
		3112	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
		3113	$sig->send;
		3114	}
		3115	while (my $sig = shift @WAIT_FOR_TICK) {
		3116	$sig->send;
		3117	}
		3118
		3119	$NOW = Event::time;
		3120
1556	# if we are delayed by four ticks or more, skip them all	3121	# if we are delayed by four ticks or more, skip them all
1557	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;	3122	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1558		3123
1559	$TICK_WATCHER->at ($NEXT_TICK);	3124	$TICK_WATCHER->at ($NEXT_TICK);
1560	$TICK_WATCHER->start;	3125	$TICK_WATCHER->start;
		3126
		3127	$LOAD = ($NOW - $tick_start) / $TICK;
		3128	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
		3129
		3130	_post_tick;
		3131
		3132
1561	},	3133	},
1562	);	3134	);
1563		3135
		3136	{
1564	IO::AIO::max_poll_time $TICK * 0.2;	3137	BDB::max_poll_time $TICK * 0.1;
1565		3138	$BDB_POLL_WATCHER = Event->io (
1566	Event->io (	3139	reentrant => 0,
1567	fd => IO::AIO::poll_fileno,	3140	fd => BDB::poll_fileno,
1568	poll => 'r',	3141	poll => 'r',
1569	prio => 5,	3142	prio => 0,
1570	data => WF_AUTOCANCEL,
1571	cb => \&IO::AIO::poll_cb,
1572	);
1573
1574	Event->timer (
1575	data => WF_AUTOCANCEL,	3143	data => WF_AUTOCANCEL,
1576	after => 0,	3144	cb => \&BDB::poll_cb,
1577	interval => 10,	3145	);
1578	cb => sub {	3146	BDB::min_parallel 8;
1579	(Coro::unblock_sub {	3147
1580	write_runtime	3148	BDB::set_sync_prepare {
1581	or warn "ERROR: unable to write runtime file: $!";	3149	my $status;
		3150	my $current = $Coro::current;
		3151	(
		3152	sub {
		3153	$status = $!;
		3154	$current->ready; undef $current;
		3155	},
		3156	sub {
		3157	Coro::schedule while defined $current;
		3158	$! = $status;
		3159	},
		3160	)
		3161	};
		3162
		3163	unless ($DB_ENV) {
		3164	$DB_ENV = BDB::db_env_create;
		3165
		3166	cf::sync_job {
		3167	eval {
		3168	BDB::db_env_open
		3169	$DB_ENV,
		3170	$BDBDIR,
		3171	BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
		3172	| BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
		3173	0666;
		3174
		3175	cf::cleanup "db_env_open($BDBDIR): $!" if $!;
		3176
		3177	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
		3178	$DB_ENV->set_lk_detect;
		3179	};
		3180
		3181	cf::cleanup "db_env_open(db): $@" if $@;
1582	})->();	3182	};
1583	},	3183	}
1584	);	3184	}
		3185
		3186	{
		3187	IO::AIO::min_parallel 8;
		3188
		3189	undef $Coro::AIO::WATCHER;
		3190	IO::AIO::max_poll_time $TICK * 0.1;
		3191	$AIO_POLL_WATCHER = Event->io (
		3192	reentrant => 0,
		3193	data => WF_AUTOCANCEL,
		3194	fd => IO::AIO::poll_fileno,
		3195	poll => 'r',
		3196	prio => 6,
		3197	cb => \&IO::AIO::poll_cb,
		3198	);
		3199	}
		3200
		3201	my $_log_backtrace;
		3202
		3203	sub _log_backtrace {
		3204	my ($msg, @addr) = @_;
		3205
		3206	$msg =~ s/\n//;
		3207
		3208	# limit the # of concurrent backtraces
		3209	if ($_log_backtrace < 2) {
		3210	++$_log_backtrace;
		3211	async {
		3212	my @bt = fork_call {
		3213	@addr = map { sprintf "%x", $_ } @addr;
		3214	my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
		3215	open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
		3216	or die "addr2line: $!";
		3217
		3218	my @funcs;
		3219	my @res = <$fh>;
		3220	chomp for @res;
		3221	while (@res) {
		3222	my ($func, $line) = splice @res, 0, 2, ();
		3223	push @funcs, "[$func] $line";
		3224	}
		3225
		3226	@funcs
		3227	};
		3228
		3229	LOG llevInfo, "[ABT] $msg\n";
		3230	LOG llevInfo, "[ABT] $_\n" for @bt;
		3231	--$_log_backtrace;
		3232	};
		3233	} else {
		3234	LOG llevInfo, "[ABT] $msg\n";
		3235	LOG llevInfo, "[ABT] [suppressed]\n";
		3236	}
		3237	}
		3238
		3239	# load additional modules
		3240	use cf::pod;
		3241
		3242	END { cf::emergency_save }
1585		3243
1586	1	3244	1
1587		3245

Diff Legend

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