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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.310 by elmex, Mon Jul 16 15:43:49 2007 UTC vs.
Revision 1.379 by root, Thu Oct 4 23:59:07 2007 UTC

…		…
10	use Event;	10	use Event;
11	use Opcode;	11	use Opcode;
12	use Safe;	12	use Safe;
13	use Safe::Hole;	13	use Safe::Hole;
14		14
15	use Coro 3.61 ();	15	use Coro 3.64 ();
16	use Coro::State;	16	use Coro::State;
17	use Coro::Handle;	17	use Coro::Handle;
18	use Coro::Event;	18	use Coro::Event;
19	use Coro::Timer;	19	use Coro::Timer;
20	use Coro::Signal;	20	use Coro::Signal;
21	use Coro::Semaphore;	21	use Coro::Semaphore;
22	use Coro::AIO;	22	use Coro::AIO;
23	use Coro::Storable;	23	use Coro::Storable;
		24	use Coro::Util ();
24		25
25	use JSON::XS 1.4 ();	26	use JSON::XS ();
26	use BDB ();	27	use BDB ();
27	use Data::Dumper;	28	use Data::Dumper;
28	use Digest::MD5;	29	use Digest::MD5;
29	use Fcntl;	30	use Fcntl;
30	use YAML::Syck ();	31	use YAML::Syck ();
…		…
79	our $NEXT_TICK;	80	our $NEXT_TICK;
80	our $NOW;	81	our $NOW;
81	our $USE_FSYNC = 1; # use fsync to write maps - default off	82	our $USE_FSYNC = 1; # use fsync to write maps - default off
82		83
83	our $BDB_POLL_WATCHER;	84	our $BDB_POLL_WATCHER;
		85	our $BDB_DEADLOCK_WATCHER;
		86	our $BDB_CHECKPOINT_WATCHER;
		87	our $BDB_TRICKLE_WATCHER;
84	our $DB_ENV;	88	our $DB_ENV;
85		89
86	our %CFG;	90	our %CFG;
87		91
88	our $UPTIME; $UPTIME \|\|= time;	92	our $UPTIME; $UPTIME \|\|= time;
89	our $RUNTIME;	93	our $RUNTIME;
90		94
91	our %PLAYER; # all users	95	our (%PLAYER, %PLAYER_LOADING); # all users
92	our %MAP; # all maps	96	our (%MAP, %MAP_LOADING ); # all maps
93	our $LINK_MAP; # the special {link} map, which is always available	97	our $LINK_MAP; # the special {link} map, which is always available
94		98
95	# used to convert map paths into valid unix filenames by replacing / by ∕	99	# used to convert map paths into valid unix filenames by replacing / by ∕
96	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons	100	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
97		101
…		…
186	$msg .= "\n"	190	$msg .= "\n"
187	unless $msg =~ /\n$/;	191	unless $msg =~ /\n$/;
188		192
189	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;	193	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
190		194
191	utf8::encode $msg;
192	LOG llevError, $msg;	195	LOG llevError, $msg;
193	};	196	};
194	}	197	}
195		198
196	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	199	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
…		…
271	Wait until the given lock is available and then acquires it and returns	274	Wait until the given lock is available and then acquires it and returns
272	a Coro::guard object. If the guard object gets destroyed (goes out of scope,	275	a Coro::guard object. If the guard object gets destroyed (goes out of scope,
273	for example when the coroutine gets canceled), the lock is automatically	276	for example when the coroutine gets canceled), the lock is automatically
274	returned.	277	returned.
275		278
		279	Locks are not recursive, locking from the same coro twice results in a
		280	deadlocked coro.
		281
276	Lock names should begin with a unique identifier (for example, cf::map::find	282	Lock names should begin with a unique identifier (for example, cf::map::find
277	uses map_find and cf::map::load uses map_load).	283	uses map_find and cf::map::load uses map_load).
278		284
279	=item $locked = cf::lock_active $string	285	=item $locked = cf::lock_active $string
280		286
281	Return true if the lock is currently active, i.e. somebody has locked it.	287	Return true if the lock is currently active, i.e. somebody has locked it.
282		288
283	=cut	289	=cut
284		290
285	our %LOCK;	291	our %LOCK;
		292	our %LOCKER;#d#
286		293
287	sub lock_wait($) {	294	sub lock_wait($) {
288	my ($key) = @_;	295	my ($key) = @_;
		296
		297	if ($LOCKER{$key} == $Coro::current) {#d#
		298	Carp::cluck "lock_wait($key) for already-acquired lock";#d#
		299	return;#d#
		300	}#d#
289		301
290	# wait for lock, if any	302	# wait for lock, if any
291	while ($LOCK{$key}) {	303	while ($LOCK{$key}) {
292	push @{ $LOCK{$key} }, $Coro::current;	304	push @{ $LOCK{$key} }, $Coro::current;
293	Coro::schedule;	305	Coro::schedule;
…		…
299		311
300	# wait, to be sure we are not locked	312	# wait, to be sure we are not locked
301	lock_wait $key;	313	lock_wait $key;
302		314
303	$LOCK{$key} = [];	315	$LOCK{$key} = [];
		316	$LOCKER{$key} = $Coro::current;#d#
304		317
305	Coro::guard {	318	Coro::guard {
		319	delete $LOCKER{$key};#d#
306	# wake up all waiters, to be on the safe side	320	# wake up all waiters, to be on the safe side
307	$_->ready for @{ delete $LOCK{$key} };	321	$_->ready for @{ delete $LOCK{$key} };
308	}	322	}
309	}	323	}
310		324
…		…
322	};	336	};
323	$TICK_WATCHER->stop;	337	$TICK_WATCHER->stop;
324	$guard	338	$guard
325	}	339	}
326		340
		341	=item cf::get_slot $time[, $priority[, $name]]
		342
		343	Allocate $time seconds of blocking CPU time at priority C<$priority>:
		344	This call blocks and returns only when you have at least C<$time> seconds
		345	of cpu time till the next tick. The slot is only valid till the next cede.
		346
		347	The optional C<$name> can be used to identify the job to run. It might be
		348	used for statistical purposes and should identify the same time-class.
		349
		350	Useful for short background jobs.
		351
		352	=cut
		353
		354	our @SLOT_QUEUE;
		355	our $SLOT_QUEUE;
		356
		357	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
		358	$SLOT_QUEUE = Coro::async {
		359	$Coro::current->desc ("timeslot manager");
		360
		361	my $signal = new Coro::Signal;
		362
		363	while () {
		364	next_job:
		365	my $avail = cf::till_tick;
		366	if ($avail > 0.01) {
		367	for (0 .. $#SLOT_QUEUE) {
		368	if ($SLOT_QUEUE[$_][0] < $avail) {
		369	my $job = splice @SLOT_QUEUE, $_, 1, ();
		370	$job->[2]->send;
		371	Coro::cede;
		372	goto next_job;
		373	}
		374	}
		375	}
		376
		377	if (@SLOT_QUEUE) {
		378	# we do not use wait_For_tick() as it returns immediately when tick is inactive
		379	push @cf::WAIT_FOR_TICK, $signal;
		380	$signal->wait;
		381	} else {
		382	Coro::schedule;
		383	}
		384	}
		385	};
		386
		387	sub get_slot($;$$) {
		388	my ($time, $pri, $name) = @_;
		389
		390	$time = $TICK * .6 if $time > $TICK * .6;
		391	my $sig = new Coro::Signal;
		392
		393	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
		394	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
		395	$SLOT_QUEUE->ready;
		396	$sig->wait;
		397	}
		398
327	=item cf::async { BLOCK }	399	=item cf::async { BLOCK }
328		400
329	Currently the same as Coro::async_pool, meaning you cannot use	401	Currently the same as Coro::async_pool, meaning you cannot use
330	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only	402	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
331	thing you are allowed to do is call C<prio> on it.	403	thing you are allowed to do is call C<prio> on it.
…		…
355	my $time = Event::time;	427	my $time = Event::time;
356		428
357	# this is the main coro, too bad, we have to block	429	# this is the main coro, too bad, we have to block
358	# till the operation succeeds, freezing the server :/	430	# till the operation succeeds, freezing the server :/
359		431
		432	LOG llevError \| logBacktrace, Carp::longmess "sync job";#d#
		433
360	# TODO: use suspend/resume instead	434	# TODO: use suspend/resume instead
361	# (but this is cancel-safe)	435	# (but this is cancel-safe)
362	my $freeze_guard = freeze_mainloop;	436	my $freeze_guard = freeze_mainloop;
363		437
364	my $busy = 1;	438	my $busy = 1;
365	my @res;	439	my @res;
366		440
367	(async {	441	(async {
		442	$Coro::current->desc ("sync job coro");
368	@res = eval { $job->() };	443	@res = eval { $job->() };
369	warn $@ if $@;	444	warn $@ if $@;
370	undef $busy;	445	undef $busy;
371	})->prio (Coro::PRIO_MAX);	446	})->prio (Coro::PRIO_MAX);
372		447
…		…
416	Coro::Storable. May, of course, block. Note that the executed sub may	491	Coro::Storable. May, of course, block. Note that the executed sub may
417	never block itself or use any form of Event handling.	492	never block itself or use any form of Event handling.
418		493
419	=cut	494	=cut
420		495
421	sub _store_scalar {
422	open my $fh, ">", \my $buf
423	or die "fork_call: cannot open fh-to-buf in child : $!";
424	Storable::store_fd $_[0], $fh;
425	close $fh;
426
427	$buf
428	}
429
430	sub fork_call(&@) {	496	sub fork_call(&@) {
431	my ($cb, @args) = @_;	497	my ($cb, @args) = @_;
432		498
433	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC	499	# we seemingly have to make a local copy of the whole thing,
434	# or die "socketpair: $!";	500	# otherwise perl prematurely frees the stuff :/
435	pipe my $fh1, my $fh2	501	# TODO: investigate and fix (likely this will be rather laborious)
436	or die "pipe: $!";
437		502
438	if (my $pid = fork) {	503	my @res = Coro::Util::fork_eval {
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;	504	reset_signals;
452	local $SIG{__WARN__};	505	&$cb
453	local $SIG{__DIE__};	506	}, @args;
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		507
460	eval {	508	wantarray ? @res : $res[-1]
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;
471	}
472	}	509	}
473		510
474	=item $value = cf::db_get $family => $key	511	=item $value = cf::db_get $family => $key
475		512
476	Returns a single value from the environment database.	513	Returns a single value from the environment database.
…		…
478	=item cf::db_put $family => $key => $value	515	=item cf::db_put $family => $key => $value
479		516
480	Stores the given C<$value> in the family. It can currently store binary	517	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).	518	data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
482		519
		520	=item $db = cf::db_table "name"
		521
		522	Create and/or open a new database table. The string must not be "db" and must be unique
		523	within each server.
		524
483	=cut	525	=cut
		526
		527	sub db_table($) {
		528	my ($name) = @_;
		529	my $db = BDB::db_create $DB_ENV;
		530
		531	eval {
		532	$db->set_flags (BDB::CHKSUM);
		533
		534	utf8::encode $name;
		535	BDB::db_open $db, undef, $name, undef, BDB::BTREE,
		536	BDB::CREATE \| BDB::AUTO_COMMIT, 0666;
		537	cf::cleanup "db_open(db): $!" if $!;
		538	};
		539	cf::cleanup "db_open(db): $@" if $@;
		540
		541	$db
		542	}
484		543
485	our $DB;	544	our $DB;
486		545
487	sub db_init {	546	sub db_init {
488	unless ($DB) {
489	$DB = BDB::db_create $DB_ENV;
490
491	cf::sync_job {	547	cf::sync_job {
492	eval {	548	$DB \|\|= db_table "db";
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	}	549	};
502	}	550	}
503		551
504	sub db_get($$) {	552	sub db_get($$) {
505	my $key = "$_[0]/$_[1]";	553	my $key = "$_[0]/$_[1]";
506		554
…		…
556	if (1) {	604	if (1) {
557	$md5 =	605	$md5 =
558	join "\x00",	606	join "\x00",
559	$processversion,	607	$processversion,
560	map {	608	map {
561	Coro::cede;	609	cf::cede_to_tick;
562	($src->[$_], Digest::MD5::md5_hex $data[$_])	610	($src->[$_], Digest::MD5::md5_hex $data[$_])
563	} 0.. $#$src;	611	} 0.. $#$src;
564		612
565		613
566	my $dbmd5 = db_get cache => "$id/md5";	614	my $dbmd5 = db_get cache => "$id/md5";
…		…
918		966
919	=cut	967	=cut
920		968
921	#############################################################################	969	#############################################################################
922	# object support	970	# object support
		971	#
		972
		973	sub _can_merge {
		974	my ($ob1, $ob2) = @_;
		975
		976	local $Storable::canonical = 1;
		977	my $fob1 = Storable::freeze $ob1;
		978	my $fob2 = Storable::freeze $ob2;
		979
		980	$fob1 eq $fob2
		981	}
923		982
924	sub reattach {	983	sub reattach {
925	# basically do the same as instantiate, without calling instantiate	984	# basically do the same as instantiate, without calling instantiate
926	my ($obj) = @_;	985	my ($obj) = @_;
927		986
…		…
974	sub object_freezer_save {	1033	sub object_freezer_save {
975	my ($filename, $rdata, $objs) = @_;	1034	my ($filename, $rdata, $objs) = @_;
976		1035
977	sync_job {	1036	sync_job {
978	if (length $$rdata) {	1037	if (length $$rdata) {
		1038	utf8::decode (my $decname = $filename);
979	warn sprintf "saving %s (%d,%d)\n",	1039	warn sprintf "saving %s (%d,%d)\n",
980	$filename, length $$rdata, scalar @$objs;	1040	$decname, length $$rdata, scalar @$objs;
981		1041
982	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {	1042	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {
983	chmod SAVE_MODE, $fh;	1043	chmod SAVE_MODE, $fh;
984	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1044	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
985	aio_fsync $fh if $cf::USE_FSYNC;	1045	aio_fsync $fh if $cf::USE_FSYNC;
…		…
1004	}	1064	}
1005	} else {	1065	} else {
1006	aio_unlink $filename;	1066	aio_unlink $filename;
1007	aio_unlink "$filename.pst";	1067	aio_unlink "$filename.pst";
1008	}	1068	}
1009	}	1069	};
1010	}	1070	}
1011		1071
1012	sub object_freezer_as_string {	1072	sub object_freezer_as_string {
1013	my ($rdata, $objs) = @_;	1073	my ($rdata, $objs) = @_;
1014		1074
…		…
1026	or return;	1086	or return;
1027		1087
1028	unless (aio_stat "$filename.pst") {	1088	unless (aio_stat "$filename.pst") {
1029	(aio_load "$filename.pst", $av) >= 0	1089	(aio_load "$filename.pst", $av) >= 0
1030	or return;	1090	or return;
		1091
1031	$av = eval { (Storable::thaw $av)->{objs} };	1092	$av = eval { (Storable::thaw $av)->{objs} };
1032	}	1093	}
1033		1094
		1095	utf8::decode (my $decname = $filename);
1034	warn sprintf "loading %s (%d)\n",	1096	warn sprintf "loading %s (%d,%d)\n",
1035	$filename, length $data, scalar @{$av \|\| []};	1097	$decname, length $data, scalar @{$av \|\| []};
		1098
1036	return ($data, $av);	1099	($data, $av)
1037	}	1100	}
1038		1101
1039	=head2 COMMAND CALLBACKS	1102	=head2 COMMAND CALLBACKS
1040		1103
1041	=over 4	1104	=over 4
…		…
1114	my ($pl, $buf) = @_;	1177	my ($pl, $buf) = @_;
1115		1178
1116	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1179	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1117		1180
1118	if (ref $msg) {	1181	if (ref $msg) {
		1182	my ($type, $reply, @payload) =
		1183	"ARRAY" eq ref $msg
		1184	? @$msg
		1185	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		1186
		1187	my @reply;
		1188
1119	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1189	if (my $cb = $EXTCMD{$type}) {
1120	if (my %reply = $cb->($pl, $msg)) {	1190	@reply = $cb->($pl, @payload);
1121	$pl->ext_reply ($msg->{msgid}, %reply);
1122	}
1123	}	1191	}
		1192
		1193	$pl->ext_reply ($reply, @reply)
		1194	if $reply;
		1195
1124	} else {	1196	} else {
1125	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1197	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1126	}	1198	}
1127		1199
1128	cf::override;	1200	cf::override;
…		…
1218		1290
1219	=head3 cf::player	1291	=head3 cf::player
1220		1292
1221	=over 4	1293	=over 4
1222		1294
		1295	=item cf::player::num_playing
		1296
		1297	Returns the official number of playing players, as per the Crossfire metaserver rules.
		1298
		1299	=cut
		1300
		1301	sub num_playing {
		1302	scalar grep
		1303	$_->ob->map
		1304	&& !$_->hidden
		1305	&& !$_->ob->flag (cf::FLAG_WIZ),
		1306	cf::player::list
		1307	}
		1308
1223	=item cf::player::find $login	1309	=item cf::player::find $login
1224		1310
1225	Returns the given player object, loading it if necessary (might block).	1311	Returns the given player object, loading it if necessary (might block).
1226		1312
1227	=cut	1313	=cut
…		…
1262	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";	1348	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1263	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";	1349	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1264	aio_unlink +(playerdir $login) . "/$login.pl.pst";	1350	aio_unlink +(playerdir $login) . "/$login.pl.pst";
1265	aio_unlink +(playerdir $login) . "/$login.pl";	1351	aio_unlink +(playerdir $login) . "/$login.pl";
1266		1352
1267	my $pl = load_pl path $login	1353	my $f = new_from_file cf::object::thawer path $login
1268	or return;	1354	or return;
		1355
		1356	my $pl = cf::player::load_pl $f
		1357	or return;
		1358	local $cf::PLAYER_LOADING{$login} = $pl;
		1359	$f->resolve_delayed_derefs;
1269	$cf::PLAYER{$login} = $pl	1360	$cf::PLAYER{$login} = $pl
1270	}	1361	}
1271	}	1362	}
1272	}	1363	}
1273		1364
…		…
1283		1374
1284	aio_mkdir playerdir $pl, 0770;	1375	aio_mkdir playerdir $pl, 0770;
1285	$pl->{last_save} = $cf::RUNTIME;	1376	$pl->{last_save} = $cf::RUNTIME;
1286		1377
1287	$pl->save_pl ($path);	1378	$pl->save_pl ($path);
1288	Coro::cede;	1379	cf::cede_to_tick;
1289	}	1380	}
1290		1381
1291	sub new($) {	1382	sub new($) {
1292	my ($login) = @_;	1383	my ($login) = @_;
1293		1384
…		…
1297	$self->{deny_save} = 1;	1388	$self->{deny_save} = 1;
1298		1389
1299	$cf::PLAYER{$login} = $self;	1390	$cf::PLAYER{$login} = $self;
1300		1391
1301	$self	1392	$self
		1393	}
		1394
		1395	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1396
		1397	=cut
		1398
		1399	sub send_msg {
		1400	my $ns = shift->ns
		1401	or return;
		1402	$ns->send_msg (@_);
1302	}	1403	}
1303		1404
1304	=item $pl->quit_character	1405	=item $pl->quit_character
1305		1406
1306	Nukes the player without looking back. If logged in, the connection will	1407	Nukes the player without looking back. If logged in, the connection will
…		…
1361	or return [];	1462	or return [];
1362		1463
1363	my @logins;	1464	my @logins;
1364		1465
1365	for my $login (@$dirs) {	1466	for my $login (@$dirs) {
		1467	my $path = path $login;
		1468
		1469	# a .pst is a dead give-away for a valid player
		1470	unless (-e "$path.pst") {
1366	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;	1471	my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1367	aio_read $fh, 0, 512, my $buf, 0 or next;	1472	aio_read $fh, 0, 512, my $buf, 0 or next;
1368	$buf !~ /^password -------------$/m or next; # official not-valid tag	1473	$buf !~ /^password -------------$/m or next; # official not-valid tag
		1474	}
1369		1475
1370	utf8::decode $login;	1476	utf8::decode $login;
1371	push @logins, $login;	1477	push @logins, $login;
1372	}	1478	}
1373		1479
…		…
1411	sub expand_cfpod {	1517	sub expand_cfpod {
1412	((my $self), (local $_)) = @_;	1518	((my $self), (local $_)) = @_;
1413		1519
1414	# escape & and <	1520	# escape & and <
1415	s/&/&/g;	1521	s/&/&/g;
1416	s/(?<![BIUGH])</</g;	1522	s/(?<![BIUGHT])</</g;
1417		1523
1418	# this is buggy, it needs to properly take care of nested <'s	1524	# this is buggy, it needs to properly take care of nested <'s
1419		1525
1420	1 while	1526	1 while
1421	# replace B<>, I<>, U<> etc.	1527	# replace B<>, I<>, U<> etc.
1422	s/B<([^\>]*)>/<b>$1<\/b>/	1528	s/B<([^\>]*)>/<b>$1<\/b>/
1423	\|\| s/I<([^\>]*)>/<i>$1<\/i>/	1529	\|\| s/I<([^\>]*)>/<i>$1<\/i>/
1424	\|\| s/U<([^\>]*)>/<u>$1<\/u>/	1530	\|\| s/U<([^\>]*)>/<u>$1<\/u>/
		1531	\|\| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1425	# replace G<male\|female> tags	1532	# replace G<male\|female> tags
1426	\|\| s{G<([^>\|])\\|([^>])>}{	1533	\|\| s{G<([^>\|])\\|([^>])>}{
1427	$self->gender ? $2 : $1	1534	$self->gender ? $2 : $1
1428	}ge	1535	}ge
1429	# replace H<hint text>	1536	# replace H<hint text>
…		…
1450	sub hintmode {	1557	sub hintmode {
1451	$_[0]{hintmode} = $_[1] if @_ > 1;	1558	$_[0]{hintmode} = $_[1] if @_ > 1;
1452	$_[0]{hintmode}	1559	$_[0]{hintmode}
1453	}	1560	}
1454		1561
1455	=item $player->ext_reply ($msgid, %msg)	1562	=item $player->ext_reply ($msgid, @msg)
1456		1563
1457	Sends an ext reply to the player.	1564	Sends an ext reply to the player.
1458		1565
1459	=cut	1566	=cut
1460		1567
1461	sub ext_reply($$%) {	1568	sub ext_reply($$@) {
1462	my ($self, $id, %msg) = @_;	1569	my ($self, $id, @msg) = @_;
1463		1570
1464	$msg{msgid} = $id;	1571	$self->ns->ext_reply ($id, @msg)
1465	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1466	}	1572	}
1467		1573
1468	=item $player->ext_event ($type, %msg)	1574	=item $player->ext_msg ($type, @msg)
1469		1575
1470	Sends an ext event to the client.	1576	Sends an ext event to the client.
1471		1577
1472	=cut	1578	=cut
1473		1579
1474	sub ext_event($$%) {	1580	sub ext_msg($$@) {
1475	my ($self, $type, %msg) = @_;	1581	my ($self, $type, @msg) = @_;
1476		1582
1477	$self->ns->ext_event ($type, %msg);	1583	$self->ns->ext_msg ($type, @msg);
1478	}	1584	}
1479		1585
1480	=head3 cf::region	1586	=head3 cf::region
1481		1587
1482	=over 4	1588	=over 4
…		…
1698		1804
1699	sub load_header_from($) {	1805	sub load_header_from($) {
1700	my ($self, $path) = @_;	1806	my ($self, $path) = @_;
1701		1807
1702	utf8::encode $path;	1808	utf8::encode $path;
1703	#aio_open $path, O_RDONLY, 0	1809	my $f = new_from_file cf::object::thawer $path
1704	# or return;
1705
1706	$self->_load_header ($path)
1707	or return;	1810	or return;
		1811
		1812	$self->_load_header ($f)
		1813	or return;
		1814
		1815	local $MAP_LOADING{$self->{path}} = $self;
		1816	$f->resolve_delayed_derefs;
1708		1817
1709	$self->{load_path} = $path;	1818	$self->{load_path} = $path;
1710		1819
1711	1	1820	1
1712	}	1821	}
…		…
1766	sub find {	1875	sub find {
1767	my ($path, $origin) = @_;	1876	my ($path, $origin) = @_;
1768		1877
1769	$path = normalise $path, $origin && $origin->path;	1878	$path = normalise $path, $origin && $origin->path;
1770		1879
		1880	cf::lock_wait "map_data:$path";#d#remove
1771	cf::lock_wait "map_find:$path";	1881	cf::lock_wait "map_find:$path";
1772		1882
1773	$cf::MAP{$path} \|\| do {	1883	$cf::MAP{$path} \|\| do {
1774	my $guard = cf::lock_acquire "map_find:$path";	1884	my $guard1 = cf::lock_acquire "map_find:$path";
		1885	my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
		1886
1775	my $map = new_from_path cf::map $path	1887	my $map = new_from_path cf::map $path
1776	or return;	1888	or return;
1777		1889
1778	$map->{last_save} = $cf::RUNTIME;	1890	$map->{last_save} = $cf::RUNTIME;
1779		1891
…		…
1781	or return;	1893	or return;
1782		1894
1783	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)	1895	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1784	# doing this can freeze the server in a sync job, obviously	1896	# doing this can freeze the server in a sync job, obviously
1785	#$cf::WAIT_FOR_TICK->wait;	1897	#$cf::WAIT_FOR_TICK->wait;
		1898	undef $guard1;
		1899	undef $guard2;
1786	$map->reset;	1900	$map->reset;
1787	undef $guard;
1788	return find $path;	1901	return find $path;
1789	}	1902	}
1790		1903
1791	$cf::MAP{$path} = $map	1904	$cf::MAP{$path} = $map
1792	}	1905	}
…		…
1801	local $self->{deny_reset} = 1; # loading can take a long time	1914	local $self->{deny_reset} = 1; # loading can take a long time
1802		1915
1803	my $path = $self->{path};	1916	my $path = $self->{path};
1804		1917
1805	{	1918	{
1806	my $guard = cf::lock_acquire "map_load:$path";	1919	my $guard = cf::lock_acquire "map_data:$path";
1807		1920
		1921	return unless $self->valid;
1808	return if $self->in_memory != cf::MAP_SWAPPED;	1922	return unless $self->in_memory == cf::MAP_SWAPPED;
1809		1923
1810	$self->in_memory (cf::MAP_LOADING);	1924	$self->in_memory (cf::MAP_LOADING);
1811		1925
1812	$self->alloc;	1926	$self->alloc;
1813		1927
1814	$self->pre_load;	1928	$self->pre_load;
1815	Coro::cede;	1929	cf::cede_to_tick;
1816		1930
		1931	my $f = new_from_file cf::object::thawer $self->{load_path};
		1932	$f->skip_block;
1817	$self->_load_objects ($self->{load_path}, 1)	1933	$self->_load_objects ($f)
1818	or return;	1934	or return;
1819		1935
1820	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	1936	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1821	if delete $self->{load_original};	1937	if delete $self->{load_original};
1822		1938
1823	if (my $uniq = $self->uniq_path) {	1939	if (my $uniq = $self->uniq_path) {
1824	utf8::encode $uniq;	1940	utf8::encode $uniq;
1825	if (aio_open $uniq, O_RDONLY, 0) {	1941	unless (aio_stat $uniq) {
		1942	if (my $f = new_from_file cf::object::thawer $uniq) {
1826	$self->clear_unique_items;	1943	$self->clear_unique_items;
1827	$self->_load_objects ($uniq, 0);	1944	$self->_load_objects ($f);
		1945	$f->resolve_delayed_derefs;
		1946	}
1828	}	1947	}
1829	}	1948	}
1830		1949
1831	Coro::cede;	1950	$f->resolve_delayed_derefs;
		1951
		1952	cf::cede_to_tick;
1832	# now do the right thing for maps	1953	# now do the right thing for maps
1833	$self->link_multipart_objects;	1954	$self->link_multipart_objects;
1834	$self->difficulty ($self->estimate_difficulty)	1955	$self->difficulty ($self->estimate_difficulty)
1835	unless $self->difficulty;	1956	unless $self->difficulty;
1836	Coro::cede;	1957	cf::cede_to_tick;
1837		1958
1838	unless ($self->{deny_activate}) {	1959	unless ($self->{deny_activate}) {
1839	$self->decay_objects;	1960	$self->decay_objects;
1840	$self->fix_auto_apply;	1961	$self->fix_auto_apply;
1841	$self->update_buttons;	1962	$self->update_buttons;
1842	Coro::cede;	1963	cf::cede_to_tick;
1843	$self->set_darkness_map;	1964	$self->set_darkness_map;
1844	Coro::cede;	1965	cf::cede_to_tick;
1845	$self->activate;	1966	$self->activate;
1846	}	1967	}
		1968
		1969	$self->{last_save} = $cf::RUNTIME;
		1970	$self->last_access ($cf::RUNTIME);
1847		1971
1848	$self->in_memory (cf::MAP_IN_MEMORY);	1972	$self->in_memory (cf::MAP_IN_MEMORY);
1849	}	1973	}
1850		1974
1851	$self->post_load;	1975	$self->post_load;
…		…
1862		1986
1863	$self	1987	$self
1864	}	1988	}
1865		1989
1866	# find and load all maps in the 3x3 area around a map	1990	# find and load all maps in the 3x3 area around a map
1867	sub load_diag {	1991	sub load_neighbours {
1868	my ($map) = @_;	1992	my ($map) = @_;
1869		1993
1870	my @diag; # diagonal neighbours	1994	my @neigh; # diagonal neighbours
1871		1995
1872	for (0 .. 3) {	1996	for (0 .. 3) {
1873	my $neigh = $map->tile_path ($_)	1997	my $neigh = $map->tile_path ($_)
1874	or next;	1998	or next;
1875	$neigh = find $neigh, $map	1999	$neigh = find $neigh, $map
1876	or next;	2000	or next;
1877	$neigh->load;	2001	$neigh->load;
1878		2002
		2003	push @neigh,
1879	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],	2004	[$neigh->tile_path (($_ + 3) % 4), $neigh],
1880	[$neigh->tile_path (($_ + 1) % 4), $neigh];	2005	[$neigh->tile_path (($_ + 1) % 4), $neigh];
1881	}	2006	}
1882		2007
1883	for (@diag) {	2008	for (grep defined $_->[0], @neigh) {
		2009	my ($path, $origin) = @$_;
1884	my $neigh = find @$_	2010	my $neigh = find $path, $origin
1885	or next;	2011	or next;
1886	$neigh->load;	2012	$neigh->load;
1887	}	2013	}
1888	}	2014	}
1889		2015
…		…
1894	}	2020	}
1895		2021
1896	sub do_load_sync {	2022	sub do_load_sync {
1897	my ($map) = @_;	2023	my ($map) = @_;
1898		2024
		2025	cf::LOG cf::llevDebug \| cf::logBacktrace, "do_load_sync"
		2026	if $Coro::current == $Coro::main;
		2027
1899	cf::sync_job { $map->load };	2028	cf::sync_job { $map->load };
1900	}	2029	}
1901		2030
1902	our %MAP_PREFETCH;	2031	our %MAP_PREFETCH;
1903	our $MAP_PREFETCHER = undef;	2032	our $MAP_PREFETCHER = undef;
1904		2033
1905	sub find_async {	2034	sub find_async {
1906	my ($path, $origin) = @_;	2035	my ($path, $origin, $load) = @_;
1907		2036
1908	$path = normalise $path, $origin && $origin->{path};	2037	$path = normalise $path, $origin && $origin->{path};
1909		2038
1910	if (my $map = $cf::MAP{$path}) {	2039	if (my $map = $cf::MAP{$path}) {
1911	return $map if $map->in_memory == cf::MAP_IN_MEMORY;	2040	return $map if !$load \|\| $map->in_memory == cf::MAP_IN_MEMORY;
1912	}	2041	}
1913		2042
1914	undef $MAP_PREFETCH{$path};	2043	$MAP_PREFETCH{$path} \|= $load;
		2044
1915	$MAP_PREFETCHER \|\|= cf::async {	2045	$MAP_PREFETCHER \|\|= cf::async {
		2046	$Coro::current->{desc} = "map prefetcher";
		2047
1916	while (%MAP_PREFETCH) {	2048	while (%MAP_PREFETCH) {
1917	for my $path (keys %MAP_PREFETCH) {	2049	while (my ($k, $v) = each %MAP_PREFETCH) {
1918	if (my $map = find $path) {	2050	if (my $map = find $k) {
1919	$map->load;	2051	$map->load if $v;
1920	}	2052	}
1921		2053
1922	delete $MAP_PREFETCH{$path};	2054	delete $MAP_PREFETCH{$k};
1923	}	2055	}
1924	}	2056	}
1925	undef $MAP_PREFETCHER;	2057	undef $MAP_PREFETCHER;
1926	};	2058	};
1927	$MAP_PREFETCHER->prio (6);	2059	$MAP_PREFETCHER->prio (6);
…		…
1930	}	2062	}
1931		2063
1932	sub save {	2064	sub save {
1933	my ($self) = @_;	2065	my ($self) = @_;
1934		2066
1935	my $lock = cf::lock_acquire "map_data:" . $self->path;	2067	my $lock = cf::lock_acquire "map_data:$self->{path}";
1936		2068
1937	$self->{last_save} = $cf::RUNTIME;	2069	$self->{last_save} = $cf::RUNTIME;
1938		2070
1939	return unless $self->dirty;	2071	return unless $self->dirty;
1940		2072
…		…
1946	return if $self->{deny_save};	2078	return if $self->{deny_save};
1947		2079
1948	local $self->{last_access} = $self->last_access;#d#	2080	local $self->{last_access} = $self->last_access;#d#
1949		2081
1950	cf::async {	2082	cf::async {
		2083	$Coro::current->{desc} = "map player save";
1951	$_->contr->save for $self->players;	2084	$_->contr->save for $self->players;
1952	};	2085	};
1953		2086
1954	if ($uniq) {	2087	if ($uniq) {
1955	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);	2088	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);
…		…
1963	my ($self) = @_;	2096	my ($self) = @_;
1964		2097
1965	# save first because save cedes	2098	# save first because save cedes
1966	$self->save;	2099	$self->save;
1967		2100
1968	my $lock = cf::lock_acquire "map_data:" . $self->path;	2101	my $lock = cf::lock_acquire "map_data:$self->{path}";
1969		2102
1970	return if $self->players;	2103	return if $self->players;
1971	return if $self->in_memory != cf::MAP_IN_MEMORY;	2104	return if $self->in_memory != cf::MAP_IN_MEMORY;
1972	return if $self->{deny_save};	2105	return if $self->{deny_save};
1973		2106
		2107	$self->in_memory (cf::MAP_SWAPPED);
		2108
		2109	$self->deactivate;
		2110	$_->clear_links_to ($self) for values %cf::MAP;
1974	$self->clear;	2111	$self->clear;
1975	$self->in_memory (cf::MAP_SWAPPED);
1976	}	2112	}
1977		2113
1978	sub reset_at {	2114	sub reset_at {
1979	my ($self) = @_;	2115	my ($self) = @_;
1980		2116
…		…
2012	if $uniq;	2148	if $uniq;
2013	}	2149	}
2014		2150
2015	delete $cf::MAP{$self->path};	2151	delete $cf::MAP{$self->path};
2016		2152
		2153	$self->deactivate;
		2154	$_->clear_links_to ($self) for values %cf::MAP;
2017	$self->clear;	2155	$self->clear;
2018
2019	$_->clear_links_to ($self) for values %cf::MAP;
2020		2156
2021	$self->unlink_save;	2157	$self->unlink_save;
2022	$self->destroy;	2158	$self->destroy;
2023	}	2159	}
2024		2160
2025	my $nuke_counter = "aaaa";	2161	my $nuke_counter = "aaaa";
2026		2162
2027	sub nuke {	2163	sub nuke {
2028	my ($self) = @_;	2164	my ($self) = @_;
2029		2165
		2166	{
		2167	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2168
2030	delete $cf::MAP{$self->path};	2169	delete $cf::MAP{$self->path};
2031		2170
2032	$self->unlink_save;	2171	$self->unlink_save;
2033		2172
2034	bless $self, "cf::map";	2173	bless $self, "cf::map";
2035	delete $self->{deny_reset};	2174	delete $self->{deny_reset};
2036	$self->{deny_save} = 1;	2175	$self->{deny_save} = 1;
2037	$self->reset_timeout (1);	2176	$self->reset_timeout (1);
2038	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2177	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2039		2178
2040	$cf::MAP{$self->path} = $self;	2179	$cf::MAP{$self->path} = $self;
		2180	}
2041		2181
2042	$self->reset; # polite request, might not happen	2182	$self->reset; # polite request, might not happen
2043	}	2183	}
2044		2184
2045	=item $maps = cf::map::tmp_maps	2185	=item $maps = cf::map::tmp_maps
…		…
2121		2261
2122	sub inv_recursive {	2262	sub inv_recursive {
2123	inv_recursive_ inv $_[0]	2263	inv_recursive_ inv $_[0]
2124	}	2264	}
2125		2265
		2266	=item $ref = $ob->ref
		2267
		2268	creates and returns a persistent reference to an objetc that can be stored as a string.
		2269
		2270	=item $ob = cf::object::deref ($refstring)
		2271
		2272	returns the objetc referenced by refstring. may return undef when it cnanot find the object,
		2273	even if the object actually exists. May block.
		2274
		2275	=cut
		2276
		2277	sub deref {
		2278	my ($ref) = @_;
		2279
		2280	if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
		2281	my ($uuid, $name) = ($1, $2);
		2282	my $pl = $cf::PLAYER_LOADING{$name} \|\| cf::player::find $name
		2283	or return;
		2284	$pl->ob->uuid eq $uuid
		2285	or return;
		2286
		2287	$pl->ob
		2288	} else {
		2289	warn "$ref: cannot resolve object reference\n";
		2290	undef
		2291	}
		2292	}
		2293
2126	package cf;	2294	package cf;
2127		2295
2128	=back	2296	=back
2129		2297
2130	=head3 cf::object::player	2298	=head3 cf::object::player
…		…
2152		2320
2153	} else {	2321	} else {
2154	my $pl = $self->contr;	2322	my $pl = $self->contr;
2155		2323
2156	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2324	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2157	my $diag = $pl->{npc_dialog};	2325	my $dialog = $pl->{npc_dialog};
2158	$diag->{pl}->ext_reply (	2326	$dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2159	$diag->{id},
2160	msgtype => "reply",
2161	msg => $diag->{pl}->expand_cfpod ($msg),
2162	add_topics => []
2163	);
2164		2327
2165	} else {	2328	} else {
2166	$msg = $npc->name . " says: $msg" if $npc;	2329	$msg = $npc->name . " says: $msg" if $npc;
2167	$self->message ($msg, $flags);	2330	$self->message ($msg, $flags);
2168	}	2331	}
2169	}	2332	}
		2333	}
		2334
		2335	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2336
		2337	=cut
		2338
		2339	sub cf::object::send_msg {
		2340	my $pl = shift->contr
		2341	or return;
		2342	$pl->send_msg (@_);
2170	}	2343	}
2171		2344
2172	=item $player_object->may ("access")	2345	=item $player_object->may ("access")
2173		2346
2174	Returns wether the given player is authorized to access resource "access"	2347	Returns wether the given player is authorized to access resource "access"
…		…
2253	# use -1 or undef as default coordinates, not 0, 0	2426	# use -1 or undef as default coordinates, not 0, 0
2254	($x, $y) = ($map->enter_x, $map->enter_y)	2427	($x, $y) = ($map->enter_x, $map->enter_y)
2255	if $x <=0 && $y <= 0;	2428	if $x <=0 && $y <= 0;
2256		2429
2257	$map->load;	2430	$map->load;
2258	$map->load_diag;	2431	$map->load_neighbours;
2259		2432
2260	return unless $self->contr->active;	2433	return unless $self->contr->active;
2261	$self->activate_recursive;	2434	$self->activate_recursive;
2262		2435
2263	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2436	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
…		…
2283	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2456	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2284		2457
2285	$self->enter_link;	2458	$self->enter_link;
2286		2459
2287	(async {	2460	(async {
		2461	$Coro::current->{desc} = "player::goto $path $x $y";
		2462
		2463	# *tag paths override both path and x\|y
		2464	if ($path =~ /^\(.)$/) {
		2465	if (my @obs = grep $_->map, ext::map_tags::find $1) {
		2466	my $ob = $obs[rand @obs];
		2467
		2468	# see if we actually can go there
		2469	if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
		2470	$ob = $obs[rand @obs];
		2471	} else {
		2472	$self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE \| cf::NDI_RED);
		2473	}
		2474	# else put us there anyways for now #d#
		2475
		2476	($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
		2477	} else {
		2478	($path, $x, $y) = (undef, undef, undef);
		2479	}
		2480	}
		2481
2288	my $map = eval {	2482	my $map = eval {
2289	my $map = cf::map::find $path;	2483	my $map = defined $path ? cf::map::find $path : undef;
2290		2484
2291	if ($map) {	2485	if ($map) {
2292	$map = $map->customise_for ($self);	2486	$map = $map->customise_for ($self);
2293	$map = $check->($map) if $check && $map;	2487	$map = $check->($map) if $check && $map;
2294	} else {	2488	} else {
2295	$self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE \| cf::NDI_RED);	2489	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE \| cf::NDI_RED);
2296	}	2490	}
2297		2491
2298	$map	2492	$map
2299	};	2493	};
2300		2494
…		…
2390	# if exit is damned, update players death & WoR home-position	2584	# if exit is damned, update players death & WoR home-position
2391	$self->contr->savebed ($slaying, $hp, $sp)	2585	$self->contr->savebed ($slaying, $hp, $sp)
2392	if $exit->flag (FLAG_DAMNED);	2586	if $exit->flag (FLAG_DAMNED);
2393		2587
2394	(async {	2588	(async {
		2589	$Coro::current->{desc} = "enter_exit $slaying $hp $sp";
		2590
2395	$self->deactivate_recursive; # just to be sure	2591	$self->deactivate_recursive; # just to be sure
2396	unless (eval {	2592	unless (eval {
2397	$self->goto ($slaying, $hp, $sp);	2593	$self->goto ($slaying, $hp, $sp);
2398		2594
2399	1;	2595	1;
…		…
2425		2621
2426	utf8::encode $text;	2622	utf8::encode $text;
2427	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2623	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2428	}	2624	}
2429		2625
2430	=item $client->send_msg ($color, $type, $msg, [extra...])	2626	=item $client->send_msg ($channel, $msg, $color, [extra...])
2431		2627
2432	Send a drawinfo or msg packet to the client, formatting the msg for the	2628	Send a drawinfo or msg packet to the client, formatting the msg for the
2433	client if neccessary. C<$type> should be a string identifying the type of	2629	client if neccessary. C<$type> should be a string identifying the type of
2434	the message, with C<log> being the default. If C<$color> is negative, suppress	2630	the message, with C<log> being the default. If C<$color> is negative, suppress
2435	the message unless the client supports the msg packet.	2631	the message unless the client supports the msg packet.
2436		2632
2437	=cut	2633	=cut
2438		2634
		2635	our %CHANNEL = (
		2636	"c/identify" => {
		2637	id => "infobox",
		2638	title => "Identify",
		2639	reply => undef,
		2640	tooltip => "Items recently identified",
		2641	},
		2642	"c/examine" => {
		2643	id => "infobox",
		2644	title => "Examine",
		2645	reply => undef,
		2646	tooltip => "Signs and other items you examined",
		2647	},
		2648	"c/lookat" => {
		2649	id => "infobox",
		2650	title => "Look",
		2651	reply => undef,
		2652	tooltip => "What you saw there",
		2653	},
		2654	);
		2655
2439	sub cf::client::send_msg {	2656	sub cf::client::send_msg {
2440	my ($self, $color, $type, $msg, @extra) = @_;	2657	my ($self, $channel, $msg, $color, @extra) = @_;
2441		2658
2442	$msg = $self->pl->expand_cfpod ($msg);	2659	$msg = $self->pl->expand_cfpod ($msg);
2443		2660
		2661	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2662
		2663	# check predefined channels, for the benefit of C
		2664	if ($CHANNEL{$channel}) {
		2665	$channel = $CHANNEL{$channel};
		2666
		2667	$self->ext_msg (channel_info => $channel)
		2668	if $self->can_msg;
		2669
		2670	$channel = $channel->{id};
		2671
		2672	} elsif (ref $channel) {
		2673	# send meta info to client, if not yet sent
		2674	unless (exists $self->{channel}{$channel->{id}}) {
		2675	$self->{channel}{$channel->{id}} = $channel;
		2676	$self->ext_msg (channel_info => $channel)
		2677	if $self->can_msg;
		2678	}
		2679
		2680	$channel = $channel->{id};
		2681	}
		2682
2444	return unless @extra \|\| length $msg;	2683	return unless @extra \|\| length $msg;
2445		2684
2446	if ($self->can_msg) {	2685	if ($self->can_msg) {
		2686	# default colour, mask it out
		2687	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2688	if $color & cf::NDI_DEF;
		2689
2447	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));	2690	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2691	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2448	} else {	2692	} else {
2449	# replace some tags by gcfclient-compatible ones
2450	for ($msg) {
2451	1 while
2452	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2453	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2454	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2455	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2456	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2457	}
2458
2459	if ($color >= 0) {	2693	if ($color >= 0) {
		2694	# replace some tags by gcfclient-compatible ones
		2695	for ($msg) {
		2696	1 while
		2697	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2698	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2699	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2700	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2701	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2702	}
		2703
		2704	$color &= cf::NDI_COLOR_MASK;
		2705
		2706	utf8::encode $msg;
		2707
2460	if (0 && $msg =~ /\[/) {	2708	if (0 && $msg =~ /\[/) {
		2709	# COMMAND/INFO
2461	$self->send_packet ("drawextinfo $color 4 0 $msg")	2710	$self->send_packet ("drawextinfo $color 10 8 $msg")
2462	} else {	2711	} else {
2463	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2712	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2464	$self->send_packet ("drawinfo $color $msg")	2713	$self->send_packet ("drawinfo $color $msg")
2465	}	2714	}
2466	}	2715	}
2467	}	2716	}
2468	}	2717	}
2469		2718
2470	=item $client->ext_event ($type, %msg)	2719	=item $client->ext_msg ($type, @msg)
2471		2720
2472	Sends an ext event to the client.	2721	Sends an ext event to the client.
2473		2722
2474	=cut	2723	=cut
2475		2724
2476	sub cf::client::ext_event($$%) {	2725	sub cf::client::ext_msg($$@) {
2477	my ($self, $type, %msg) = @_;	2726	my ($self, $type, @msg) = @_;
2478		2727
2479	return unless $self->extcmd;	2728	if ($self->extcmd == 2) {
2480		2729	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2730	} elsif ($self->extcmd == 1) { # TODO: remove
2481	$msg{msgtype} = "event_$type";	2731	push @msg, msgtype => "event_$type";
2482	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2732	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2733	}
		2734	}
		2735
		2736	=item $client->ext_reply ($msgid, @msg)
		2737
		2738	Sends an ext reply to the client.
		2739
		2740	=cut
		2741
		2742	sub cf::client::ext_reply($$@) {
		2743	my ($self, $id, @msg) = @_;
		2744
		2745	if ($self->extcmd == 2) {
		2746	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
		2747	} elsif ($self->extcmd == 1) {
		2748	#TODO: version 1, remove
		2749	unshift @msg, msgtype => "reply", msgid => $id;
		2750	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2751	}
2483	}	2752	}
2484		2753
2485	=item $success = $client->query ($flags, "text", \&cb)	2754	=item $success = $client->query ($flags, "text", \&cb)
2486		2755
2487	Queues a query to the client, calling the given callback with	2756	Queues a query to the client, calling the given callback with
…		…
2542	my ($ns, $buf) = @_;	2811	my ($ns, $buf) = @_;
2543		2812
2544	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2813	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2545		2814
2546	if (ref $msg) {	2815	if (ref $msg) {
		2816	my ($type, $reply, @payload) =
		2817	"ARRAY" eq ref $msg
		2818	? @$msg
		2819	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2820
		2821	my @reply;
		2822
2547	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2823	if (my $cb = $EXTICMD{$type}) {
2548	if (my %reply = $cb->($ns, $msg)) {	2824	@reply = $cb->($ns, @payload);
2549	$reply{msgid} = $msg->{msgid};
2550	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2551	}
2552	}	2825	}
		2826
		2827	$ns->ext_reply ($reply, @reply)
		2828	if $reply;
		2829
2553	} else {	2830	} else {
2554	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2831	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2555	}	2832	}
2556		2833
2557	cf::override;	2834	cf::override;
…		…
2604	our $safe = new Safe "safe";	2881	our $safe = new Safe "safe";
2605	our $safe_hole = new Safe::Hole;	2882	our $safe_hole = new Safe::Hole;
2606		2883
2607	$SIG{FPE} = 'IGNORE';	2884	$SIG{FPE} = 'IGNORE';
2608		2885
2609	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2886	$safe->permit_only (Opcode::opset qw(
		2887	:base_core :base_mem :base_orig :base_math
		2888	grepstart grepwhile mapstart mapwhile
		2889	sort time
		2890	));
2610		2891
2611	# here we export the classes and methods available to script code	2892	# here we export the classes and methods available to script code
2612		2893
2613	=pod	2894	=pod
2614		2895
2615	The following functions and methods are available within a safe environment:	2896	The following functions and methods are available within a safe environment:
2616		2897
2617	cf::object	2898	cf::object
2618	contr pay_amount pay_player map x y force_find force_add	2899	contr pay_amount pay_player map x y force_find force_add
2619	insert remove	2900	insert remove name archname title slaying race decrease_ob_nr
2620		2901
2621	cf::object::player	2902	cf::object::player
2622	player	2903	player
2623		2904
2624	cf::player	2905	cf::player
…		…
2629		2910
2630	=cut	2911	=cut
2631		2912
2632	for (	2913	for (
2633	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2914	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2915	insert remove inv name archname title slaying race
2634	insert remove)],	2916	decrease_ob_nr)],
2635	["cf::object::player" => qw(player)],	2917	["cf::object::player" => qw(player)],
2636	["cf::player" => qw(peaceful)],	2918	["cf::player" => qw(peaceful)],
2637	["cf::map" => qw(trigger)],	2919	["cf::map" => qw(trigger)],
2638	) {	2920	) {
2639	no strict 'refs';	2921	no strict 'refs';
…		…
2715	# the server's init and main functions	2997	# the server's init and main functions
2716		2998
2717	sub load_facedata($) {	2999	sub load_facedata($) {
2718	my ($path) = @_;	3000	my ($path) = @_;
2719		3001
		3002	# HACK to clear player env face cache, we need some signal framework
		3003	# for this (global event?)
		3004	%ext::player_env::MUSIC_FACE_CACHE = ();
		3005
		3006	my $enc = JSON::XS->new->utf8->canonical->relaxed;
		3007
2720	warn "loading facedata from $path\n";	3008	warn "loading facedata from $path\n";
2721		3009
2722	my $facedata;	3010	my $facedata;
2723	0 < aio_load $path, $facedata	3011	0 < aio_load $path, $facedata
2724	or die "$path: $!";	3012	or die "$path: $!";
2725		3013
2726	$facedata = Coro::Storable::thaw $facedata;	3014	$facedata = Coro::Storable::thaw $facedata;
2727		3015
2728	$facedata->{version} == 2	3016	$facedata->{version} == 2
2729	or cf::cleanup "$path: version mismatch, cannot proceed.";	3017	or cf::cleanup "$path: version mismatch, cannot proceed.";
		3018
		3019	# patch in the exptable
		3020	$facedata->{resource}{"res/exp_table"} = {
		3021	type => FT_RSRC,
		3022	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
		3023	};
		3024	cf::cede_to_tick;
2730		3025
2731	{	3026	{
2732	my $faces = $facedata->{faceinfo};	3027	my $faces = $facedata->{faceinfo};
2733		3028
2734	while (my ($face, $info) = each %$faces) {	3029	while (my ($face, $info) = each %$faces) {
2735	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	3030	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2736	cf::face::set_visibility $idx, $info->{visibility};	3031	cf::face::set_visibility $idx, $info->{visibility};
2737	cf::face::set_magicmap $idx, $info->{magicmap};	3032	cf::face::set_magicmap $idx, $info->{magicmap};
2738	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	3033	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2739	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	3034	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2740		3035
2741	cf::cede_to_tick;	3036	cf::cede_to_tick;
2742	}	3037	}
2743		3038
2744	while (my ($face, $info) = each %$faces) {	3039	while (my ($face, $info) = each %$faces) {
…		…
2769		3064
2770	{	3065	{
2771	# TODO: for gcfclient pleasure, we should give resources	3066	# TODO: for gcfclient pleasure, we should give resources
2772	# that gcfclient doesn't grok a >10000 face index.	3067	# that gcfclient doesn't grok a >10000 face index.
2773	my $res = $facedata->{resource};	3068	my $res = $facedata->{resource};
2774	my $enc = JSON::XS->new->utf8->canonical;	3069
		3070	my $soundconf = delete $res->{"res/sound.conf"};
2775		3071
2776	while (my ($name, $info) = each %$res) {	3072	while (my ($name, $info) = each %$res) {
2777	my $meta = $enc->encode ({
2778	name => $name,
2779	type => $info->{type},
2780	copyright => $info->{copyright}, #TODO#
2781	});
2782
2783	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	3073	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		3074	my $data;
2784		3075
2785	if ($name =~ /\.jpg$/) {	3076	if ($info->{type} & 1) {
2786	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack	3077	# prepend meta info
2787	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack	3078
		3079	my $meta = $enc->encode ({
		3080	name => $name,
		3081	%{ $info->{meta} \|\| {} },
		3082	});
		3083
		3084	$data = pack "(w/a)", $meta, $info->{data};
2788	} else {	3085	} else {
2789	my $data = pack "(w/a)", $meta, $info->{data};	3086	$data = $info->{data};
2790	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2791
2792	cf::face::set_type $idx, 1;
2793	cf::face::set_data $idx, 0, $data, $chk;
2794	}	3087	}
2795		3088
		3089	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
		3090	cf::face::set_type $idx, $info->{type};
		3091
2796	cf::cede_to_tick;	3092	cf::cede_to_tick;
2797	}	3093	}
		3094
		3095	if ($soundconf) {
		3096	$soundconf = $enc->decode (delete $soundconf->{data});
		3097
		3098	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3099	my $sound = $soundconf->{compat}[$_]
		3100	or next;
		3101
		3102	my $face = cf::face::find "sound/$sound->[1]";
		3103	cf::sound::set $sound->[0] => $face;
		3104	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3105	}
		3106
		3107	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3108	my $face = cf::face::find "sound/$v";
		3109	cf::sound::set $k => $face;
		3110	}
		3111	}
2798	}	3112	}
2799		3113
2800	1	3114	1
2801	}	3115	}
2802		3116
		3117	register_exticmd fx_want => sub {
		3118	my ($ns, $want) = @_;
		3119
		3120	while (my ($k, $v) = each %$want) {
		3121	$ns->fx_want ($k, $v);
		3122	}
		3123	};
		3124
2803	sub reload_regions {	3125	sub reload_regions {
		3126	# HACK to clear player env face cache, we need some signal framework
		3127	# for this (global event?)
		3128	%ext::player_env::MUSIC_FACE_CACHE = ();
		3129
2804	load_resource_file "$MAPDIR/regions"	3130	load_resource_file "$MAPDIR/regions"
2805	or die "unable to load regions file\n";	3131	or die "unable to load regions file\n";
2806		3132
2807	for (cf::region::list) {	3133	for (cf::region::list) {
2808	$_->{match} = qr/$_->{match}/	3134	$_->{match} = qr/$_->{match}/
…		…
2844		3170
2845	sub init {	3171	sub init {
2846	reload_resources;	3172	reload_resources;
2847	}	3173	}
2848		3174
2849	sub cfg_load {	3175	sub reload_config {
2850	open my $fh, "<:utf8", "$CONFDIR/config"	3176	open my $fh, "<:utf8", "$CONFDIR/config"
2851	or return;	3177	or return;
2852		3178
2853	local $/;	3179	local $/;
2854	*CFG = YAML::Syck::Load <$fh>;	3180	*CFG = YAML::Syck::Load <$fh>;
…		…
2870	sub main {	3196	sub main {
2871	# we must not ever block the main coroutine	3197	# we must not ever block the main coroutine
2872	local $Coro::idle = sub {	3198	local $Coro::idle = sub {
2873	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#	3199	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2874	(async {	3200	(async {
		3201	$Coro::current->{desc} = "IDLE BUG HANDLER";
2875	Event::one_event;	3202	Event::one_event;
2876	})->prio (Coro::PRIO_MAX);	3203	})->prio (Coro::PRIO_MAX);
2877	};	3204	};
2878		3205
2879	cfg_load;	3206	reload_config;
2880	db_init;	3207	db_init;
2881	load_extensions;	3208	load_extensions;
2882		3209
2883	$TICK_WATCHER->start;	3210	$TICK_WATCHER->start;
2884	Event::loop;	3211	Event::loop;
…		…
3077	warn "reloading cf.pm";	3404	warn "reloading cf.pm";
3078	require cf;	3405	require cf;
3079	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3406	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3080		3407
3081	warn "loading config and database again";	3408	warn "loading config and database again";
3082	cf::cfg_load;	3409	cf::reload_config;
3083		3410
3084	warn "loading extensions";	3411	warn "loading extensions";
3085	cf::load_extensions;	3412	cf::load_extensions;
3086		3413
3087	warn "reattaching attachments to objects/players";	3414	warn "reattaching attachments to objects/players";
…		…
3123	register_command "reload" => sub {	3450	register_command "reload" => sub {
3124	my ($who, $arg) = @_;	3451	my ($who, $arg) = @_;
3125		3452
3126	if ($who->flag (FLAG_WIZ)) {	3453	if ($who->flag (FLAG_WIZ)) {
3127	$who->message ("reloading server.");	3454	$who->message ("reloading server.");
		3455	async {
		3456	$Coro::current->{desc} = "perl_reload";
3128	async { reload_perl };	3457	reload_perl;
		3458	};
3129	}	3459	}
3130	};	3460	};
3131		3461
3132	unshift @INC, $LIBDIR;	3462	unshift @INC, $LIBDIR;
3133		3463
…		…
3152	my $signal = new Coro::Signal;	3482	my $signal = new Coro::Signal;
3153	push @WAIT_FOR_TICK_BEGIN, $signal;	3483	push @WAIT_FOR_TICK_BEGIN, $signal;
3154	$signal->wait;	3484	$signal->wait;
3155	}	3485	}
3156		3486
3157	my $min = 1e6;#d#
3158	my $avg = 10;
3159	$TICK_WATCHER = Event->timer (	3487	$TICK_WATCHER = Event->timer (
3160	reentrant => 0,	3488	reentrant => 0,
3161	parked => 1,	3489	parked => 1,
3162	prio => 0,	3490	prio => 0,
3163	at => $NEXT_TICK \|\| $TICK,	3491	at => $NEXT_TICK \|\| $TICK,
…		…
3171		3499
3172	$NOW = $tick_start = Event::time;	3500	$NOW = $tick_start = Event::time;
3173		3501
3174	cf::server_tick; # one server iteration	3502	cf::server_tick; # one server iteration
3175		3503
3176	0 && sync_job {#d#
3177	for(1..10) {
3178	my $t = Event::time;
3179	my $map = my $map = new_from_path cf::map "/tmp/x.map"
3180	or die;
3181
3182	$map->width (50);
3183	$map->height (50);
3184	$map->alloc;
3185	$map->_load_objects ("/tmp/x.map", 1);
3186	my $t = Event::time - $t;
3187
3188	#next unless $t < 0.0013;#d#
3189	if ($t < $min) {
3190	$min = $t;
3191	}
3192	$avg = $avg * 0.99 + $t * 0.01;
3193	}
3194	warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3195	exit 0;
3196	# 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3197	};
3198
3199	$RUNTIME += $TICK;	3504	$RUNTIME += $TICK;
3200	$NEXT_TICK += $TICK;	3505	$NEXT_TICK += $TICK;
3201		3506
3202	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3507	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3203	$NEXT_RUNTIME_WRITE = $NOW + 10;	3508	$NEXT_RUNTIME_WRITE = $NOW + 10;
3204	Coro::async_pool {	3509	Coro::async_pool {
		3510	$Coro::current->{desc} = "runtime saver";
3205	write_runtime	3511	write_runtime
3206	or warn "ERROR: unable to write runtime file: $!";	3512	or warn "ERROR: unable to write runtime file: $!";
3207	};	3513	};
3208	}	3514	}
3209		3515
3210	# my $AFTER = Event::time;
3211	# warn $AFTER - $NOW;#d#
3212
3213	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3516	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3214	$sig->send;	3517	$sig->send;
3215	}	3518	}
3216	while (my $sig = shift @WAIT_FOR_TICK) {	3519	while (my $sig = shift @WAIT_FOR_TICK) {
3217	$sig->send;	3520	$sig->send;
…		…
3227		3530
3228	$LOAD = ($NOW - $tick_start) / $TICK;	3531	$LOAD = ($NOW - $tick_start) / $TICK;
3229	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	3532	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3230		3533
3231	_post_tick;	3534	_post_tick;
3232
3233
3234	},	3535	},
3235	);	3536	);
3236		3537
3237	{	3538	{
		3539	BDB::min_parallel 8;
3238	BDB::max_poll_time $TICK * 0.1;	3540	BDB::max_poll_time $TICK * 0.1;
3239	$BDB_POLL_WATCHER = Event->io (	3541	$BDB_POLL_WATCHER = Event->io (
3240	reentrant => 0,	3542	reentrant => 0,
3241	fd => BDB::poll_fileno,	3543	fd => BDB::poll_fileno,
3242	poll => 'r',	3544	poll => 'r',
3243	prio => 0,	3545	prio => 0,
3244	data => WF_AUTOCANCEL,	3546	data => WF_AUTOCANCEL,
3245	cb => \&BDB::poll_cb,	3547	cb => \&BDB::poll_cb,
3246	);	3548	);
3247	BDB::min_parallel 8;
3248		3549
3249	BDB::set_sync_prepare {	3550	BDB::set_sync_prepare {
3250	my $status;	3551	my $status;
3251	my $current = $Coro::current;	3552	my $current = $Coro::current;
3252	(	3553	(
…		…
3261	)	3562	)
3262	};	3563	};
3263		3564
3264	unless ($DB_ENV) {	3565	unless ($DB_ENV) {
3265	$DB_ENV = BDB::db_env_create;	3566	$DB_ENV = BDB::db_env_create;
		3567	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC
		3568	\| BDB::LOG_AUTOREMOVE, 1);
		3569	$DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
		3570	$DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3266		3571
3267	cf::sync_job {	3572	cf::sync_job {
3268	eval {	3573	eval {
3269	BDB::db_env_open	3574	BDB::db_env_open
3270	$DB_ENV,	3575	$DB_ENV,
…		…
3272	BDB::INIT_LOCK \| BDB::INIT_LOG \| BDB::INIT_MPOOL \| BDB::INIT_TXN	3577	BDB::INIT_LOCK \| BDB::INIT_LOG \| BDB::INIT_MPOOL \| BDB::INIT_TXN
3273	\| BDB::RECOVER \| BDB::REGISTER \| BDB::USE_ENVIRON \| BDB::CREATE,	3578	\| BDB::RECOVER \| BDB::REGISTER \| BDB::USE_ENVIRON \| BDB::CREATE,
3274	0666;	3579	0666;
3275		3580
3276	cf::cleanup "db_env_open($BDBDIR): $!" if $!;	3581	cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3277
3278	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC, 1);
3279	$DB_ENV->set_lk_detect;
3280	};	3582	};
3281		3583
3282	cf::cleanup "db_env_open(db): $@" if $@;	3584	cf::cleanup "db_env_open(db): $@" if $@;
3283	};	3585	};
3284	}	3586	}
		3587
		3588	$BDB_DEADLOCK_WATCHER = Event->timer (
		3589	after => 3,
		3590	interval => 1,
		3591	hard => 1,
		3592	prio => 0,
		3593	data => WF_AUTOCANCEL,
		3594	cb => sub {
		3595	BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
		3596	},
		3597	);
		3598	$BDB_CHECKPOINT_WATCHER = Event->timer (
		3599	after => 11,
		3600	interval => 60,
		3601	hard => 1,
		3602	prio => 0,
		3603	data => WF_AUTOCANCEL,
		3604	cb => sub {
		3605	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
		3606	},
		3607	);
		3608	$BDB_TRICKLE_WATCHER = Event->timer (
		3609	after => 5,
		3610	interval => 10,
		3611	hard => 1,
		3612	prio => 0,
		3613	data => WF_AUTOCANCEL,
		3614	cb => sub {
		3615	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
		3616	},
		3617	);
3285	}	3618	}
3286		3619
3287	{	3620	{
3288	IO::AIO::min_parallel 8;	3621	IO::AIO::min_parallel 8;
3289		3622
…		…
3292	$AIO_POLL_WATCHER = Event->io (	3625	$AIO_POLL_WATCHER = Event->io (
3293	reentrant => 0,	3626	reentrant => 0,
3294	data => WF_AUTOCANCEL,	3627	data => WF_AUTOCANCEL,
3295	fd => IO::AIO::poll_fileno,	3628	fd => IO::AIO::poll_fileno,
3296	poll => 'r',	3629	poll => 'r',
3297	prio => 6,	3630	prio => 0,
3298	cb => \&IO::AIO::poll_cb,	3631	cb => \&IO::AIO::poll_cb,
3299	);	3632	);
3300	}	3633	}
3301		3634
3302	my $_log_backtrace;	3635	my $_log_backtrace;
…		…
3308		3641
3309	# limit the # of concurrent backtraces	3642	# limit the # of concurrent backtraces
3310	if ($_log_backtrace < 2) {	3643	if ($_log_backtrace < 2) {
3311	++$_log_backtrace;	3644	++$_log_backtrace;
3312	async {	3645	async {
		3646	$Coro::current->{desc} = "abt $msg";
		3647
3313	my @bt = fork_call {	3648	my @bt = fork_call {
3314	@addr = map { sprintf "%x", $_ } @addr;	3649	@addr = map { sprintf "%x", $_ } @addr;
3315	my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;	3650	my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3316	open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 \|"	3651	open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 \|"
3317	or die "addr2line: $!";	3652	or die "addr2line: $!";

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.310 by elmex, Mon Jul 16 15:43:49 2007 UTC vs. Revision 1.379 by root, Thu Oct 4 23:59:07 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.310 by elmex, Mon Jul 16 15:43:49 2007 UTC vs.
Revision 1.379 by root, Thu Oct 4 23:59:07 2007 UTC