ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/cf.schmorp.de/server/lib/cf.pm

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

Diff Legend

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