ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/deliantra/server/lib/cf.pm

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.311 by root, Fri Jul 20 16:11:10 2007 UTC vs.
Revision 1.370 by root, Thu Sep 13 10:59:41 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_CHECKPOINT_WATCHER;
		86	our $BDB_TRICKLE_WATCHER;
84	our $DB_ENV;	87	our $DB_ENV;
85		88
86	our %CFG;	89	our %CFG;
87		90
88	our $UPTIME; $UPTIME ||= time;	91	our $UPTIME; $UPTIME ||= time;
89	our $RUNTIME;	92	our $RUNTIME;
90		93
91	our %PLAYER; # all users	94	our (%PLAYER, %PLAYER_LOADING); # all users
92	our %MAP; # all maps	95	our (%MAP, %MAP_LOADING ); # all maps
93	our $LINK_MAP; # the special {link} map, which is always available	96	our $LINK_MAP; # the special {link} map, which is always available
94		97
95	# used to convert map paths into valid unix filenames by replacing / by ∕	98	# used to convert map paths into valid unix filenames by replacing / by ∕
96	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons	99	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
97		100
…		…
186	$msg .= "\n"	189	$msg .= "\n"
187	unless $msg =~ /\n$/;	190	unless $msg =~ /\n$/;
188		191
189	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;	192	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
190		193
191	utf8::encode $msg;
192	LOG llevError, $msg;	194	LOG llevError, $msg;
193	};	195	};
194	}	196	}
195		197
196	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	198	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
…		…
271	Wait until the given lock is available and then acquires it and returns	273	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,	274	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	275	for example when the coroutine gets canceled), the lock is automatically
274	returned.	276	returned.
275		277
		278	Locks are *not* recursive, locking from the same coro twice results in a
		279	deadlocked coro.
		280
276	Lock names should begin with a unique identifier (for example, cf::map::find	281	Lock names should begin with a unique identifier (for example, cf::map::find
277	uses map_find and cf::map::load uses map_load).	282	uses map_find and cf::map::load uses map_load).
278		283
279	=item $locked = cf::lock_active $string	284	=item $locked = cf::lock_active $string
280		285
281	Return true if the lock is currently active, i.e. somebody has locked it.	286	Return true if the lock is currently active, i.e. somebody has locked it.
282		287
283	=cut	288	=cut
284		289
285	our %LOCK;	290	our %LOCK;
		291	our %LOCKER;#d#
286		292
287	sub lock_wait($) {	293	sub lock_wait($) {
288	my ($key) = @_;	294	my ($key) = @_;
		295
		296	if ($LOCKER{$key} == $Coro::current) {#d#
		297	Carp::cluck "lock_wait($key) for already-acquired lock";#d#
		298	return;#d#
		299	}#d#
289		300
290	# wait for lock, if any	301	# wait for lock, if any
291	while ($LOCK{$key}) {	302	while ($LOCK{$key}) {
292	push @{ $LOCK{$key} }, $Coro::current;	303	push @{ $LOCK{$key} }, $Coro::current;
293	Coro::schedule;	304	Coro::schedule;
…		…
299		310
300	# wait, to be sure we are not locked	311	# wait, to be sure we are not locked
301	lock_wait $key;	312	lock_wait $key;
302		313
303	$LOCK{$key} = [];	314	$LOCK{$key} = [];
		315	$LOCKER{$key} = $Coro::current;#d#
304		316
305	Coro::guard {	317	Coro::guard {
		318	delete $LOCKER{$key};#d#
306	# wake up all waiters, to be on the safe side	319	# wake up all waiters, to be on the safe side
307	$_->ready for @{ delete $LOCK{$key} };	320	$_->ready for @{ delete $LOCK{$key} };
308	}	321	}
309	}	322	}
310		323
…		…
320	my $guard = Coro::guard {	333	my $guard = Coro::guard {
321	$TICK_WATCHER->start;	334	$TICK_WATCHER->start;
322	};	335	};
323	$TICK_WATCHER->stop;	336	$TICK_WATCHER->stop;
324	$guard	337	$guard
		338	}
		339
		340	=item cf::get_slot $time[, $priority[, $name]]
		341
		342	Allocate $time seconds of blocking CPU time at priority C<$priority>:
		343	This call blocks and returns only when you have at least C<$time> seconds
		344	of cpu time till the next tick. The slot is only valid till the next cede.
		345
		346	The optional C<$name> can be used to identify the job to run. It might be
		347	used for statistical purposes and should identify the same time-class.
		348
		349	Useful for short background jobs.
		350
		351	=cut
		352
		353	our @SLOT_QUEUE;
		354	our $SLOT_QUEUE;
		355
		356	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
		357	$SLOT_QUEUE = Coro::async {
		358	my $signal = new Coro::Signal;
		359
		360	while () {
		361	next_job:
		362	my $avail = cf::till_tick;
		363	if ($avail > 0.01) {
		364	for (0 .. $#SLOT_QUEUE) {
		365	if ($SLOT_QUEUE[$_][0] < $avail) {
		366	my $job = splice @SLOT_QUEUE, $_, 1, ();
		367	$job->[2]->send;
		368	Coro::cede;
		369	goto next_job;
		370	}
		371	}
		372	}
		373
		374	if (@SLOT_QUEUE) {
		375	# we do not use wait_For_tick() as it returns immediately when tick is inactive
		376	push @cf::WAIT_FOR_TICK, $signal;
		377	$signal->wait;
		378	} else {
		379	Coro::schedule;
		380	}
		381	}
		382	};
		383
		384	sub get_slot($;$$) {
		385	my ($time, $pri, $name) = @_;
		386
		387	$time = $TICK * .6 if $time > $TICK * .6;
		388	my $sig = new Coro::Signal;
		389
		390	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
		391	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
		392	$SLOT_QUEUE->ready;
		393	$sig->wait;
325	}	394	}
326		395
327	=item cf::async { BLOCK }	396	=item cf::async { BLOCK }
328		397
329	Currently the same as Coro::async_pool, meaning you cannot use	398	Currently the same as Coro::async_pool, meaning you cannot use
…		…
416	Coro::Storable. May, of course, block. Note that the executed sub may	485	Coro::Storable. May, of course, block. Note that the executed sub may
417	never block itself or use any form of Event handling.	486	never block itself or use any form of Event handling.
418		487
419	=cut	488	=cut
420		489
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(&@) {	490	sub fork_call(&@) {
431	my ($cb, @args) = @_;	491	my ($cb, @args) = @_;
432		492
433	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC	493	# we seemingly have to make a local copy of the whole thing,
434	# or die "socketpair: $!";	494	# otherwise perl prematurely frees the stuff :/
435	pipe my $fh1, my $fh2	495	# TODO: investigate and fix (likely this will be rather laborious)
436	or die "pipe: $!";
437		496
438	if (my $pid = fork) {	497	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;	498	reset_signals;
452	local $SIG{__WARN__};	499	&$cb
453	local $SIG{__DIE__};	500	}, @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		501
460	eval {	502	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	}	503	}
473		504
474	=item $value = cf::db_get $family => $key	505	=item $value = cf::db_get $family => $key
475		506
476	Returns a single value from the environment database.	507	Returns a single value from the environment database.
…		…
478	=item cf::db_put $family => $key => $value	509	=item cf::db_put $family => $key => $value
479		510
480	Stores the given C<$value> in the family. It can currently store binary	511	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).	512	data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
482		513
		514	=item $db = cf::db_table "name"
		515
		516	Create and/or open a new database table. The string must not be "db" and must be unique
		517	within each server.
		518
483	=cut	519	=cut
		520
		521	sub db_table($) {
		522	my ($name) = @_;
		523	my $db = BDB::db_create $DB_ENV;
		524
		525	eval {
		526	$db->set_flags (BDB::CHKSUM);
		527
		528	utf8::encode $name;
		529	BDB::db_open $db, undef, $name, undef, BDB::BTREE,
		530	BDB::CREATE | BDB::AUTO_COMMIT, 0666;
		531	cf::cleanup "db_open(db): $!" if $!;
		532	};
		533	cf::cleanup "db_open(db): $@" if $@;
		534
		535	$db
		536	}
484		537
485	our $DB;	538	our $DB;
486		539
487	sub db_init {	540	sub db_init {
488	unless ($DB) {
489	$DB = BDB::db_create $DB_ENV;
490
491	cf::sync_job {	541	cf::sync_job {
492	eval {	542	$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	}	543	};
502	}	544	}
503		545
504	sub db_get($$) {	546	sub db_get($$) {
505	my $key = "$_[0]/$_[1]";	547	my $key = "$_[0]/$_[1]";
506		548
…		…
556	if (1) {	598	if (1) {
557	$md5 =	599	$md5 =
558	join "\x00",	600	join "\x00",
559	$processversion,	601	$processversion,
560	map {	602	map {
561	Coro::cede;	603	cf::cede_to_tick;
562	($src->[$_], Digest::MD5::md5_hex $data[$_])	604	($src->[$_], Digest::MD5::md5_hex $data[$_])
563	} 0.. $#$src;	605	} 0.. $#$src;
564		606
565		607
566	my $dbmd5 = db_get cache => "$id/md5";	608	my $dbmd5 = db_get cache => "$id/md5";
…		…
918		960
919	=cut	961	=cut
920		962
921	#############################################################################	963	#############################################################################
922	# object support	964	# object support
		965	#
		966
		967	sub _can_merge {
		968	my ($ob1, $ob2) = @_;
		969
		970	local $Storable::canonical = 1;
		971	my $fob1 = Storable::freeze $ob1;
		972	my $fob2 = Storable::freeze $ob2;
		973
		974	$fob1 eq $fob2
		975	}
923		976
924	sub reattach {	977	sub reattach {
925	# basically do the same as instantiate, without calling instantiate	978	# basically do the same as instantiate, without calling instantiate
926	my ($obj) = @_;	979	my ($obj) = @_;
927		980
…		…
972	);	1025	);
973		1026
974	sub object_freezer_save {	1027	sub object_freezer_save {
975	my ($filename, $rdata, $objs) = @_;	1028	my ($filename, $rdata, $objs) = @_;
976		1029
		1030	my $guard = cf::lock_acquire "io";
		1031
977	sync_job {	1032	sync_job {
978	if (length $$rdata) {	1033	if (length $$rdata) {
		1034	utf8::decode (my $decname = $filename);
979	warn sprintf "saving %s (%d,%d)\n",	1035	warn sprintf "saving %s (%d,%d)\n",
980	$filename, length $$rdata, scalar @$objs;	1036	$decname, length $$rdata, scalar @$objs;
981		1037
982	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {	1038	if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
983	chmod SAVE_MODE, $fh;	1039	chmod SAVE_MODE, $fh;
984	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1040	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
985	aio_fsync $fh if $cf::USE_FSYNC;	1041	aio_fsync $fh if $cf::USE_FSYNC;
…		…
1004	}	1060	}
1005	} else {	1061	} else {
1006	aio_unlink $filename;	1062	aio_unlink $filename;
1007	aio_unlink "$filename.pst";	1063	aio_unlink "$filename.pst";
1008	}	1064	}
1009	}	1065	};
		1066
		1067	undef $guard;
1010	}	1068	}
1011		1069
1012	sub object_freezer_as_string {	1070	sub object_freezer_as_string {
1013	my ($rdata, $objs) = @_;	1071	my ($rdata, $objs) = @_;
1014		1072
…		…
1019		1077
1020	sub object_thawer_load {	1078	sub object_thawer_load {
1021	my ($filename) = @_;	1079	my ($filename) = @_;
1022		1080
1023	my ($data, $av);	1081	my ($data, $av);
		1082
		1083	my $guard = cf::lock_acquire "io";
1024		1084
1025	(aio_load $filename, $data) >= 0	1085	(aio_load $filename, $data) >= 0
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
		1092	undef $guard;
1031	$av = eval { (Storable::thaw $av)->{objs} };	1093	$av = eval { (Storable::thaw $av)->{objs} };
1032	}	1094	}
1033		1095
		1096	utf8::decode (my $decname = $filename);
1034	warn sprintf "loading %s (%d)\n",	1097	warn sprintf "loading %s (%d,%d)\n",
1035	$filename, length $data, scalar @{$av || []};	1098	$decname, length $data, scalar @{$av || []};
		1099
1036	return ($data, $av);	1100	($data, $av)
1037	}	1101	}
1038		1102
1039	=head2 COMMAND CALLBACKS	1103	=head2 COMMAND CALLBACKS
1040		1104
1041	=over 4	1105	=over 4
…		…
1114	my ($pl, $buf) = @_;	1178	my ($pl, $buf) = @_;
1115		1179
1116	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1180	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1117		1181
1118	if (ref $msg) {	1182	if (ref $msg) {
		1183	my ($type, $reply, @payload) =
		1184	"ARRAY" eq ref $msg
		1185	? @$msg
		1186	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		1187
		1188	my @reply;
		1189
1119	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1190	if (my $cb = $EXTCMD{$type}) {
1120	if (my %reply = $cb->($pl, $msg)) {	1191	@reply = $cb->($pl, @payload);
1121	$pl->ext_reply ($msg->{msgid}, %reply);
1122	}
1123	}	1192	}
		1193
		1194	$pl->ext_reply ($reply, @reply)
		1195	if $reply;
		1196
1124	} else {	1197	} else {
1125	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1198	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1126	}	1199	}
1127		1200
1128	cf::override;	1201	cf::override;
…		…
1218		1291
1219	=head3 cf::player	1292	=head3 cf::player
1220		1293
1221	=over 4	1294	=over 4
1222		1295
		1296	=item cf::player::num_playing
		1297
		1298	Returns the official number of playing players, as per the Crossfire metaserver rules.
		1299
		1300	=cut
		1301
		1302	sub num_playing {
		1303	scalar grep
		1304	$_->ob->map
		1305	&& !$_->hidden
		1306	&& !$_->ob->flag (cf::FLAG_WIZ),
		1307	cf::player::list
		1308	}
		1309
1223	=item cf::player::find $login	1310	=item cf::player::find $login
1224		1311
1225	Returns the given player object, loading it if necessary (might block).	1312	Returns the given player object, loading it if necessary (might block).
1226		1313
1227	=cut	1314	=cut
…		…
1262	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";	1349	aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1263	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";	1350	aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1264	aio_unlink +(playerdir $login) . "/$login.pl.pst";	1351	aio_unlink +(playerdir $login) . "/$login.pl.pst";
1265	aio_unlink +(playerdir $login) . "/$login.pl";	1352	aio_unlink +(playerdir $login) . "/$login.pl";
1266		1353
1267	my $pl = load_pl path $login	1354	my $f = new_from_file cf::object::thawer path $login
1268	or return;	1355	or return;
		1356
		1357	$f->next;
		1358	my $pl = cf::player::load_pl $f
		1359	or return;
		1360	local $cf::PLAYER_LOADING{$login} = $pl;
		1361	$f->resolve_delayed_derefs;
1269	$cf::PLAYER{$login} = $pl	1362	$cf::PLAYER{$login} = $pl
1270	}	1363	}
1271	}	1364	}
1272	}	1365	}
1273		1366
…		…
1283		1376
1284	aio_mkdir playerdir $pl, 0770;	1377	aio_mkdir playerdir $pl, 0770;
1285	$pl->{last_save} = $cf::RUNTIME;	1378	$pl->{last_save} = $cf::RUNTIME;
1286		1379
1287	$pl->save_pl ($path);	1380	$pl->save_pl ($path);
1288	Coro::cede;	1381	cf::cede_to_tick;
1289	}	1382	}
1290		1383
1291	sub new($) {	1384	sub new($) {
1292	my ($login) = @_;	1385	my ($login) = @_;
1293		1386
…		…
1297	$self->{deny_save} = 1;	1390	$self->{deny_save} = 1;
1298		1391
1299	$cf::PLAYER{$login} = $self;	1392	$cf::PLAYER{$login} = $self;
1300		1393
1301	$self	1394	$self
		1395	}
		1396
		1397	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1398
		1399	=cut
		1400
		1401	sub send_msg {
		1402	my $ns = shift->ns
		1403	or return;
		1404	$ns->send_msg (@_);
1302	}	1405	}
1303		1406
1304	=item $pl->quit_character	1407	=item $pl->quit_character
1305		1408
1306	Nukes the player without looking back. If logged in, the connection will	1409	Nukes the player without looking back. If logged in, the connection will
…		…
1361	or return [];	1464	or return [];
1362		1465
1363	my @logins;	1466	my @logins;
1364		1467
1365	for my $login (@$dirs) {	1468	for my $login (@$dirs) {
		1469	my $path = path $login;
		1470
		1471	# a .pst is a dead give-away for a valid player
		1472	unless (-e "$path.pst") {
1366	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;	1473	my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1367	aio_read $fh, 0, 512, my $buf, 0 or next;	1474	aio_read $fh, 0, 512, my $buf, 0 or next;
1368	$buf !~ /^password -------------$/m or next; # official not-valid tag	1475	$buf !~ /^password -------------$/m or next; # official not-valid tag
		1476	}
1369		1477
1370	utf8::decode $login;	1478	utf8::decode $login;
1371	push @logins, $login;	1479	push @logins, $login;
1372	}	1480	}
1373		1481
…		…
1411	sub expand_cfpod {	1519	sub expand_cfpod {
1412	((my $self), (local $_)) = @_;	1520	((my $self), (local $_)) = @_;
1413		1521
1414	# escape & and <	1522	# escape & and <
1415	s/&/&amp;/g;	1523	s/&/&amp;/g;
1416	s/(?<![BIUGH])</&lt;/g;	1524	s/(?<![BIUGHT])</&lt;/g;
1417		1525
1418	# this is buggy, it needs to properly take care of nested <'s	1526	# this is buggy, it needs to properly take care of nested <'s
1419		1527
1420	1 while	1528	1 while
1421	# replace B<>, I<>, U<> etc.	1529	# replace B<>, I<>, U<> etc.
1422	s/B<([^\>]*)>/<b>$1<\/b>/	1530	s/B<([^\>]*)>/<b>$1<\/b>/
1423	|| s/I<([^\>]*)>/<i>$1<\/i>/	1531	|| s/I<([^\>]*)>/<i>$1<\/i>/
1424	|| s/U<([^\>]*)>/<u>$1<\/u>/	1532	|| s/U<([^\>]*)>/<u>$1<\/u>/
		1533	|| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1425	# replace G<male|female> tags	1534	# replace G<male|female> tags
1426	|| s{G<([^>|]*)\|([^>]*)>}{	1535	|| s{G<([^>|]*)\|([^>]*)>}{
1427	$self->gender ? $2 : $1	1536	$self->gender ? $2 : $1
1428	}ge	1537	}ge
1429	# replace H<hint text>	1538	# replace H<hint text>
…		…
1450	sub hintmode {	1559	sub hintmode {
1451	$_[0]{hintmode} = $_[1] if @_ > 1;	1560	$_[0]{hintmode} = $_[1] if @_ > 1;
1452	$_[0]{hintmode}	1561	$_[0]{hintmode}
1453	}	1562	}
1454		1563
1455	=item $player->ext_reply ($msgid, %msg)	1564	=item $player->ext_reply ($msgid, @msg)
1456		1565
1457	Sends an ext reply to the player.	1566	Sends an ext reply to the player.
1458		1567
1459	=cut	1568	=cut
1460		1569
1461	sub ext_reply($$%) {	1570	sub ext_reply($$@) {
1462	my ($self, $id, %msg) = @_;	1571	my ($self, $id, @msg) = @_;
1463		1572
1464	$msg{msgid} = $id;	1573	$self->ns->ext_reply ($id, @msg)
1465	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1466	}	1574	}
1467		1575
1468	=item $player->ext_event ($type, %msg)	1576	=item $player->ext_msg ($type, @msg)
1469		1577
1470	Sends an ext event to the client.	1578	Sends an ext event to the client.
1471		1579
1472	=cut	1580	=cut
1473		1581
1474	sub ext_event($$%) {	1582	sub ext_msg($$@) {
1475	my ($self, $type, %msg) = @_;	1583	my ($self, $type, @msg) = @_;
1476		1584
1477	$self->ns->ext_event ($type, %msg);	1585	$self->ns->ext_msg ($type, @msg);
1478	}	1586	}
1479		1587
1480	=head3 cf::region	1588	=head3 cf::region
1481		1589
1482	=over 4	1590	=over 4
…		…
1698		1806
1699	sub load_header_from($) {	1807	sub load_header_from($) {
1700	my ($self, $path) = @_;	1808	my ($self, $path) = @_;
1701		1809
1702	utf8::encode $path;	1810	utf8::encode $path;
1703	#aio_open $path, O_RDONLY, 0	1811	my $f = new_from_file cf::object::thawer $path
1704	# or return;
1705
1706	$self->_load_header ($path)
1707	or return;	1812	or return;
		1813
		1814	$self->_load_header ($f)
		1815	or return;
		1816
		1817	local $MAP_LOADING{$self->{path}} = $self;
		1818	$f->resolve_delayed_derefs;
1708		1819
1709	$self->{load_path} = $path;	1820	$self->{load_path} = $path;
1710		1821
1711	1	1822	1
1712	}	1823	}
…		…
1766	sub find {	1877	sub find {
1767	my ($path, $origin) = @_;	1878	my ($path, $origin) = @_;
1768		1879
1769	$path = normalise $path, $origin && $origin->path;	1880	$path = normalise $path, $origin && $origin->path;
1770		1881
		1882	cf::lock_wait "map_data:$path";#d#remove
1771	cf::lock_wait "map_find:$path";	1883	cf::lock_wait "map_find:$path";
1772		1884
1773	$cf::MAP{$path} || do {	1885	$cf::MAP{$path} || do {
1774	my $guard = cf::lock_acquire "map_find:$path";	1886	my $guard1 = cf::lock_acquire "map_find:$path";
		1887	my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
		1888
1775	my $map = new_from_path cf::map $path	1889	my $map = new_from_path cf::map $path
1776	or return;	1890	or return;
1777		1891
1778	$map->{last_save} = $cf::RUNTIME;	1892	$map->{last_save} = $cf::RUNTIME;
1779		1893
…		…
1781	or return;	1895	or return;
1782		1896
1783	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)	1897	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1784	# doing this can freeze the server in a sync job, obviously	1898	# doing this can freeze the server in a sync job, obviously
1785	#$cf::WAIT_FOR_TICK->wait;	1899	#$cf::WAIT_FOR_TICK->wait;
		1900	undef $guard1;
		1901	undef $guard2;
1786	$map->reset;	1902	$map->reset;
1787	undef $guard;
1788	return find $path;	1903	return find $path;
1789	}	1904	}
1790		1905
1791	$cf::MAP{$path} = $map	1906	$cf::MAP{$path} = $map
1792	}	1907	}
…		…
1801	local $self->{deny_reset} = 1; # loading can take a long time	1916	local $self->{deny_reset} = 1; # loading can take a long time
1802		1917
1803	my $path = $self->{path};	1918	my $path = $self->{path};
1804		1919
1805	{	1920	{
1806	my $guard = cf::lock_acquire "map_load:$path";	1921	my $guard = cf::lock_acquire "map_data:$path";
1807		1922
		1923	return unless $self->valid;
1808	return if $self->in_memory != cf::MAP_SWAPPED;	1924	return unless $self->in_memory == cf::MAP_SWAPPED;
1809		1925
1810	$self->in_memory (cf::MAP_LOADING);	1926	$self->in_memory (cf::MAP_LOADING);
1811		1927
1812	$self->alloc;	1928	$self->alloc;
1813		1929
1814	$self->pre_load;	1930	$self->pre_load;
1815	Coro::cede;	1931	cf::cede_to_tick;
1816		1932
		1933	my $f = new_from_file cf::object::thawer $self->{load_path};
		1934	$f->skip_block;
1817	$self->_load_objects ($self->{load_path}, 1)	1935	$self->_load_objects ($f)
1818	or return;	1936	or return;
1819		1937
1820	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	1938	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1821	if delete $self->{load_original};	1939	if delete $self->{load_original};
1822		1940
1823	if (my $uniq = $self->uniq_path) {	1941	if (my $uniq = $self->uniq_path) {
1824	utf8::encode $uniq;	1942	utf8::encode $uniq;
1825	if (aio_open $uniq, O_RDONLY, 0) {	1943	unless (aio_stat $uniq) {
		1944	if (my $f = new_from_file cf::object::thawer $uniq) {
1826	$self->clear_unique_items;	1945	$self->clear_unique_items;
1827	$self->_load_objects ($uniq, 0);	1946	$self->_load_objects ($f);
		1947	$f->resolve_delayed_derefs;
		1948	}
1828	}	1949	}
1829	}	1950	}
1830		1951
1831	Coro::cede;	1952	$f->resolve_delayed_derefs;
		1953
		1954	cf::cede_to_tick;
1832	# now do the right thing for maps	1955	# now do the right thing for maps
1833	$self->link_multipart_objects;	1956	$self->link_multipart_objects;
1834	$self->difficulty ($self->estimate_difficulty)	1957	$self->difficulty ($self->estimate_difficulty)
1835	unless $self->difficulty;	1958	unless $self->difficulty;
1836	Coro::cede;	1959	cf::cede_to_tick;
1837		1960
1838	unless ($self->{deny_activate}) {	1961	unless ($self->{deny_activate}) {
1839	$self->decay_objects;	1962	$self->decay_objects;
1840	$self->fix_auto_apply;	1963	$self->fix_auto_apply;
1841	$self->update_buttons;	1964	$self->update_buttons;
1842	Coro::cede;	1965	cf::cede_to_tick;
1843	$self->set_darkness_map;	1966	$self->set_darkness_map;
1844	Coro::cede;	1967	cf::cede_to_tick;
1845	$self->activate;	1968	$self->activate;
1846	}	1969	}
		1970
		1971	$self->{last_save} = $cf::RUNTIME;
		1972	$self->last_access ($cf::RUNTIME);
1847		1973
1848	$self->in_memory (cf::MAP_IN_MEMORY);	1974	$self->in_memory (cf::MAP_IN_MEMORY);
1849	}	1975	}
1850		1976
1851	$self->post_load;	1977	$self->post_load;
…		…
1862		1988
1863	$self	1989	$self
1864	}	1990	}
1865		1991
1866	# find and load all maps in the 3x3 area around a map	1992	# find and load all maps in the 3x3 area around a map
1867	sub load_diag {	1993	sub load_neighbours {
1868	my ($map) = @_;	1994	my ($map) = @_;
1869		1995
1870	my @diag; # diagonal neighbours	1996	my @neigh; # diagonal neighbours
1871		1997
1872	for (0 .. 3) {	1998	for (0 .. 3) {
1873	my $neigh = $map->tile_path ($_)	1999	my $neigh = $map->tile_path ($_)
1874	or next;	2000	or next;
1875	$neigh = find $neigh, $map	2001	$neigh = find $neigh, $map
1876	or next;	2002	or next;
1877	$neigh->load;	2003	$neigh->load;
1878		2004
		2005	push @neigh,
1879	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],	2006	[$neigh->tile_path (($_ + 3) % 4), $neigh],
1880	[$neigh->tile_path (($_ + 1) % 4), $neigh];	2007	[$neigh->tile_path (($_ + 1) % 4), $neigh];
1881	}	2008	}
1882		2009
1883	for (@diag) {	2010	for (grep defined $_->[0], @neigh) {
		2011	my ($path, $origin) = @$_;
1884	my $neigh = find @$_	2012	my $neigh = find $path, $origin
1885	or next;	2013	or next;
1886	$neigh->load;	2014	$neigh->load;
1887	}	2015	}
1888	}	2016	}
1889		2017
…		…
1894	}	2022	}
1895		2023
1896	sub do_load_sync {	2024	sub do_load_sync {
1897	my ($map) = @_;	2025	my ($map) = @_;
1898		2026
		2027	cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
		2028	if $Coro::current == $Coro::main;
		2029
1899	cf::sync_job { $map->load };	2030	cf::sync_job { $map->load };
1900	}	2031	}
1901		2032
1902	our %MAP_PREFETCH;	2033	our %MAP_PREFETCH;
1903	our $MAP_PREFETCHER = undef;	2034	our $MAP_PREFETCHER = undef;
1904		2035
1905	sub find_async {	2036	sub find_async {
1906	my ($path, $origin) = @_;	2037	my ($path, $origin, $load) = @_;
1907		2038
1908	$path = normalise $path, $origin && $origin->{path};	2039	$path = normalise $path, $origin && $origin->{path};
1909		2040
1910	if (my $map = $cf::MAP{$path}) {	2041	if (my $map = $cf::MAP{$path}) {
1911	return $map if $map->in_memory == cf::MAP_IN_MEMORY;	2042	return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1912	}	2043	}
1913		2044
1914	undef $MAP_PREFETCH{$path};	2045	$MAP_PREFETCH{$path} |= $load;
		2046
1915	$MAP_PREFETCHER ||= cf::async {	2047	$MAP_PREFETCHER ||= cf::async {
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
…		…
1963	my ($self) = @_;	2095	my ($self) = @_;
1964		2096
1965	# save first because save cedes	2097	# save first because save cedes
1966	$self->save;	2098	$self->save;
1967		2099
1968	my $lock = cf::lock_acquire "map_data:" . $self->path;	2100	my $lock = cf::lock_acquire "map_data:$self->{path}";
1969		2101
1970	return if $self->players;	2102	return if $self->players;
1971	return if $self->in_memory != cf::MAP_IN_MEMORY;	2103	return if $self->in_memory != cf::MAP_IN_MEMORY;
1972	return if $self->{deny_save};	2104	return if $self->{deny_save};
1973		2105
		2106	$self->in_memory (cf::MAP_SWAPPED);
		2107
		2108	$self->deactivate;
		2109	$_->clear_links_to ($self) for values %cf::MAP;
1974	$self->clear;	2110	$self->clear;
1975	$self->in_memory (cf::MAP_SWAPPED);
1976	}	2111	}
1977		2112
1978	sub reset_at {	2113	sub reset_at {
1979	my ($self) = @_;	2114	my ($self) = @_;
1980		2115
…		…
2012	if $uniq;	2147	if $uniq;
2013	}	2148	}
2014		2149
2015	delete $cf::MAP{$self->path};	2150	delete $cf::MAP{$self->path};
2016		2151
		2152	$self->deactivate;
		2153	$_->clear_links_to ($self) for values %cf::MAP;
2017	$self->clear;	2154	$self->clear;
2018
2019	$_->clear_links_to ($self) for values %cf::MAP;
2020		2155
2021	$self->unlink_save;	2156	$self->unlink_save;
2022	$self->destroy;	2157	$self->destroy;
2023	}	2158	}
2024		2159
2025	my $nuke_counter = "aaaa";	2160	my $nuke_counter = "aaaa";
2026		2161
2027	sub nuke {	2162	sub nuke {
2028	my ($self) = @_;	2163	my ($self) = @_;
2029		2164
		2165	{
		2166	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2167
2030	delete $cf::MAP{$self->path};	2168	delete $cf::MAP{$self->path};
2031		2169
2032	$self->unlink_save;	2170	$self->unlink_save;
2033		2171
2034	bless $self, "cf::map";	2172	bless $self, "cf::map";
2035	delete $self->{deny_reset};	2173	delete $self->{deny_reset};
2036	$self->{deny_save} = 1;	2174	$self->{deny_save} = 1;
2037	$self->reset_timeout (1);	2175	$self->reset_timeout (1);
2038	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2176	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2039		2177
2040	$cf::MAP{$self->path} = $self;	2178	$cf::MAP{$self->path} = $self;
		2179	}
2041		2180
2042	$self->reset; # polite request, might not happen	2181	$self->reset; # polite request, might not happen
2043	}	2182	}
2044		2183
2045	=item $maps = cf::map::tmp_maps	2184	=item $maps = cf::map::tmp_maps
…		…
2121		2260
2122	sub inv_recursive {	2261	sub inv_recursive {
2123	inv_recursive_ inv $_[0]	2262	inv_recursive_ inv $_[0]
2124	}	2263	}
2125		2264
		2265	=item $ref = $ob->ref
		2266
		2267	creates and returns a persistent reference to an objetc that can be stored as a string.
		2268
		2269	=item $ob = cf::object::deref ($refstring)
		2270
		2271	returns the objetc referenced by refstring. may return undef when it cnanot find the object,
		2272	even if the object actually exists. May block.
		2273
		2274	=cut
		2275
		2276	sub deref {
		2277	my ($ref) = @_;
		2278
		2279	# temporary compatibility#TODO#remove
		2280	$ref =~ s{^<}{player/<};
		2281
		2282	if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
		2283	my ($uuid, $name) = ($1, $2);
		2284	my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
		2285	or return;
		2286	$pl->ob->uuid eq $uuid
		2287	or return;
		2288
		2289	$pl->ob
		2290	} else {
		2291	warn "$ref: cannot resolve object reference\n";
		2292	undef
		2293	}
		2294	}
		2295
2126	package cf;	2296	package cf;
2127		2297
2128	=back	2298	=back
2129		2299
2130	=head3 cf::object::player	2300	=head3 cf::object::player
…		…
2152		2322
2153	} else {	2323	} else {
2154	my $pl = $self->contr;	2324	my $pl = $self->contr;
2155		2325
2156	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2326	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2157	my $diag = $pl->{npc_dialog};	2327	my $dialog = $pl->{npc_dialog};
2158	$diag->{pl}->ext_reply (	2328	$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		2329
2165	} else {	2330	} else {
2166	$msg = $npc->name . " says: $msg" if $npc;	2331	$msg = $npc->name . " says: $msg" if $npc;
2167	$self->message ($msg, $flags);	2332	$self->message ($msg, $flags);
2168	}	2333	}
2169	}	2334	}
		2335	}
		2336
		2337	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2338
		2339	=cut
		2340
		2341	sub cf::object::send_msg {
		2342	my $pl = shift->contr
		2343	or return;
		2344	$pl->send_msg (@_);
2170	}	2345	}
2171		2346
2172	=item $player_object->may ("access")	2347	=item $player_object->may ("access")
2173		2348
2174	Returns wether the given player is authorized to access resource "access"	2349	Returns wether the given player is authorized to access resource "access"
…		…
2253	# use -1 or undef as default coordinates, not 0, 0	2428	# use -1 or undef as default coordinates, not 0, 0
2254	($x, $y) = ($map->enter_x, $map->enter_y)	2429	($x, $y) = ($map->enter_x, $map->enter_y)
2255	if $x <=0 && $y <= 0;	2430	if $x <=0 && $y <= 0;
2256		2431
2257	$map->load;	2432	$map->load;
2258	$map->load_diag;	2433	$map->load_neighbours;
2259		2434
2260	return unless $self->contr->active;	2435	return unless $self->contr->active;
2261	$self->activate_recursive;	2436	$self->activate_recursive;
2262		2437
2263	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2438	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
…		…
2283	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2458	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2284		2459
2285	$self->enter_link;	2460	$self->enter_link;
2286		2461
2287	(async {	2462	(async {
		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
…		…
2434	the message, with C<log> being the default. If C<$color> is negative, suppress	2628	the message, with C<log> being the default. If C<$color> is negative, suppress
2435	the message unless the client supports the msg packet.	2629	the message unless the client supports the msg packet.
2436		2630
2437	=cut	2631	=cut
2438		2632
		2633	our %CHANNEL = (
		2634	"c/identify" => {
		2635	id => "identify",
		2636	title => "Identify",
		2637	reply => undef,
		2638	tooltip => "Items recently identified",
		2639	},
		2640	"c/examine" => {
		2641	id => "examine",
		2642	title => "Examine",
		2643	reply => undef,
		2644	tooltip => "Signs and other items you examined",
		2645	},
		2646	);
		2647
2439	sub cf::client::send_msg {	2648	sub cf::client::send_msg {
2440	my ($self, $channel, $msg, $color, @extra) = @_;	2649	my ($self, $channel, $msg, $color, @extra) = @_;
2441		2650
2442	$msg = $self->pl->expand_cfpod ($msg);	2651	$msg = $self->pl->expand_cfpod ($msg);
2443		2652
2444	return unless @extra || length $msg;
2445
2446	$color &= ~cf::NDI_UNIQUE; # just in case...	2653	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2654
		2655	# check predefined channels, for the benefit of C
		2656	$channel = $CHANNEL{$channel} if $CHANNEL{$channel};
2447		2657
2448	if (ref $channel) {	2658	if (ref $channel) {
2449	# send meta info to client, if not yet sent	2659	# send meta info to client, if not yet sent
2450	unless (exists $self->{channel}{$channel->{id}}) {	2660	unless (exists $self->{channel}{$channel->{id}}) {
2451	$self->{channel}{$channel->{id}} = $channel;	2661	$self->{channel}{$channel->{id}} = $channel;
2452	$self->ext_event (channel_info => %$channel);	2662	$self->ext_msg (channel_info => $channel)
		2663	if $self->can_msg;
2453	}	2664	}
2454		2665
2455	$channel = $channel->{id};	2666	$channel = $channel->{id};
2456	}	2667	}
2457		2668
		2669	return unless @extra || length $msg;
		2670
2458	if ($self->can_msg) {	2671	if ($self->can_msg) {
		2672	# default colour, mask it out
		2673	$color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
		2674	if $color & cf::NDI_DEF;
		2675
2459	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra]));	2676	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2677	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2460	} else {	2678	} else {
2461	# replace some tags by gcfclient-compatible ones
2462	for ($msg) {
2463	1 while
2464	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2465	|| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2466	|| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2467	|| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2468	|| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2469	}
2470
2471	if ($color >= 0) {	2679	if ($color >= 0) {
		2680	# replace some tags by gcfclient-compatible ones
		2681	for ($msg) {
		2682	1 while
		2683	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2684	|| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2685	|| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2686	|| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2687	|| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2688	}
		2689
		2690	$color &= cf::NDI_COLOR_MASK;
		2691
		2692	utf8::encode $msg;
		2693
2472	if (0 && $msg =~ /\[/) {	2694	if (0 && $msg =~ /\[/) {
		2695	# COMMAND/INFO
2473	$self->send_packet ("drawextinfo $color 4 0 $msg")	2696	$self->send_packet ("drawextinfo $color 10 8 $msg")
2474	} else {	2697	} else {
2475	$msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;	2698	$msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2476	$self->send_packet ("drawinfo $color $msg")	2699	$self->send_packet ("drawinfo $color $msg")
2477	}	2700	}
2478	}	2701	}
2479	}	2702	}
2480	}	2703	}
2481		2704
2482	=item $client->ext_event ($type, %msg)	2705	=item $client->ext_msg ($type, @msg)
2483		2706
2484	Sends an ext event to the client.	2707	Sends an ext event to the client.
2485		2708
2486	=cut	2709	=cut
2487		2710
2488	sub cf::client::ext_event($$%) {	2711	sub cf::client::ext_msg($$@) {
2489	my ($self, $type, %msg) = @_;	2712	my ($self, $type, @msg) = @_;
2490		2713
2491	return unless $self->extcmd;	2714	if ($self->extcmd == 2) {
2492		2715	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2716	} elsif ($self->extcmd == 1) { # TODO: remove
2493	$msg{msgtype} = "event_$type";	2717	push @msg, msgtype => "event_$type";
2494	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2718	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2719	}
		2720	}
		2721
		2722	=item $client->ext_reply ($msgid, @msg)
		2723
		2724	Sends an ext reply to the client.
		2725
		2726	=cut
		2727
		2728	sub cf::client::ext_reply($$@) {
		2729	my ($self, $id, @msg) = @_;
		2730
		2731	if ($self->extcmd == 2) {
		2732	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
		2733	} elsif ($self->extcmd == 1) {
		2734	#TODO: version 1, remove
		2735	unshift @msg, msgtype => "reply", msgid => $id;
		2736	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2737	}
2495	}	2738	}
2496		2739
2497	=item $success = $client->query ($flags, "text", \&cb)	2740	=item $success = $client->query ($flags, "text", \&cb)
2498		2741
2499	Queues a query to the client, calling the given callback with	2742	Queues a query to the client, calling the given callback with
…		…
2554	my ($ns, $buf) = @_;	2797	my ($ns, $buf) = @_;
2555		2798
2556	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2799	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2557		2800
2558	if (ref $msg) {	2801	if (ref $msg) {
		2802	my ($type, $reply, @payload) =
		2803	"ARRAY" eq ref $msg
		2804	? @$msg
		2805	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2806
		2807	my @reply;
		2808
2559	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2809	if (my $cb = $EXTICMD{$type}) {
2560	if (my %reply = $cb->($ns, $msg)) {	2810	@reply = $cb->($ns, @payload);
2561	$reply{msgid} = $msg->{msgid};
2562	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2563	}
2564	}	2811	}
		2812
		2813	$ns->ext_reply ($reply, @reply)
		2814	if $reply;
		2815
2565	} else {	2816	} else {
2566	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2817	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2567	}	2818	}
2568		2819
2569	cf::override;	2820	cf::override;
…		…
2616	our $safe = new Safe "safe";	2867	our $safe = new Safe "safe";
2617	our $safe_hole = new Safe::Hole;	2868	our $safe_hole = new Safe::Hole;
2618		2869
2619	$SIG{FPE} = 'IGNORE';	2870	$SIG{FPE} = 'IGNORE';
2620		2871
2621	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2872	$safe->permit_only (Opcode::opset qw(
		2873	:base_core :base_mem :base_orig :base_math
		2874	grepstart grepwhile mapstart mapwhile
		2875	sort time
		2876	));
2622		2877
2623	# here we export the classes and methods available to script code	2878	# here we export the classes and methods available to script code
2624		2879
2625	=pod	2880	=pod
2626		2881
2627	The following functions and methods are available within a safe environment:	2882	The following functions and methods are available within a safe environment:
2628		2883
2629	cf::object	2884	cf::object
2630	contr pay_amount pay_player map x y force_find force_add	2885	contr pay_amount pay_player map x y force_find force_add
2631	insert remove	2886	insert remove name archname title slaying race decrease_ob_nr
2632		2887
2633	cf::object::player	2888	cf::object::player
2634	player	2889	player
2635		2890
2636	cf::player	2891	cf::player
…		…
2641		2896
2642	=cut	2897	=cut
2643		2898
2644	for (	2899	for (
2645	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2900	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2901	insert remove inv name archname title slaying race
2646	insert remove)],	2902	decrease_ob_nr)],
2647	["cf::object::player" => qw(player)],	2903	["cf::object::player" => qw(player)],
2648	["cf::player" => qw(peaceful)],	2904	["cf::player" => qw(peaceful)],
2649	["cf::map" => qw(trigger)],	2905	["cf::map" => qw(trigger)],
2650	) {	2906	) {
2651	no strict 'refs';	2907	no strict 'refs';
…		…
2727	# the server's init and main functions	2983	# the server's init and main functions
2728		2984
2729	sub load_facedata($) {	2985	sub load_facedata($) {
2730	my ($path) = @_;	2986	my ($path) = @_;
2731		2987
		2988	# HACK to clear player env face cache, we need some signal framework
		2989	# for this (global event?)
		2990	%ext::player_env::MUSIC_FACE_CACHE = ();
		2991
		2992	my $enc = JSON::XS->new->utf8->canonical->relaxed;
		2993
2732	warn "loading facedata from $path\n";	2994	warn "loading facedata from $path\n";
2733		2995
2734	my $facedata;	2996	my $facedata;
2735	0 < aio_load $path, $facedata	2997	0 < aio_load $path, $facedata
2736	or die "$path: $!";	2998	or die "$path: $!";
2737		2999
2738	$facedata = Coro::Storable::thaw $facedata;	3000	$facedata = Coro::Storable::thaw $facedata;
2739		3001
2740	$facedata->{version} == 2	3002	$facedata->{version} == 2
2741	or cf::cleanup "$path: version mismatch, cannot proceed.";	3003	or cf::cleanup "$path: version mismatch, cannot proceed.";
		3004
		3005	# patch in the exptable
		3006	$facedata->{resource}{"res/exp_table"} = {
		3007	type => FT_RSRC,
		3008	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
		3009	};
		3010	cf::cede_to_tick;
2742		3011
2743	{	3012	{
2744	my $faces = $facedata->{faceinfo};	3013	my $faces = $facedata->{faceinfo};
2745		3014
2746	while (my ($face, $info) = each %$faces) {	3015	while (my ($face, $info) = each %$faces) {
2747	my $idx = (cf::face::find $face) || cf::face::alloc $face;	3016	my $idx = (cf::face::find $face) || cf::face::alloc $face;
2748	cf::face::set_visibility $idx, $info->{visibility};	3017	cf::face::set_visibility $idx, $info->{visibility};
2749	cf::face::set_magicmap $idx, $info->{magicmap};	3018	cf::face::set_magicmap $idx, $info->{magicmap};
2750	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	3019	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2751	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	3020	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2752		3021
2753	cf::cede_to_tick;	3022	cf::cede_to_tick;
2754	}	3023	}
2755		3024
2756	while (my ($face, $info) = each %$faces) {	3025	while (my ($face, $info) = each %$faces) {
…		…
2781		3050
2782	{	3051	{
2783	# TODO: for gcfclient pleasure, we should give resources	3052	# TODO: for gcfclient pleasure, we should give resources
2784	# that gcfclient doesn't grok a >10000 face index.	3053	# that gcfclient doesn't grok a >10000 face index.
2785	my $res = $facedata->{resource};	3054	my $res = $facedata->{resource};
2786	my $enc = JSON::XS->new->utf8->canonical;	3055
		3056	my $soundconf = delete $res->{"res/sound.conf"};
2787		3057
2788	while (my ($name, $info) = each %$res) {	3058	while (my ($name, $info) = each %$res) {
2789	my $meta = $enc->encode ({
2790	name => $name,
2791	type => $info->{type},
2792	copyright => $info->{copyright}, #TODO#
2793	});
2794
2795	my $idx = (cf::face::find $name) || cf::face::alloc $name;	3059	my $idx = (cf::face::find $name) || cf::face::alloc $name;
		3060	my $data;
2796		3061
2797	if ($name =~ /\.jpg$/) {	3062	if ($info->{type} & 1) {
2798	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack	3063	# prepend meta info
2799	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack	3064
		3065	my $meta = $enc->encode ({
		3066	name => $name,
		3067	%{ $info->{meta} || {} },
		3068	});
		3069
		3070	$data = pack "(w/a*)*", $meta, $info->{data};
2800	} else {	3071	} else {
2801	my $data = pack "(w/a*)*", $meta, $info->{data};	3072	$data = $info->{data};
2802	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2803
2804	cf::face::set_type $idx, 1;
2805	cf::face::set_data $idx, 0, $data, $chk;
2806	}	3073	}
2807		3074
		3075	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
		3076	cf::face::set_type $idx, $info->{type};
		3077
2808	cf::cede_to_tick;	3078	cf::cede_to_tick;
2809	}	3079	}
		3080
		3081	if ($soundconf) {
		3082	$soundconf = $enc->decode (delete $soundconf->{data});
		3083
		3084	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		3085	my $sound = $soundconf->{compat}[$_]
		3086	or next;
		3087
		3088	my $face = cf::face::find "sound/$sound->[1]";
		3089	cf::sound::set $sound->[0] => $face;
		3090	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		3091	}
		3092
		3093	while (my ($k, $v) = each %{$soundconf->{event}}) {
		3094	my $face = cf::face::find "sound/$v";
		3095	cf::sound::set $k => $face;
		3096	}
		3097	}
2810	}	3098	}
2811		3099
2812	1	3100	1
2813	}	3101	}
2814		3102
		3103	register_exticmd fx_want => sub {
		3104	my ($ns, $want) = @_;
		3105
		3106	while (my ($k, $v) = each %$want) {
		3107	$ns->fx_want ($k, $v);
		3108	}
		3109	};
		3110
2815	sub reload_regions {	3111	sub reload_regions {
		3112	# HACK to clear player env face cache, we need some signal framework
		3113	# for this (global event?)
		3114	%ext::player_env::MUSIC_FACE_CACHE = ();
		3115
2816	load_resource_file "$MAPDIR/regions"	3116	load_resource_file "$MAPDIR/regions"
2817	or die "unable to load regions file\n";	3117	or die "unable to load regions file\n";
2818		3118
2819	for (cf::region::list) {	3119	for (cf::region::list) {
2820	$_->{match} = qr/$_->{match}/	3120	$_->{match} = qr/$_->{match}/
…		…
2856		3156
2857	sub init {	3157	sub init {
2858	reload_resources;	3158	reload_resources;
2859	}	3159	}
2860		3160
2861	sub cfg_load {	3161	sub reload_config {
2862	open my $fh, "<:utf8", "$CONFDIR/config"	3162	open my $fh, "<:utf8", "$CONFDIR/config"
2863	or return;	3163	or return;
2864		3164
2865	local $/;	3165	local $/;
2866	*CFG = YAML::Syck::Load <$fh>;	3166	*CFG = YAML::Syck::Load <$fh>;
…		…
2886	(async {	3186	(async {
2887	Event::one_event;	3187	Event::one_event;
2888	})->prio (Coro::PRIO_MAX);	3188	})->prio (Coro::PRIO_MAX);
2889	};	3189	};
2890		3190
2891	cfg_load;	3191	reload_config;
2892	db_init;	3192	db_init;
2893	load_extensions;	3193	load_extensions;
2894		3194
2895	$TICK_WATCHER->start;	3195	$TICK_WATCHER->start;
2896	Event::loop;	3196	Event::loop;
…		…
3089	warn "reloading cf.pm";	3389	warn "reloading cf.pm";
3090	require cf;	3390	require cf;
3091	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3391	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3092		3392
3093	warn "loading config and database again";	3393	warn "loading config and database again";
3094	cf::cfg_load;	3394	cf::reload_config;
3095		3395
3096	warn "loading extensions";	3396	warn "loading extensions";
3097	cf::load_extensions;	3397	cf::load_extensions;
3098		3398
3099	warn "reattaching attachments to objects/players";	3399	warn "reattaching attachments to objects/players";
…		…
3164	my $signal = new Coro::Signal;	3464	my $signal = new Coro::Signal;
3165	push @WAIT_FOR_TICK_BEGIN, $signal;	3465	push @WAIT_FOR_TICK_BEGIN, $signal;
3166	$signal->wait;	3466	$signal->wait;
3167	}	3467	}
3168		3468
3169	my $min = 1e6;#d#
3170	my $avg = 10;
3171	$TICK_WATCHER = Event->timer (	3469	$TICK_WATCHER = Event->timer (
3172	reentrant => 0,	3470	reentrant => 0,
3173	parked => 1,	3471	parked => 1,
3174	prio => 0,	3472	prio => 0,
3175	at => $NEXT_TICK || $TICK,	3473	at => $NEXT_TICK || $TICK,
…		…
3183		3481
3184	$NOW = $tick_start = Event::time;	3482	$NOW = $tick_start = Event::time;
3185		3483
3186	cf::server_tick; # one server iteration	3484	cf::server_tick; # one server iteration
3187		3485
3188	0 && sync_job {#d#
3189	for(1..10) {
3190	my $t = Event::time;
3191	my $map = my $map = new_from_path cf::map "/tmp/x.map"
3192	or die;
3193
3194	$map->width (50);
3195	$map->height (50);
3196	$map->alloc;
3197	$map->_load_objects ("/tmp/x.map", 1);
3198	my $t = Event::time - $t;
3199
3200	#next unless $t < 0.0013;#d#
3201	if ($t < $min) {
3202	$min = $t;
3203	}
3204	$avg = $avg * 0.99 + $t * 0.01;
3205	}
3206	warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3207	exit 0;
3208	# 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3209	};
3210
3211	$RUNTIME += $TICK;	3486	$RUNTIME += $TICK;
3212	$NEXT_TICK += $TICK;	3487	$NEXT_TICK += $TICK;
3213		3488
3214	if ($NOW >= $NEXT_RUNTIME_WRITE) {	3489	if ($NOW >= $NEXT_RUNTIME_WRITE) {
3215	$NEXT_RUNTIME_WRITE = $NOW + 10;	3490	$NEXT_RUNTIME_WRITE = $NOW + 10;
…		…
3217	write_runtime	3492	write_runtime
3218	or warn "ERROR: unable to write runtime file: $!";	3493	or warn "ERROR: unable to write runtime file: $!";
3219	};	3494	};
3220	}	3495	}
3221		3496
3222	# my $AFTER = Event::time;
3223	# warn $AFTER - $NOW;#d#
3224
3225	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	3497	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3226	$sig->send;	3498	$sig->send;
3227	}	3499	}
3228	while (my $sig = shift @WAIT_FOR_TICK) {	3500	while (my $sig = shift @WAIT_FOR_TICK) {
3229	$sig->send;	3501	$sig->send;
…		…
3239		3511
3240	$LOAD = ($NOW - $tick_start) / $TICK;	3512	$LOAD = ($NOW - $tick_start) / $TICK;
3241	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;	3513	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3242		3514
3243	_post_tick;	3515	_post_tick;
3244
3245
3246	},	3516	},
3247	);	3517	);
3248		3518
3249	{	3519	{
		3520	BDB::min_parallel 8;
3250	BDB::max_poll_time $TICK * 0.1;	3521	BDB::max_poll_time $TICK * 0.1;
3251	$BDB_POLL_WATCHER = Event->io (	3522	$BDB_POLL_WATCHER = Event->io (
3252	reentrant => 0,	3523	reentrant => 0,
3253	fd => BDB::poll_fileno,	3524	fd => BDB::poll_fileno,
3254	poll => 'r',	3525	poll => 'r',
3255	prio => 0,	3526	prio => 0,
3256	data => WF_AUTOCANCEL,	3527	data => WF_AUTOCANCEL,
3257	cb => \&BDB::poll_cb,	3528	cb => \&BDB::poll_cb,
3258	);	3529	);
3259	BDB::min_parallel 8;
3260		3530
3261	BDB::set_sync_prepare {	3531	BDB::set_sync_prepare {
3262	my $status;	3532	my $status;
3263	my $current = $Coro::current;	3533	my $current = $Coro::current;
3264	(	3534	(
…		…
3285	| BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,	3555	| BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3286	0666;	3556	0666;
3287		3557
3288	cf::cleanup "db_env_open($BDBDIR): $!" if $!;	3558	cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3289		3559
3290	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);	3560	$DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
		3561	| BDB::LOG_AUTOREMOVE, 1);
3291	$DB_ENV->set_lk_detect;	3562	$DB_ENV->set_lk_detect;
3292	};	3563	};
3293		3564
3294	cf::cleanup "db_env_open(db): $@" if $@;	3565	cf::cleanup "db_env_open(db): $@" if $@;
3295	};	3566	};
3296	}	3567	}
		3568
		3569	$BDB_CHECKPOINT_WATCHER = Event->timer (
		3570	after => 11,
		3571	interval => 60,
		3572	hard => 1,
		3573	prio => 0,
		3574	data => WF_AUTOCANCEL,
		3575	cb => sub {
		3576	BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
		3577	},
		3578	);
		3579	$BDB_TRICKLE_WATCHER = Event->timer (
		3580	after => 5,
		3581	interval => 10,
		3582	hard => 1,
		3583	prio => 0,
		3584	data => WF_AUTOCANCEL,
		3585	cb => sub {
		3586	BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
		3587	},
		3588	);
3297	}	3589	}
3298		3590
3299	{	3591	{
3300	IO::AIO::min_parallel 8;	3592	IO::AIO::min_parallel 8;
3301		3593

Diff Legend

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