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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.303 by root, Wed Jul 11 15:57:31 2007 UTC vs.
Revision 1.371 by root, Thu Sep 13 16:16:01 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
…		…
167		171
168	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	172	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
169	returns directly I<after> the tick processing (and consequently, can only wake one process	173	returns directly I<after> the tick processing (and consequently, can only wake one process
170	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	174	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
171		175
		176	=item @cf::INVOKE_RESULTS
		177
		178	This array contains the results of the last C<invoke ()> call. When
		179	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
		180	that call.
		181
172	=back	182	=back
173		183
174	=cut	184	=cut
175		185
176	BEGIN {	186	BEGIN {
…		…
180	$msg .= "\n"	190	$msg .= "\n"
181	unless $msg =~ /\n$/;	191	unless $msg =~ /\n$/;
182		192
183	$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;
184		194
185	utf8::encode $msg;
186	LOG llevError, $msg;	195	LOG llevError, $msg;
187	};	196	};
188	}	197	}
189		198
190	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	199	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
…		…
265	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
266	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,
267	for example when the coroutine gets canceled), the lock is automatically	276	for example when the coroutine gets canceled), the lock is automatically
268	returned.	277	returned.
269		278
		279	Locks are not recursive, locking from the same coro twice results in a
		280	deadlocked coro.
		281
270	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
271	uses map_find and cf::map::load uses map_load).	283	uses map_find and cf::map::load uses map_load).
272		284
273	=item $locked = cf::lock_active $string	285	=item $locked = cf::lock_active $string
274		286
275	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.
276		288
277	=cut	289	=cut
278		290
279	our %LOCK;	291	our %LOCK;
		292	our %LOCKER;#d#
280		293
281	sub lock_wait($) {	294	sub lock_wait($) {
282	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#
283		301
284	# wait for lock, if any	302	# wait for lock, if any
285	while ($LOCK{$key}) {	303	while ($LOCK{$key}) {
286	push @{ $LOCK{$key} }, $Coro::current;	304	push @{ $LOCK{$key} }, $Coro::current;
287	Coro::schedule;	305	Coro::schedule;
…		…
293		311
294	# wait, to be sure we are not locked	312	# wait, to be sure we are not locked
295	lock_wait $key;	313	lock_wait $key;
296		314
297	$LOCK{$key} = [];	315	$LOCK{$key} = [];
		316	$LOCKER{$key} = $Coro::current;#d#
298		317
299	Coro::guard {	318	Coro::guard {
		319	delete $LOCKER{$key};#d#
300	# wake up all waiters, to be on the safe side	320	# wake up all waiters, to be on the safe side
301	$_->ready for @{ delete $LOCK{$key} };	321	$_->ready for @{ delete $LOCK{$key} };
302	}	322	}
303	}	323	}
304		324
…		…
314	my $guard = Coro::guard {	334	my $guard = Coro::guard {
315	$TICK_WATCHER->start;	335	$TICK_WATCHER->start;
316	};	336	};
317	$TICK_WATCHER->stop;	337	$TICK_WATCHER->stop;
318	$guard	338	$guard
		339	}
		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	my $signal = new Coro::Signal;
		360
		361	while () {
		362	next_job:
		363	my $avail = cf::till_tick;
		364	if ($avail > 0.01) {
		365	for (0 .. $#SLOT_QUEUE) {
		366	if ($SLOT_QUEUE[$_][0] < $avail) {
		367	my $job = splice @SLOT_QUEUE, $_, 1, ();
		368	$job->[2]->send;
		369	Coro::cede;
		370	goto next_job;
		371	}
		372	}
		373	}
		374
		375	if (@SLOT_QUEUE) {
		376	# we do not use wait_For_tick() as it returns immediately when tick is inactive
		377	push @cf::WAIT_FOR_TICK, $signal;
		378	$signal->wait;
		379	} else {
		380	Coro::schedule;
		381	}
		382	}
		383	};
		384
		385	sub get_slot($;$$) {
		386	my ($time, $pri, $name) = @_;
		387
		388	$time = $TICK * .6 if $time > $TICK * .6;
		389	my $sig = new Coro::Signal;
		390
		391	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
		392	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
		393	$SLOT_QUEUE->ready;
		394	$sig->wait;
319	}	395	}
320		396
321	=item cf::async { BLOCK }	397	=item cf::async { BLOCK }
322		398
323	Currently the same as Coro::async_pool, meaning you cannot use	399	Currently the same as Coro::async_pool, meaning you cannot use
…		…
410	Coro::Storable. May, of course, block. Note that the executed sub may	486	Coro::Storable. May, of course, block. Note that the executed sub may
411	never block itself or use any form of Event handling.	487	never block itself or use any form of Event handling.
412		488
413	=cut	489	=cut
414		490
415	sub _store_scalar {
416	open my $fh, ">", \my $buf
417	or die "fork_call: cannot open fh-to-buf in child : $!";
418	Storable::store_fd $_[0], $fh;
419	close $fh;
420
421	$buf
422	}
423
424	sub fork_call(&@) {	491	sub fork_call(&@) {
425	my ($cb, @args) = @_;	492	my ($cb, @args) = @_;
426		493
427	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC	494	# we seemingly have to make a local copy of the whole thing,
428	# or die "socketpair: $!";	495	# otherwise perl prematurely frees the stuff :/
429	pipe my $fh1, my $fh2	496	# TODO: investigate and fix (likely this will be rather laborious)
430	or die "pipe: $!";
431		497
432	if (my $pid = fork) {	498	my @res = Coro::Util::fork_eval {
433	close $fh2;
434
435	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
436	warn "pst<$res>" unless $res =~ /^pst/;
437	$res = Coro::Storable::thaw $res;
438
439	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
440
441	Carp::confess $$res unless "ARRAY" eq ref $res;
442
443	return wantarray ? @$res : $res->[-1];
444	} else {
445	reset_signals;	499	reset_signals;
446	local $SIG{__WARN__};	500	&$cb
447	local $SIG{__DIE__};	501	}, @args;
448	# just in case, this hack effectively disables event
449	# in the child. cleaner and slower would be canceling all watchers,
450	# but this works for the time being.
451	local $Coro::idle;
452	$Coro::current->prio (Coro::PRIO_MAX);
453		502
454	eval {	503	wantarray ? @res : $res[-1]
455	close $fh1;
456
457	my @res = eval { $cb->(@args) };
458
459	syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
460	close $fh2;
461	};
462
463	warn $@ if $@;
464	_exit 0;
465	}
466	}	504	}
467		505
468	=item $value = cf::db_get $family => $key	506	=item $value = cf::db_get $family => $key
469		507
470	Returns a single value from the environment database.	508	Returns a single value from the environment database.
…		…
472	=item cf::db_put $family => $key => $value	510	=item cf::db_put $family => $key => $value
473		511
474	Stores the given C<$value> in the family. It can currently store binary	512	Stores the given C<$value> in the family. It can currently store binary
475	data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).	513	data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
476		514
		515	=item $db = cf::db_table "name"
		516
		517	Create and/or open a new database table. The string must not be "db" and must be unique
		518	within each server.
		519
477	=cut	520	=cut
		521
		522	sub db_table($) {
		523	my ($name) = @_;
		524	my $db = BDB::db_create $DB_ENV;
		525
		526	eval {
		527	$db->set_flags (BDB::CHKSUM);
		528
		529	utf8::encode $name;
		530	BDB::db_open $db, undef, $name, undef, BDB::BTREE,
		531	BDB::CREATE \| BDB::AUTO_COMMIT, 0666;
		532	cf::cleanup "db_open(db): $!" if $!;
		533	};
		534	cf::cleanup "db_open(db): $@" if $@;
		535
		536	$db
		537	}
478		538
479	our $DB;	539	our $DB;
480		540
481	sub db_init {	541	sub db_init {
482	unless ($DB) {
483	$DB = BDB::db_create $DB_ENV;
484
485	cf::sync_job {	542	cf::sync_job {
486	eval {	543	$DB \|\|= db_table "db";
487	$DB->set_flags (BDB::CHKSUM);
488
489	BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
490	BDB::CREATE \| BDB::AUTO_COMMIT, 0666;
491	cf::cleanup "db_open(db): $!" if $!;
492	};
493	cf::cleanup "db_open(db): $@" if $@;
494	};
495	}	544	};
496	}	545	}
497		546
498	sub db_get($$) {	547	sub db_get($$) {
499	my $key = "$_[0]/$_[1]";	548	my $key = "$_[0]/$_[1]";
500		549
…		…
550	if (1) {	599	if (1) {
551	$md5 =	600	$md5 =
552	join "\x00",	601	join "\x00",
553	$processversion,	602	$processversion,
554	map {	603	map {
555	Coro::cede;	604	cf::cede_to_tick;
556	($src->[$_], Digest::MD5::md5_hex $data[$_])	605	($src->[$_], Digest::MD5::md5_hex $data[$_])
557	} 0.. $#$src;	606	} 0.. $#$src;
558		607
559		608
560	my $dbmd5 = db_get cache => "$id/md5";	609	my $dbmd5 = db_get cache => "$id/md5";
…		…
866	";	915	";
867	die if $@;	916	die if $@;
868	}	917	}
869		918
870	our $override;	919	our $override;
871	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	920	our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
872		921
873	sub override {	922	sub override {
874	$override = 1;	923	$override = 1;
875	@invoke_results = ();	924	@INVOKE_RESULTS = (@_);
876	}	925	}
877		926
878	sub do_invoke {	927	sub do_invoke {
879	my $event = shift;	928	my $event = shift;
880	my $callbacks = shift;	929	my $callbacks = shift;
881		930
882	@invoke_results = ();	931	@INVOKE_RESULTS = ();
883		932
884	local $override;	933	local $override;
885		934
886	for (@$callbacks) {	935	for (@$callbacks) {
887	eval { &{$_->[1]} };	936	eval { &{$_->[1]} };
…		…
904		953
905	Generate an object-specific event with the given arguments.	954	Generate an object-specific event with the given arguments.
906		955
907	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be	956	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
908	removed in future versions), and there is no public API to access override	957	removed in future versions), and there is no public API to access override
909	results (if you must, access C<@cf::invoke_results> directly).	958	results (if you must, access C<@cf::INVOKE_RESULTS> directly).
910		959
911	=back	960	=back
912		961
913	=cut	962	=cut
914		963
915	#############################################################################	964	#############################################################################
916	# object support	965	# object support
		966	#
		967
		968	sub _can_merge {
		969	my ($ob1, $ob2) = @_;
		970
		971	local $Storable::canonical = 1;
		972	my $fob1 = Storable::freeze $ob1;
		973	my $fob2 = Storable::freeze $ob2;
		974
		975	$fob1 eq $fob2
		976	}
917		977
918	sub reattach {	978	sub reattach {
919	# basically do the same as instantiate, without calling instantiate	979	# basically do the same as instantiate, without calling instantiate
920	my ($obj) = @_;	980	my ($obj) = @_;
921		981
…		…
966	);	1026	);
967		1027
968	sub object_freezer_save {	1028	sub object_freezer_save {
969	my ($filename, $rdata, $objs) = @_;	1029	my ($filename, $rdata, $objs) = @_;
970		1030
		1031	my $guard = cf::lock_acquire "io";
		1032
971	sync_job {	1033	sync_job {
972	if (length $$rdata) {	1034	if (length $$rdata) {
		1035	utf8::decode (my $decname = $filename);
973	warn sprintf "saving %s (%d,%d)\n",	1036	warn sprintf "saving %s (%d,%d)\n",
974	$filename, length $$rdata, scalar @$objs;	1037	$decname, length $$rdata, scalar @$objs;
975		1038
976	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {	1039	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {
977	chmod SAVE_MODE, $fh;	1040	chmod SAVE_MODE, $fh;
978	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1041	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
979	aio_fsync $fh if $cf::USE_FSYNC;	1042	aio_fsync $fh if $cf::USE_FSYNC;
…		…
998	}	1061	}
999	} else {	1062	} else {
1000	aio_unlink $filename;	1063	aio_unlink $filename;
1001	aio_unlink "$filename.pst";	1064	aio_unlink "$filename.pst";
1002	}	1065	}
1003	}	1066	};
		1067
		1068	undef $guard;
1004	}	1069	}
1005		1070
1006	sub object_freezer_as_string {	1071	sub object_freezer_as_string {
1007	my ($rdata, $objs) = @_;	1072	my ($rdata, $objs) = @_;
1008		1073
…		…
1013		1078
1014	sub object_thawer_load {	1079	sub object_thawer_load {
1015	my ($filename) = @_;	1080	my ($filename) = @_;
1016		1081
1017	my ($data, $av);	1082	my ($data, $av);
		1083
		1084	my $guard = cf::lock_acquire "io";
1018		1085
1019	(aio_load $filename, $data) >= 0	1086	(aio_load $filename, $data) >= 0
1020	or return;	1087	or return;
1021		1088
1022	unless (aio_stat "$filename.pst") {	1089	unless (aio_stat "$filename.pst") {
1023	(aio_load "$filename.pst", $av) >= 0	1090	(aio_load "$filename.pst", $av) >= 0
1024	or return;	1091	or return;
		1092
		1093	undef $guard;
1025	$av = eval { (Storable::thaw $av)->{objs} };	1094	$av = eval { (Storable::thaw $av)->{objs} };
1026	}	1095	}
1027		1096
		1097	utf8::decode (my $decname = $filename);
1028	warn sprintf "loading %s (%d)\n",	1098	warn sprintf "loading %s (%d,%d)\n",
1029	$filename, length $data, scalar @{$av \|\| []};	1099	$decname, length $data, scalar @{$av \|\| []};
		1100
1030	return ($data, $av);	1101	($data, $av)
1031	}	1102	}
1032		1103
1033	=head2 COMMAND CALLBACKS	1104	=head2 COMMAND CALLBACKS
1034		1105
1035	=over 4	1106	=over 4
…		…
1108	my ($pl, $buf) = @_;	1179	my ($pl, $buf) = @_;
1109		1180
1110	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1181	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1111		1182
1112	if (ref $msg) {	1183	if (ref $msg) {
		1184	my ($type, $reply, @payload) =
		1185	"ARRAY" eq ref $msg
		1186	? @$msg
		1187	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		1188
		1189	my @reply;
		1190
1113	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1191	if (my $cb = $EXTCMD{$type}) {
1114	if (my %reply = $cb->($pl, $msg)) {	1192	@reply = $cb->($pl, @payload);
1115	$pl->ext_reply ($msg->{msgid}, %reply);
1116	}
1117	}	1193	}
		1194
		1195	$pl->ext_reply ($reply, @reply)
		1196	if $reply;
		1197
1118	} else {	1198	} else {
1119	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1199	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1120	}	1200	}
1121		1201
1122	cf::override;	1202	cf::override;
…		…
1212		1292
1213	=head3 cf::player	1293	=head3 cf::player
1214		1294
1215	=over 4	1295	=over 4
1216		1296
		1297	=item cf::player::num_playing
		1298
		1299	Returns the official number of playing players, as per the Crossfire metaserver rules.
		1300
		1301	=cut
		1302
		1303	sub num_playing {
		1304	scalar grep
		1305	$_->ob->map
		1306	&& !$_->hidden
		1307	&& !$_->ob->flag (cf::FLAG_WIZ),
		1308	cf::player::list
		1309	}
		1310
1217	=item cf::player::find $login	1311	=item cf::player::find $login
1218		1312
1219	Returns the given player object, loading it if necessary (might block).	1313	Returns the given player object, loading it if necessary (might block).
1220		1314
1221	=cut	1315	=cut
…		…
1256	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";	1350	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1257	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";	1351	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1258	aio_unlink +(playerdir $login) . "/$login.pl.pst";	1352	aio_unlink +(playerdir $login) . "/$login.pl.pst";
1259	aio_unlink +(playerdir $login) . "/$login.pl";	1353	aio_unlink +(playerdir $login) . "/$login.pl";
1260		1354
1261	my $pl = load_pl path $login	1355	my $f = new_from_file cf::object::thawer path $login
1262	or return;	1356	or return;
		1357
		1358	$f->next;
		1359	my $pl = cf::player::load_pl $f
		1360	or return;
		1361	local $cf::PLAYER_LOADING{$login} = $pl;
		1362	$f->resolve_delayed_derefs;
1263	$cf::PLAYER{$login} = $pl	1363	$cf::PLAYER{$login} = $pl
1264	}	1364	}
1265	}	1365	}
1266	}	1366	}
1267		1367
…		…
1277		1377
1278	aio_mkdir playerdir $pl, 0770;	1378	aio_mkdir playerdir $pl, 0770;
1279	$pl->{last_save} = $cf::RUNTIME;	1379	$pl->{last_save} = $cf::RUNTIME;
1280		1380
1281	$pl->save_pl ($path);	1381	$pl->save_pl ($path);
1282	Coro::cede;	1382	cf::cede_to_tick;
1283	}	1383	}
1284		1384
1285	sub new($) {	1385	sub new($) {
1286	my ($login) = @_;	1386	my ($login) = @_;
1287		1387
…		…
1291	$self->{deny_save} = 1;	1391	$self->{deny_save} = 1;
1292		1392
1293	$cf::PLAYER{$login} = $self;	1393	$cf::PLAYER{$login} = $self;
1294		1394
1295	$self	1395	$self
		1396	}
		1397
		1398	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1399
		1400	=cut
		1401
		1402	sub send_msg {
		1403	my $ns = shift->ns
		1404	or return;
		1405	$ns->send_msg (@_);
1296	}	1406	}
1297		1407
1298	=item $pl->quit_character	1408	=item $pl->quit_character
1299		1409
1300	Nukes the player without looking back. If logged in, the connection will	1410	Nukes the player without looking back. If logged in, the connection will
…		…
1355	or return [];	1465	or return [];
1356		1466
1357	my @logins;	1467	my @logins;
1358		1468
1359	for my $login (@$dirs) {	1469	for my $login (@$dirs) {
		1470	my $path = path $login;
		1471
		1472	# a .pst is a dead give-away for a valid player
		1473	unless (-e "$path.pst") {
1360	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;	1474	my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1361	aio_read $fh, 0, 512, my $buf, 0 or next;	1475	aio_read $fh, 0, 512, my $buf, 0 or next;
1362	$buf !~ /^password -------------$/m or next; # official not-valid tag	1476	$buf !~ /^password -------------$/m or next; # official not-valid tag
		1477	}
1363		1478
1364	utf8::decode $login;	1479	utf8::decode $login;
1365	push @logins, $login;	1480	push @logins, $login;
1366	}	1481	}
1367		1482
…		…
1405	sub expand_cfpod {	1520	sub expand_cfpod {
1406	((my $self), (local $_)) = @_;	1521	((my $self), (local $_)) = @_;
1407		1522
1408	# escape & and <	1523	# escape & and <
1409	s/&/&/g;	1524	s/&/&/g;
1410	s/(?<![BIUGH])</</g;	1525	s/(?<![BIUGHT])</</g;
1411		1526
1412	# this is buggy, it needs to properly take care of nested <'s	1527	# this is buggy, it needs to properly take care of nested <'s
1413		1528
1414	1 while	1529	1 while
1415	# replace B<>, I<>, U<> etc.	1530	# replace B<>, I<>, U<> etc.
1416	s/B<([^\>]*)>/<b>$1<\/b>/	1531	s/B<([^\>]*)>/<b>$1<\/b>/
1417	\|\| s/I<([^\>]*)>/<i>$1<\/i>/	1532	\|\| s/I<([^\>]*)>/<i>$1<\/i>/
1418	\|\| s/U<([^\>]*)>/<u>$1<\/u>/	1533	\|\| s/U<([^\>]*)>/<u>$1<\/u>/
		1534	\|\| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1419	# replace G<male\|female> tags	1535	# replace G<male\|female> tags
1420	\|\| s{G<([^>\|])\\|([^>])>}{	1536	\|\| s{G<([^>\|])\\|([^>])>}{
1421	$self->gender ? $2 : $1	1537	$self->gender ? $2 : $1
1422	}ge	1538	}ge
1423	# replace H<hint text>	1539	# replace H<hint text>
…		…
1444	sub hintmode {	1560	sub hintmode {
1445	$_[0]{hintmode} = $_[1] if @_ > 1;	1561	$_[0]{hintmode} = $_[1] if @_ > 1;
1446	$_[0]{hintmode}	1562	$_[0]{hintmode}
1447	}	1563	}
1448		1564
1449	=item $player->ext_reply ($msgid, %msg)	1565	=item $player->ext_reply ($msgid, @msg)
1450		1566
1451	Sends an ext reply to the player.	1567	Sends an ext reply to the player.
1452		1568
1453	=cut	1569	=cut
1454		1570
1455	sub ext_reply($$%) {	1571	sub ext_reply($$@) {
1456	my ($self, $id, %msg) = @_;	1572	my ($self, $id, @msg) = @_;
1457		1573
1458	$msg{msgid} = $id;	1574	$self->ns->ext_reply ($id, @msg)
1459	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1460	}	1575	}
1461		1576
1462	=item $player->ext_event ($type, %msg)	1577	=item $player->ext_msg ($type, @msg)
1463		1578
1464	Sends an ext event to the client.	1579	Sends an ext event to the client.
1465		1580
1466	=cut	1581	=cut
1467		1582
1468	sub ext_event($$%) {	1583	sub ext_msg($$@) {
1469	my ($self, $type, %msg) = @_;	1584	my ($self, $type, @msg) = @_;
1470		1585
1471	$self->ns->ext_event ($type, %msg);	1586	$self->ns->ext_msg ($type, @msg);
1472	}	1587	}
1473		1588
1474	=head3 cf::region	1589	=head3 cf::region
1475		1590
1476	=over 4	1591	=over 4
…		…
1489	my ($path) = @_;	1604	my ($path) = @_;
1490		1605
1491	my ($match, $specificity);	1606	my ($match, $specificity);
1492		1607
1493	for my $region (list) {	1608	for my $region (list) {
1494	if ($region->match && $path =~ $region->match) {	1609	if ($region->{match} && $path =~ $region->{match}) {
1495	($match, $specificity) = ($region, $region->specificity)	1610	($match, $specificity) = ($region, $region->specificity)
1496	if $region->specificity > $specificity;	1611	if $region->specificity > $specificity;
1497	}	1612	}
1498	}	1613	}
1499		1614
…		…
1619	$self->init; # pass $1 etc.	1734	$self->init; # pass $1 etc.
1620	return $self;	1735	return $self;
1621	}	1736	}
1622	}	1737	}
1623		1738
1624	Carp::carp "unable to resolve path '$path' (base '$base').";	1739	Carp::cluck "unable to resolve path '$path' (base '$base').";
1625	()	1740	()
1626	}	1741	}
1627		1742
1628	sub init {	1743	sub init {
1629	my ($self) = @_;	1744	my ($self) = @_;
…		…
1692		1807
1693	sub load_header_from($) {	1808	sub load_header_from($) {
1694	my ($self, $path) = @_;	1809	my ($self, $path) = @_;
1695		1810
1696	utf8::encode $path;	1811	utf8::encode $path;
1697	#aio_open $path, O_RDONLY, 0	1812	my $f = new_from_file cf::object::thawer $path
1698	# or return;
1699
1700	$self->_load_header ($path)
1701	or return;	1813	or return;
		1814
		1815	$self->_load_header ($f)
		1816	or return;
		1817
		1818	local $MAP_LOADING{$self->{path}} = $self;
		1819	$f->resolve_delayed_derefs;
1702		1820
1703	$self->{load_path} = $path;	1821	$self->{load_path} = $path;
1704		1822
1705	1	1823	1
1706	}	1824	}
…		…
1760	sub find {	1878	sub find {
1761	my ($path, $origin) = @_;	1879	my ($path, $origin) = @_;
1762		1880
1763	$path = normalise $path, $origin && $origin->path;	1881	$path = normalise $path, $origin && $origin->path;
1764		1882
		1883	cf::lock_wait "map_data:$path";#d#remove
1765	cf::lock_wait "map_find:$path";	1884	cf::lock_wait "map_find:$path";
1766		1885
1767	$cf::MAP{$path} \|\| do {	1886	$cf::MAP{$path} \|\| do {
1768	my $guard = cf::lock_acquire "map_find:$path";	1887	my $guard1 = cf::lock_acquire "map_find:$path";
		1888	my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
		1889
1769	my $map = new_from_path cf::map $path	1890	my $map = new_from_path cf::map $path
1770	or return;	1891	or return;
1771		1892
1772	$map->{last_save} = $cf::RUNTIME;	1893	$map->{last_save} = $cf::RUNTIME;
1773		1894
…		…
1775	or return;	1896	or return;
1776		1897
1777	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)	1898	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1778	# doing this can freeze the server in a sync job, obviously	1899	# doing this can freeze the server in a sync job, obviously
1779	#$cf::WAIT_FOR_TICK->wait;	1900	#$cf::WAIT_FOR_TICK->wait;
		1901	undef $guard1;
		1902	undef $guard2;
1780	$map->reset;	1903	$map->reset;
1781	undef $guard;
1782	return find $path;	1904	return find $path;
1783	}	1905	}
1784		1906
1785	$cf::MAP{$path} = $map	1907	$cf::MAP{$path} = $map
1786	}	1908	}
…		…
1795	local $self->{deny_reset} = 1; # loading can take a long time	1917	local $self->{deny_reset} = 1; # loading can take a long time
1796		1918
1797	my $path = $self->{path};	1919	my $path = $self->{path};
1798		1920
1799	{	1921	{
1800	my $guard = cf::lock_acquire "map_load:$path";	1922	my $guard = cf::lock_acquire "map_data:$path";
1801		1923
		1924	return unless $self->valid;
1802	return if $self->in_memory != cf::MAP_SWAPPED;	1925	return unless $self->in_memory == cf::MAP_SWAPPED;
1803		1926
1804	$self->in_memory (cf::MAP_LOADING);	1927	$self->in_memory (cf::MAP_LOADING);
1805		1928
1806	$self->alloc;	1929	$self->alloc;
1807		1930
1808	$self->pre_load;	1931	$self->pre_load;
1809	Coro::cede;	1932	cf::cede_to_tick;
1810		1933
		1934	my $f = new_from_file cf::object::thawer $self->{load_path};
		1935	$f->skip_block;
1811	$self->_load_objects ($self->{load_path}, 1)	1936	$self->_load_objects ($f)
1812	or return;	1937	or return;
1813		1938
1814	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	1939	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1815	if delete $self->{load_original};	1940	if delete $self->{load_original};
1816		1941
1817	if (my $uniq = $self->uniq_path) {	1942	if (my $uniq = $self->uniq_path) {
1818	utf8::encode $uniq;	1943	utf8::encode $uniq;
1819	if (aio_open $uniq, O_RDONLY, 0) {	1944	unless (aio_stat $uniq) {
		1945	if (my $f = new_from_file cf::object::thawer $uniq) {
1820	$self->clear_unique_items;	1946	$self->clear_unique_items;
1821	$self->_load_objects ($uniq, 0);	1947	$self->_load_objects ($f);
		1948	$f->resolve_delayed_derefs;
		1949	}
1822	}	1950	}
1823	}	1951	}
1824		1952
1825	Coro::cede;	1953	$f->resolve_delayed_derefs;
		1954
		1955	cf::cede_to_tick;
1826	# now do the right thing for maps	1956	# now do the right thing for maps
1827	$self->link_multipart_objects;	1957	$self->link_multipart_objects;
1828	$self->difficulty ($self->estimate_difficulty)	1958	$self->difficulty ($self->estimate_difficulty)
1829	unless $self->difficulty;	1959	unless $self->difficulty;
1830	Coro::cede;	1960	cf::cede_to_tick;
1831		1961
1832	unless ($self->{deny_activate}) {	1962	unless ($self->{deny_activate}) {
1833	$self->decay_objects;	1963	$self->decay_objects;
1834	$self->fix_auto_apply;	1964	$self->fix_auto_apply;
1835	$self->update_buttons;	1965	$self->update_buttons;
1836	Coro::cede;	1966	cf::cede_to_tick;
1837	$self->set_darkness_map;	1967	$self->set_darkness_map;
1838	Coro::cede;	1968	cf::cede_to_tick;
1839	$self->activate;	1969	$self->activate;
1840	}	1970	}
		1971
		1972	$self->{last_save} = $cf::RUNTIME;
		1973	$self->last_access ($cf::RUNTIME);
1841		1974
1842	$self->in_memory (cf::MAP_IN_MEMORY);	1975	$self->in_memory (cf::MAP_IN_MEMORY);
1843	}	1976	}
1844		1977
1845	$self->post_load;	1978	$self->post_load;
…		…
1856		1989
1857	$self	1990	$self
1858	}	1991	}
1859		1992
1860	# find and load all maps in the 3x3 area around a map	1993	# find and load all maps in the 3x3 area around a map
1861	sub load_diag {	1994	sub load_neighbours {
1862	my ($map) = @_;	1995	my ($map) = @_;
1863		1996
1864	my @diag; # diagonal neighbours	1997	my @neigh; # diagonal neighbours
1865		1998
1866	for (0 .. 3) {	1999	for (0 .. 3) {
1867	my $neigh = $map->tile_path ($_)	2000	my $neigh = $map->tile_path ($_)
1868	or next;	2001	or next;
1869	$neigh = find $neigh, $map	2002	$neigh = find $neigh, $map
1870	or next;	2003	or next;
1871	$neigh->load;	2004	$neigh->load;
1872		2005
		2006	push @neigh,
1873	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],	2007	[$neigh->tile_path (($_ + 3) % 4), $neigh],
1874	[$neigh->tile_path (($_ + 1) % 4), $neigh];	2008	[$neigh->tile_path (($_ + 1) % 4), $neigh];
1875	}	2009	}
1876		2010
1877	for (@diag) {	2011	for (grep defined $_->[0], @neigh) {
		2012	my ($path, $origin) = @$_;
1878	my $neigh = find @$_	2013	my $neigh = find $path, $origin
1879	or next;	2014	or next;
1880	$neigh->load;	2015	$neigh->load;
1881	}	2016	}
1882	}	2017	}
1883		2018
…		…
1888	}	2023	}
1889		2024
1890	sub do_load_sync {	2025	sub do_load_sync {
1891	my ($map) = @_;	2026	my ($map) = @_;
1892		2027
		2028	cf::LOG cf::llevDebug \| cf::logBacktrace, "do_load_sync"
		2029	if $Coro::current == $Coro::main;
		2030
1893	cf::sync_job { $map->load };	2031	cf::sync_job { $map->load };
1894	}	2032	}
1895		2033
1896	our %MAP_PREFETCH;	2034	our %MAP_PREFETCH;
1897	our $MAP_PREFETCHER = undef;	2035	our $MAP_PREFETCHER = undef;
1898		2036
1899	sub find_async {	2037	sub find_async {
1900	my ($path, $origin) = @_;	2038	my ($path, $origin, $load) = @_;
1901		2039
1902	$path = normalise $path, $origin && $origin->{path};	2040	$path = normalise $path, $origin && $origin->{path};
1903		2041
1904	if (my $map = $cf::MAP{$path}) {	2042	if (my $map = $cf::MAP{$path}) {
1905	return $map if $map->in_memory == cf::MAP_IN_MEMORY;	2043	return $map if !$load \|\| $map->in_memory == cf::MAP_IN_MEMORY;
1906	}	2044	}
1907		2045
1908	undef $MAP_PREFETCH{$path};	2046	$MAP_PREFETCH{$path} \|= $load;
		2047
1909	$MAP_PREFETCHER \|\|= cf::async {	2048	$MAP_PREFETCHER \|\|= cf::async {
1910	while (%MAP_PREFETCH) {	2049	while (%MAP_PREFETCH) {
1911	for my $path (keys %MAP_PREFETCH) {	2050	while (my ($k, $v) = each %MAP_PREFETCH) {
1912	my $map = find $path	2051	if (my $map = find $k) {
1913	or next;
1914	$map->load;	2052	$map->load if $v;
		2053	}
1915		2054
1916	delete $MAP_PREFETCH{$path};	2055	delete $MAP_PREFETCH{$k};
1917	}	2056	}
1918	}	2057	}
1919	undef $MAP_PREFETCHER;	2058	undef $MAP_PREFETCHER;
1920	};	2059	};
1921	$MAP_PREFETCHER->prio (6);	2060	$MAP_PREFETCHER->prio (6);
…		…
1924	}	2063	}
1925		2064
1926	sub save {	2065	sub save {
1927	my ($self) = @_;	2066	my ($self) = @_;
1928		2067
1929	my $lock = cf::lock_acquire "map_data:" . $self->path;	2068	my $lock = cf::lock_acquire "map_data:$self->{path}";
1930		2069
1931	$self->{last_save} = $cf::RUNTIME;	2070	$self->{last_save} = $cf::RUNTIME;
1932		2071
1933	return unless $self->dirty;	2072	return unless $self->dirty;
1934		2073
…		…
1957	my ($self) = @_;	2096	my ($self) = @_;
1958		2097
1959	# save first because save cedes	2098	# save first because save cedes
1960	$self->save;	2099	$self->save;
1961		2100
1962	my $lock = cf::lock_acquire "map_data:" . $self->path;	2101	my $lock = cf::lock_acquire "map_data:$self->{path}";
1963		2102
1964	return if $self->players;	2103	return if $self->players;
1965	return if $self->in_memory != cf::MAP_IN_MEMORY;	2104	return if $self->in_memory != cf::MAP_IN_MEMORY;
1966	return if $self->{deny_save};	2105	return if $self->{deny_save};
1967		2106
		2107	$self->in_memory (cf::MAP_SWAPPED);
		2108
		2109	$self->deactivate;
		2110	$_->clear_links_to ($self) for values %cf::MAP;
1968	$self->clear;	2111	$self->clear;
1969	$self->in_memory (cf::MAP_SWAPPED);
1970	}	2112	}
1971		2113
1972	sub reset_at {	2114	sub reset_at {
1973	my ($self) = @_;	2115	my ($self) = @_;
1974		2116
…		…
2006	if $uniq;	2148	if $uniq;
2007	}	2149	}
2008		2150
2009	delete $cf::MAP{$self->path};	2151	delete $cf::MAP{$self->path};
2010		2152
		2153	$self->deactivate;
		2154	$_->clear_links_to ($self) for values %cf::MAP;
2011	$self->clear;	2155	$self->clear;
2012
2013	$_->clear_links_to ($self) for values %cf::MAP;
2014		2156
2015	$self->unlink_save;	2157	$self->unlink_save;
2016	$self->destroy;	2158	$self->destroy;
2017	}	2159	}
2018		2160
2019	my $nuke_counter = "aaaa";	2161	my $nuke_counter = "aaaa";
2020		2162
2021	sub nuke {	2163	sub nuke {
2022	my ($self) = @_;	2164	my ($self) = @_;
2023		2165
		2166	{
		2167	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2168
2024	delete $cf::MAP{$self->path};	2169	delete $cf::MAP{$self->path};
2025		2170
2026	$self->unlink_save;	2171	$self->unlink_save;
2027		2172
2028	bless $self, "cf::map";	2173	bless $self, "cf::map";
2029	delete $self->{deny_reset};	2174	delete $self->{deny_reset};
2030	$self->{deny_save} = 1;	2175	$self->{deny_save} = 1;
2031	$self->reset_timeout (1);	2176	$self->reset_timeout (1);
2032	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2177	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2033		2178
2034	$cf::MAP{$self->path} = $self;	2179	$cf::MAP{$self->path} = $self;
		2180	}
2035		2181
2036	$self->reset; # polite request, might not happen	2182	$self->reset; # polite request, might not happen
2037	}	2183	}
2038		2184
2039	=item $maps = cf::map::tmp_maps	2185	=item $maps = cf::map::tmp_maps
…		…
2115		2261
2116	sub inv_recursive {	2262	sub inv_recursive {
2117	inv_recursive_ inv $_[0]	2263	inv_recursive_ inv $_[0]
2118	}	2264	}
2119		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	# temporary compatibility#TODO#remove
		2281	$ref =~ s{^<}{player/<};
		2282
		2283	if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
		2284	my ($uuid, $name) = ($1, $2);
		2285	my $pl = $cf::PLAYER_LOADING{$name} \|\| cf::player::find $name
		2286	or return;
		2287	$pl->ob->uuid eq $uuid
		2288	or return;
		2289
		2290	$pl->ob
		2291	} else {
		2292	warn "$ref: cannot resolve object reference\n";
		2293	undef
		2294	}
		2295	}
		2296
2120	package cf;	2297	package cf;
2121		2298
2122	=back	2299	=back
2123		2300
2124	=head3 cf::object::player	2301	=head3 cf::object::player
…		…
2146		2323
2147	} else {	2324	} else {
2148	my $pl = $self->contr;	2325	my $pl = $self->contr;
2149		2326
2150	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2327	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2151	my $diag = $pl->{npc_dialog};	2328	my $dialog = $pl->{npc_dialog};
2152	$diag->{pl}->ext_reply (	2329	$dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2153	$diag->{id},
2154	msgtype => "reply",
2155	msg => $diag->{pl}->expand_cfpod ($msg),
2156	add_topics => []
2157	);
2158		2330
2159	} else {	2331	} else {
2160	$msg = $npc->name . " says: $msg" if $npc;	2332	$msg = $npc->name . " says: $msg" if $npc;
2161	$self->message ($msg, $flags);	2333	$self->message ($msg, $flags);
2162	}	2334	}
2163	}	2335	}
		2336	}
		2337
		2338	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2339
		2340	=cut
		2341
		2342	sub cf::object::send_msg {
		2343	my $pl = shift->contr
		2344	or return;
		2345	$pl->send_msg (@_);
2164	}	2346	}
2165		2347
2166	=item $player_object->may ("access")	2348	=item $player_object->may ("access")
2167		2349
2168	Returns wether the given player is authorized to access resource "access"	2350	Returns wether the given player is authorized to access resource "access"
…		…
2247	# use -1 or undef as default coordinates, not 0, 0	2429	# use -1 or undef as default coordinates, not 0, 0
2248	($x, $y) = ($map->enter_x, $map->enter_y)	2430	($x, $y) = ($map->enter_x, $map->enter_y)
2249	if $x <=0 && $y <= 0;	2431	if $x <=0 && $y <= 0;
2250		2432
2251	$map->load;	2433	$map->load;
2252	$map->load_diag;	2434	$map->load_neighbours;
2253		2435
2254	return unless $self->contr->active;	2436	return unless $self->contr->active;
2255	$self->activate_recursive;	2437	$self->activate_recursive;
2256		2438
2257	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2439	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2258	$self->enter_map ($map, $x, $y);	2440	$self->enter_map ($map, $x, $y);
2259	}	2441	}
2260		2442
2261	=item $player_object->goto ($path, $x, $y[, $check->($map)])	2443	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2262		2444
2263	Moves the player to the given map-path and coordinates by first freezing	2445	Moves the player to the given map-path and coordinates by first freezing
2264	her, loading and preparing them map, calling the provided $check callback	2446	her, loading and preparing them map, calling the provided $check callback
2265	that has to return the map if sucecssful, and then unfreezes the player on	2447	that has to return the map if sucecssful, and then unfreezes the player on
2266	the new (success) or old (failed) map position.	2448	the new (success) or old (failed) map position. In either case, $done will
		2449	be called at the end of this process.
2267		2450
2268	=cut	2451	=cut
2269		2452
2270	our $GOTOGEN;	2453	our $GOTOGEN;
2271		2454
2272	sub cf::object::player::goto {	2455	sub cf::object::player::goto {
2273	my ($self, $path, $x, $y, $check) = @_;	2456	my ($self, $path, $x, $y, $check, $done) = @_;
2274		2457
2275	# do generation counting so two concurrent goto's will be executed in-order	2458	# do generation counting so two concurrent goto's will be executed in-order
2276	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2459	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2277		2460
2278	$self->enter_link;	2461	$self->enter_link;
2279		2462
2280	(async {	2463	(async {
		2464	# *tag paths override both path and x\|y
		2465	if ($path =~ /^\(.)$/) {
		2466	if (my @obs = grep $_->map, ext::map_tags::find $1) {
		2467	my $ob = $obs[rand @obs];
		2468
		2469	# see if we actually can go there
		2470	if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
		2471	$ob = $obs[rand @obs];
		2472	} else {
		2473	$self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE \| cf::NDI_RED);
		2474	}
		2475	# else put us there anyways for now #d#
		2476
		2477	($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
		2478	} else {
		2479	($path, $x, $y) = (undef, undef, undef);
		2480	}
		2481	}
		2482
2281	my $map = eval {	2483	my $map = eval {
2282	my $map = cf::map::find $path;	2484	my $map = defined $path ? cf::map::find $path : undef;
2283		2485
2284	if ($map) {	2486	if ($map) {
2285	$map = $map->customise_for ($self);	2487	$map = $map->customise_for ($self);
2286	$map = $check->($map) if $check && $map;	2488	$map = $check->($map) if $check && $map;
2287	} else {	2489	} else {
2288	$self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE \| cf::NDI_RED);	2490	$self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE \| cf::NDI_RED);
2289	}	2491	}
2290		2492
2291	$map	2493	$map
2292	};	2494	};
2293		2495
…		…
2298		2500
2299	if ($gen == $self->{_goto_generation}) {	2501	if ($gen == $self->{_goto_generation}) {
2300	delete $self->{_goto_generation};	2502	delete $self->{_goto_generation};
2301	$self->leave_link ($map, $x, $y);	2503	$self->leave_link ($map, $x, $y);
2302	}	2504	}
		2505
		2506	$done->() if $done;
2303	})->prio (1);	2507	})->prio (1);
2304	}	2508	}
2305		2509
2306	=item $player_object->enter_exit ($exit_object)	2510	=item $player_object->enter_exit ($exit_object)
2307		2511
…		…
2416		2620
2417	utf8::encode $text;	2621	utf8::encode $text;
2418	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2622	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2419	}	2623	}
2420		2624
2421	=item $client->send_msg ($color, $type, $msg, [extra...])	2625	=item $client->send_msg ($channel, $msg, $color, [extra...])
2422		2626
2423	Send a drawinfo or msg packet to the client, formatting the msg for the	2627	Send a drawinfo or msg packet to the client, formatting the msg for the
2424	client if neccessary. C<$type> should be a string identifying the type of	2628	client if neccessary. C<$type> should be a string identifying the type of
2425	the message, with C<log> being the default. If C<$color> is negative, suppress	2629	the message, with C<log> being the default. If C<$color> is negative, suppress
2426	the message unless the client supports the msg packet.	2630	the message unless the client supports the msg packet.
2427		2631
2428	=cut	2632	=cut
2429		2633
		2634	our %CHANNEL = (
		2635	"c/identify" => {
		2636	id => "identify",
		2637	title => "Identify",
		2638	reply => undef,
		2639	tooltip => "Items recently identified",
		2640	},
		2641	"c/examine" => {
		2642	id => "examine",
		2643	title => "Examine",
		2644	reply => undef,
		2645	tooltip => "Signs and other items you examined",
		2646	},
		2647	);
		2648
2430	sub cf::client::send_msg {	2649	sub cf::client::send_msg {
2431	my ($self, $color, $type, $msg, @extra) = @_;	2650	my ($self, $channel, $msg, $color, @extra) = @_;
2432		2651
2433	$msg = $self->pl->expand_cfpod ($msg);	2652	$msg = $self->pl->expand_cfpod ($msg);
2434		2653
		2654	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2655
		2656	# check predefined channels, for the benefit of C
		2657	$channel = $CHANNEL{$channel} if $CHANNEL{$channel};
		2658
		2659	if (ref $channel) {
		2660	# send meta info to client, if not yet sent
		2661	unless (exists $self->{channel}{$channel->{id}}) {
		2662	$self->{channel}{$channel->{id}} = $channel;
		2663	$self->ext_msg (channel_info => $channel)
		2664	if $self->can_msg;
		2665	}
		2666
		2667	$channel = $channel->{id};
		2668	}
		2669
2435	return unless @extra \|\| length $msg;	2670	return unless @extra \|\| length $msg;
2436		2671
2437	if ($self->can_msg) {	2672	if ($self->can_msg) {
		2673	# default colour, mask it out
		2674	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2675	if $color & cf::NDI_DEF;
		2676
2438	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));	2677	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2678	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2439	} else {	2679	} else {
2440	# replace some tags by gcfclient-compatible ones
2441	for ($msg) {
2442	1 while
2443	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2444	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2445	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2446	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2447	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2448	}
2449
2450	if ($color >= 0) {	2680	if ($color >= 0) {
		2681	# replace some tags by gcfclient-compatible ones
		2682	for ($msg) {
		2683	1 while
		2684	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2685	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2686	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2687	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2688	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2689	}
		2690
		2691	$color &= cf::NDI_COLOR_MASK;
		2692
		2693	utf8::encode $msg;
		2694
2451	if (0 && $msg =~ /\[/) {	2695	if (0 && $msg =~ /\[/) {
		2696	# COMMAND/INFO
2452	$self->send_packet ("drawextinfo $color 4 0 $msg")	2697	$self->send_packet ("drawextinfo $color 10 8 $msg")
2453	} else {	2698	} else {
2454	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2699	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2455	$self->send_packet ("drawinfo $color $msg")	2700	$self->send_packet ("drawinfo $color $msg")
2456	}	2701	}
2457	}	2702	}
2458	}	2703	}
2459	}	2704	}
2460		2705
2461	=item $client->ext_event ($type, %msg)	2706	=item $client->ext_msg ($type, @msg)
2462		2707
2463	Sends an ext event to the client.	2708	Sends an ext event to the client.
2464		2709
2465	=cut	2710	=cut
2466		2711
2467	sub cf::client::ext_event($$%) {	2712	sub cf::client::ext_msg($$@) {
2468	my ($self, $type, %msg) = @_;	2713	my ($self, $type, @msg) = @_;
2469		2714
		2715	if ($self->extcmd == 2) {
		2716	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2717	} elsif ($self->extcmd == 1) { # TODO: remove
2470	$msg{msgtype} = "event_$type";	2718	push @msg, msgtype => "event_$type";
2471	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2719	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2720	}
		2721	}
		2722
		2723	=item $client->ext_reply ($msgid, @msg)
		2724
		2725	Sends an ext reply to the client.
		2726
		2727	=cut
		2728
		2729	sub cf::client::ext_reply($$@) {
		2730	my ($self, $id, @msg) = @_;
		2731
		2732	if ($self->extcmd == 2) {
		2733	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
		2734	} elsif ($self->extcmd == 1) {
		2735	#TODO: version 1, remove
		2736	unshift @msg, msgtype => "reply", msgid => $id;
		2737	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2738	}
2472	}	2739	}
2473		2740
2474	=item $success = $client->query ($flags, "text", \&cb)	2741	=item $success = $client->query ($flags, "text", \&cb)
2475		2742
2476	Queues a query to the client, calling the given callback with	2743	Queues a query to the client, calling the given callback with
…		…
2531	my ($ns, $buf) = @_;	2798	my ($ns, $buf) = @_;
2532		2799
2533	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2800	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2534		2801
2535	if (ref $msg) {	2802	if (ref $msg) {
		2803	my ($type, $reply, @payload) =
		2804	"ARRAY" eq ref $msg
		2805	? @$msg
		2806	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2807
		2808	my @reply;
		2809
2536	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2810	if (my $cb = $EXTICMD{$type}) {
2537	if (my %reply = $cb->($ns, $msg)) {	2811	@reply = $cb->($ns, @payload);
2538	$reply{msgid} = $msg->{msgid};
2539	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2540	}
2541	}	2812	}
		2813
		2814	$ns->ext_reply ($reply, @reply)
		2815	if $reply;
		2816
2542	} else {	2817	} else {
2543	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2818	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2544	}	2819	}
2545		2820
2546	cf::override;	2821	cf::override;
…		…
2593	our $safe = new Safe "safe";	2868	our $safe = new Safe "safe";
2594	our $safe_hole = new Safe::Hole;	2869	our $safe_hole = new Safe::Hole;
2595		2870
2596	$SIG{FPE} = 'IGNORE';	2871	$SIG{FPE} = 'IGNORE';
2597		2872
2598	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2873	$safe->permit_only (Opcode::opset qw(
		2874	:base_core :base_mem :base_orig :base_math
		2875	grepstart grepwhile mapstart mapwhile
		2876	sort time
		2877	));
2599		2878
2600	# here we export the classes and methods available to script code	2879	# here we export the classes and methods available to script code
2601		2880
2602	=pod	2881	=pod
2603		2882
2604	The following functions and methods are available within a safe environment:	2883	The following functions and methods are available within a safe environment:
2605		2884
2606	cf::object	2885	cf::object
2607	contr pay_amount pay_player map x y force_find force_add	2886	contr pay_amount pay_player map x y force_find force_add
2608	insert remove	2887	insert remove name archname title slaying race decrease_ob_nr
2609		2888
2610	cf::object::player	2889	cf::object::player
2611	player	2890	player
2612		2891
2613	cf::player	2892	cf::player
…		…
2618		2897
2619	=cut	2898	=cut
2620		2899
2621	for (	2900	for (
2622	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2901	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2902	insert remove inv name archname title slaying race
2623	insert remove)],	2903	decrease_ob_nr)],
2624	["cf::object::player" => qw(player)],	2904	["cf::object::player" => qw(player)],
2625	["cf::player" => qw(peaceful)],	2905	["cf::player" => qw(peaceful)],
2626	["cf::map" => qw(trigger)],	2906	["cf::map" => qw(trigger)],
2627	) {	2907	) {
2628	no strict 'refs';	2908	no strict 'refs';
…		…
2704	# the server's init and main functions	2984	# the server's init and main functions
2705		2985
2706	sub load_facedata($) {	2986	sub load_facedata($) {
2707	my ($path) = @_;	2987	my ($path) = @_;
2708		2988
		2989	# HACK to clear player env face cache, we need some signal framework
		2990	# for this (global event?)
		2991	%ext::player_env::MUSIC_FACE_CACHE = ();
		2992
		2993	my $enc = JSON::XS->new->utf8->canonical->relaxed;
		2994
2709	warn "loading facedata from $path\n";	2995	warn "loading facedata from $path\n";
2710		2996
2711	my $facedata;	2997	my $facedata;
2712	0 < aio_load $path, $facedata	2998	0 < aio_load $path, $facedata
2713	or die "$path: $!";	2999	or die "$path: $!";
2714		3000
2715	$facedata = Coro::Storable::thaw $facedata;	3001	$facedata = Coro::Storable::thaw $facedata;
2716		3002
2717	$facedata->{version} == 2	3003	$facedata->{version} == 2
2718	or cf::cleanup "$path: version mismatch, cannot proceed.";	3004	or cf::cleanup "$path: version mismatch, cannot proceed.";
		3005
		3006	# patch in the exptable
		3007	$facedata->{resource}{"res/exp_table"} = {
		3008	type => FT_RSRC,
		3009	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
		3010	};
		3011	cf::cede_to_tick;
2719		3012
2720	{	3013	{
2721	my $faces = $facedata->{faceinfo};	3014	my $faces = $facedata->{faceinfo};
2722		3015
2723	while (my ($face, $info) = each %$faces) {	3016	while (my ($face, $info) = each %$faces) {
2724	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	3017	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2725	cf::face::set_visibility $idx, $info->{visibility};	3018	cf::face::set_visibility $idx, $info->{visibility};
2726	cf::face::set_magicmap $idx, $info->{magicmap};	3019	cf::face::set_magicmap $idx, $info->{magicmap};
2727	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	3020	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2728	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	3021	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2729		3022
2730	cf::cede_to_tick;	3023	cf::cede_to_tick;
2731	}	3024	}
2732		3025
2733	while (my ($face, $info) = each %$faces) {	3026	while (my ($face, $info) = each %$faces) {
…		…
2758		3051
2759	{	3052	{
2760	# TODO: for gcfclient pleasure, we should give resources	3053	# TODO: for gcfclient pleasure, we should give resources
2761	# that gcfclient doesn't grok a >10000 face index.	3054	# that gcfclient doesn't grok a >10000 face index.
2762	my $res = $facedata->{resource};	3055	my $res = $facedata->{resource};
2763	my $enc = JSON::XS->new->utf8->canonical;	3056
		3057	my $soundconf = delete $res->{"res/sound.conf"};
2764		3058
2765	while (my ($name, $info) = each %$res) {	3059	while (my ($name, $info) = each %$res) {
2766	my $meta = $enc->encode ({
2767	name => $name,
2768	type => $info->{type},
2769	copyright => $info->{copyright}, #TODO#
2770	});
2771	my $data = pack "(w/a)", $meta, $info->{data};
2772	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2773
2774	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	3060	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		3061	my $data;
		3062
		3063	if ($info->{type} & 1) {
		3064	# prepend meta info
		3065
		3066	my $meta = $enc->encode ({
		3067	name => $name,
		3068	%{ $info->{meta} \|\| {} },
		3069	});
		3070
		3071	$data = pack "(w/a)", $meta, $info->{data};
		3072	} else {
		3073	$data = $info->{data};
		3074	}
		3075
		3076	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2775	cf::face::set_type $idx, 1;	3077	cf::face::set_type $idx, $info->{type};
2776	cf::face::set_data $idx, 0, $data, $chk;
2777		3078
2778	cf::cede_to_tick;	3079	cf::cede_to_tick;
2779	}	3080	}
		3081
		3082	if ($soundconf) {
		3083	$soundconf = $enc->decode (delete $soundconf->{data});
		3084
		3085	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3086	my $sound = $soundconf->{compat}[$_]
		3087	or next;
		3088
		3089	my $face = cf::face::find "sound/$sound->[1]";
		3090	cf::sound::set $sound->[0] => $face;
		3091	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3092	}
		3093
		3094	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3095	my $face = cf::face::find "sound/$v";
		3096	cf::sound::set $k => $face;
		3097	}
		3098	}
2780	}	3099	}
2781		3100
2782	1	3101	1
2783	}	3102	}
2784		3103
		3104	register_exticmd fx_want => sub {
		3105	my ($ns, $want) = @_;
		3106
		3107	while (my ($k, $v) = each %$want) {
		3108	$ns->fx_want ($k, $v);
		3109	}
		3110	};
		3111
2785	sub reload_regions {	3112	sub reload_regions {
		3113	# HACK to clear player env face cache, we need some signal framework
		3114	# for this (global event?)
		3115	%ext::player_env::MUSIC_FACE_CACHE = ();
		3116
2786	load_resource_file "$MAPDIR/regions"	3117	load_resource_file "$MAPDIR/regions"
2787	or die "unable to load regions file\n";	3118	or die "unable to load regions file\n";
		3119
		3120	for (cf::region::list) {
		3121	$_->{match} = qr/$_->{match}/
		3122	if exists $_->{match};
		3123	}
2788	}	3124	}
2789		3125
2790	sub reload_facedata {	3126	sub reload_facedata {
2791	load_facedata "$DATADIR/facedata"	3127	load_facedata "$DATADIR/facedata"
2792	or die "unable to load facedata\n";	3128	or die "unable to load facedata\n";
…		…
2821		3157
2822	sub init {	3158	sub init {
2823	reload_resources;	3159	reload_resources;
2824	}	3160	}
2825		3161
2826	sub cfg_load {	3162	sub reload_config {
2827	open my $fh, "<:utf8", "$CONFDIR/config"	3163	open my $fh, "<:utf8", "$CONFDIR/config"
2828	or return;	3164	or return;
2829		3165
2830	local $/;	3166	local $/;
2831	*CFG = YAML::Syck::Load <$fh>;	3167	*CFG = YAML::Syck::Load <$fh>;
…		…
2851	(async {	3187	(async {
2852	Event::one_event;	3188	Event::one_event;
2853	})->prio (Coro::PRIO_MAX);	3189	})->prio (Coro::PRIO_MAX);
2854	};	3190	};
2855		3191
2856	cfg_load;	3192	reload_config;
2857	db_init;	3193	db_init;
2858	load_extensions;	3194	load_extensions;
2859		3195
2860	$TICK_WATCHER->start;	3196	$TICK_WATCHER->start;
2861	Event::loop;	3197	Event::loop;
…		…
3054	warn "reloading cf.pm";	3390	warn "reloading cf.pm";
3055	require cf;	3391	require cf;
3056	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3392	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3057		3393
3058	warn "loading config and database again";	3394	warn "loading config and database again";
3059	cf::cfg_load;	3395	cf::reload_config;
3060		3396
3061	warn "loading extensions";	3397	warn "loading extensions";
3062	cf::load_extensions;	3398	cf::load_extensions;
3063		3399
3064	warn "reattaching attachments to objects/players";	3400	warn "reattaching attachments to objects/players";
…		…
3129	my $signal = new Coro::Signal;	3465	my $signal = new Coro::Signal;
3130	push @WAIT_FOR_TICK_BEGIN, $signal;	3466	push @WAIT_FOR_TICK_BEGIN, $signal;
3131	$signal->wait;	3467	$signal->wait;
3132	}	3468	}
3133		3469
3134	my $min = 1e6;#d#
3135	my $avg = 10;
3136	$TICK_WATCHER = Event->timer (	3470	$TICK_WATCHER = Event->timer (
3137	reentrant => 0,	3471	reentrant => 0,
3138	parked => 1,	3472	parked => 1,
3139	prio => 0,	3473	prio => 0,
3140	at => $NEXT_TICK \|\| $TICK,	3474	at => $NEXT_TICK \|\| $TICK,
…		…
3148		3482
3149	$NOW = $tick_start = Event::time;	3483	$NOW = $tick_start = Event::time;
3150		3484
3151	cf::server_tick; # one server iteration	3485	cf::server_tick; # one server iteration
3152		3486
3153	0 && sync_job {#d#
3154	for(1..10) {
3155	my $t = Event::time;
3156	my $map = my $map = new_from_path cf::map "/tmp/x.map"
3157	or die;
3158
3159	$map->width (50);
3160	$map->height (50);
3161	$map->alloc;
3162	$map->_load_objects ("/tmp/x.map", 1);
3163	my $t = Event::time - $t;
3164
3165	#next unless $t < 0.0013;#d#
3166	if ($t < $min) {
3167	$min = $t;
3168	}
3169	$avg = $avg * 0.99 + $t * 0.01;
3170	}
3171	warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3172	exit 0;
3173	# 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3174	};
3175
3176	$RUNTIME += $TICK;	3487	$RUNTIME += $TICK;
3177	$NEXT_TICK += $TICK;	3488	$NEXT_TICK += $TICK;
3178		3489
3179	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3490	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3180	$NEXT_RUNTIME_WRITE = $NOW + 10;	3491	$NEXT_RUNTIME_WRITE = $NOW + 10;
…		…
3182	write_runtime	3493	write_runtime
3183	or warn "ERROR: unable to write runtime file: $!";	3494	or warn "ERROR: unable to write runtime file: $!";
3184	};	3495	};
3185	}	3496	}
3186		3497
3187	# my $AFTER = Event::time;
3188	# warn $AFTER - $NOW;#d#
3189
3190	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3498	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3191	$sig->send;	3499	$sig->send;
3192	}	3500	}
3193	while (my $sig = shift @WAIT_FOR_TICK) {	3501	while (my $sig = shift @WAIT_FOR_TICK) {
3194	$sig->send;	3502	$sig->send;
…		…
3204		3512
3205	$LOAD = ($NOW - $tick_start) / $TICK;	3513	$LOAD = ($NOW - $tick_start) / $TICK;
3206	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	3514	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3207		3515
3208	_post_tick;	3516	_post_tick;
3209
3210
3211	},	3517	},
3212	);	3518	);
3213		3519
3214	{	3520	{
		3521	BDB::min_parallel 8;
3215	BDB::max_poll_time $TICK * 0.1;	3522	BDB::max_poll_time $TICK * 0.1;
3216	$BDB_POLL_WATCHER = Event->io (	3523	$BDB_POLL_WATCHER = Event->io (
3217	reentrant => 0,	3524	reentrant => 0,
3218	fd => BDB::poll_fileno,	3525	fd => BDB::poll_fileno,
3219	poll => 'r',	3526	poll => 'r',
3220	prio => 0,	3527	prio => 0,
3221	data => WF_AUTOCANCEL,	3528	data => WF_AUTOCANCEL,
3222	cb => \&BDB::poll_cb,	3529	cb => \&BDB::poll_cb,
3223	);	3530	);
3224	BDB::min_parallel 8;
3225		3531
3226	BDB::set_sync_prepare {	3532	BDB::set_sync_prepare {
3227	my $status;	3533	my $status;
3228	my $current = $Coro::current;	3534	my $current = $Coro::current;
3229	(	3535	(
…		…
3238	)	3544	)
3239	};	3545	};
3240		3546
3241	unless ($DB_ENV) {	3547	unless ($DB_ENV) {
3242	$DB_ENV = BDB::db_env_create;	3548	$DB_ENV = BDB::db_env_create;
		3549	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC
		3550	\| BDB::LOG_AUTOREMOVE, 1);
		3551	$DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
		3552	$DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3243		3553
3244	cf::sync_job {	3554	cf::sync_job {
3245	eval {	3555	eval {
3246	BDB::db_env_open	3556	BDB::db_env_open
3247	$DB_ENV,	3557	$DB_ENV,
…		…
3249	BDB::INIT_LOCK \| BDB::INIT_LOG \| BDB::INIT_MPOOL \| BDB::INIT_TXN	3559	BDB::INIT_LOCK \| BDB::INIT_LOG \| BDB::INIT_MPOOL \| BDB::INIT_TXN
3250	\| BDB::RECOVER \| BDB::REGISTER \| BDB::USE_ENVIRON \| BDB::CREATE,	3560	\| BDB::RECOVER \| BDB::REGISTER \| BDB::USE_ENVIRON \| BDB::CREATE,
3251	0666;	3561	0666;
3252		3562
3253	cf::cleanup "db_env_open($BDBDIR): $!" if $!;	3563	cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3254
3255	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC, 1);
3256	$DB_ENV->set_lk_detect;
3257	};	3564	};
3258		3565
3259	cf::cleanup "db_env_open(db): $@" if $@;	3566	cf::cleanup "db_env_open(db): $@" if $@;
3260	};	3567	};
3261	}	3568	}
		3569
		3570	$BDB_DEADLOCK_WATCHER = Event->timer (
		3571	after => 3,
		3572	interval => 1,
		3573	hard => 1,
		3574	prio => 0,
		3575	data => WF_AUTOCANCEL,
		3576	cb => sub {
		3577	BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
		3578	},
		3579	);
		3580	$BDB_CHECKPOINT_WATCHER = Event->timer (
		3581	after => 11,
		3582	interval => 60,
		3583	hard => 1,
		3584	prio => 0,
		3585	data => WF_AUTOCANCEL,
		3586	cb => sub {
		3587	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
		3588	},
		3589	);
		3590	$BDB_TRICKLE_WATCHER = Event->timer (
		3591	after => 5,
		3592	interval => 10,
		3593	hard => 1,
		3594	prio => 0,
		3595	data => WF_AUTOCANCEL,
		3596	cb => sub {
		3597	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
		3598	},
		3599	);
3262	}	3600	}
3263		3601
3264	{	3602	{
3265	IO::AIO::min_parallel 8;	3603	IO::AIO::min_parallel 8;
3266		3604

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.303 by root, Wed Jul 11 15:57:31 2007 UTC vs. Revision 1.371 by root, Thu Sep 13 16:16:01 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.303 by root, Wed Jul 11 15:57:31 2007 UTC vs.
Revision 1.371 by root, Thu Sep 13 16:16:01 2007 UTC