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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.282 by elmex, Tue Jun 19 18:15:34 2007 UTC vs.
Revision 1.309 by elmex, Mon Jul 16 15:27:06 2007 UTC

…		…
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		24
		25	use JSON::XS 1.4 ();
25	use BDB ();	26	use BDB ();
26	use Data::Dumper;	27	use Data::Dumper;
27	use Digest::MD5;	28	use Digest::MD5;
28	use Fcntl;	29	use Fcntl;
29	use YAML::Syck ();	30	use YAML::Syck ();
30	use IO::AIO 2.32 ();	31	use IO::AIO 2.32 ();
31	use Time::HiRes;	32	use Time::HiRes;
32	use Compress::LZF;	33	use Compress::LZF;
		34	use Digest::MD5 ();
33		35
34	# configure various modules to our taste	36	# configure various modules to our taste
35	#	37	#
36	$Storable::canonical = 1; # reduce rsync transfers	38	$Storable::canonical = 1; # reduce rsync transfers
37	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator	39	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
…		…
49	our %COMMAND = ();	51	our %COMMAND = ();
50	our %COMMAND_TIME = ();	52	our %COMMAND_TIME = ();
51		53
52	our @EXTS = (); # list of extension package names	54	our @EXTS = (); # list of extension package names
53	our %EXTCMD = ();	55	our %EXTCMD = ();
		56	our %EXTICMD = ();
54	our %EXT_CORO = (); # coroutines bound to extensions	57	our %EXT_CORO = (); # coroutines bound to extensions
55	our %EXT_MAP = (); # pluggable maps	58	our %EXT_MAP = (); # pluggable maps
56		59
57	our $RELOAD; # number of reloads so far	60	our $RELOAD; # number of reloads so far
58	our @EVENT;	61	our @EVENT;
…		…
236	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;	239	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
237	$d	240	$d
238	} \|\| "[unable to dump $_[0]: '$@']";	241	} \|\| "[unable to dump $_[0]: '$@']";
239	}	242	}
240		243
241	use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
242
243	=item $ref = cf::from_json $json	244	=item $ref = cf::from_json $json
244		245
245	Converts a JSON string into the corresponding perl data structure.	246	Converts a JSON string into the corresponding perl data structure.
246		247
247	=item $json = cf::to_json $ref	248	=item $json = cf::to_json $ref
248		249
249	Converts a perl data structure into its JSON representation.	250	Converts a perl data structure into its JSON representation.
		251
		252	=cut
		253
		254	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
		255
		256	sub to_json ($) { $json_coder->encode ($_[0]) }
		257	sub from_json ($) { $json_coder->decode ($_[0]) }
250		258
251	=item cf::lock_wait $string	259	=item cf::lock_wait $string
252		260
253	Wait until the given lock is available. See cf::lock_acquire.	261	Wait until the given lock is available. See cf::lock_acquire.
254		262
…		…
402	Coro::Storable. May, of course, block. Note that the executed sub may	410	Coro::Storable. May, of course, block. Note that the executed sub may
403	never block itself or use any form of Event handling.	411	never block itself or use any form of Event handling.
404		412
405	=cut	413	=cut
406		414
		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
407	sub fork_call(&@) {	424	sub fork_call(&@) {
408	my ($cb, @args) = @_;	425	my ($cb, @args) = @_;
409		426
410	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC	427	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
411	# or die "socketpair: $!";	428	# or die "socketpair: $!";
…		…
414		431
415	if (my $pid = fork) {	432	if (my $pid = fork) {
416	close $fh2;	433	close $fh2;
417		434
418	my $res = (Coro::Handle::unblock $fh1)->readline (undef);	435	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
		436	warn "pst<$res>" unless $res =~ /^pst/;
419	$res = Coro::Storable::thaw $res;	437	$res = Coro::Storable::thaw $res;
420		438
421	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave	439	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
422		440
423	die $$res unless "ARRAY" eq ref $res;	441	Carp::confess $$res unless "ARRAY" eq ref $res;
424		442
425	return wantarray ? @$res : $res->[-1];	443	return wantarray ? @$res : $res->[-1];
426	} else {	444	} else {
427	reset_signals;	445	reset_signals;
428	local $SIG{__WARN__};	446	local $SIG{__WARN__};
429	local $SIG{__DIE__};	447	local $SIG{__DIE__};
		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
430	eval {	454	eval {
431	close $fh1;	455	close $fh1;
432		456
433	my @res = eval { $cb->(@args) };	457	my @res = eval { $cb->(@args) };
		458
434	syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);	459	syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
		460	close $fh2;
435	};	461	};
436		462
437	warn $@ if $@;	463	warn $@ if $@;
438	_exit 0;	464	_exit 0;
439	}	465	}
…		…
844	our $override;	870	our $override;
845	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	871	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
846		872
847	sub override {	873	sub override {
848	$override = 1;	874	$override = 1;
849	@invoke_results = ();	875	@invoke_results = (@_);
850	}	876	}
851		877
852	sub do_invoke {	878	sub do_invoke {
853	my $event = shift;	879	my $event = shift;
854	my $callbacks = shift;	880	my $callbacks = shift;
…		…
1029	push @{ $COMMAND{$name} }, [$caller, $cb];	1055	push @{ $COMMAND{$name} }, [$caller, $cb];
1030	}	1056	}
1031		1057
1032	=item cf::register_extcmd $name => \&callback($pl,$packet);	1058	=item cf::register_extcmd $name => \&callback($pl,$packet);
1033		1059
1034	Register a callback fro execution when the client sends an extcmd packet.	1060	Register a callback for execution when the client sends an (synchronous)
		1061	extcmd packet. Ext commands will be processed in the order they are
		1062	received by the server, like other user commands. The first argument is
		1063	the logged-in player. Ext commands can only be processed after a player
		1064	has logged in successfully.
1035		1065
1036	If the callback returns something, it is sent back as if reply was being	1066	If the callback returns something, it is sent back as if reply was being
1037	called.	1067	called.
1038		1068
		1069	=item cf::register_exticmd $name => \&callback($ns,$packet);
		1070
		1071	Register a callback for execution when the client sends an (asynchronous)
		1072	exticmd packet. Exti commands are processed by the server as soon as they
		1073	are received, i.e. out of order w.r.t. other commands. The first argument
		1074	is a client socket. Exti commands can be received anytime, even before
		1075	log-in.
		1076
		1077	If the callback returns something, it is sent back as if reply was being
		1078	called.
		1079
1039	=cut	1080	=cut
1040		1081
1041	sub register_extcmd {	1082	sub register_extcmd {
1042	my ($name, $cb) = @_;	1083	my ($name, $cb) = @_;
1043		1084
1044	$EXTCMD{$name} = $cb;	1085	$EXTCMD{$name} = $cb;
		1086	}
		1087
		1088	sub register_exticmd {
		1089	my ($name, $cb) = @_;
		1090
		1091	$EXTICMD{$name} = $cb;
1045	}	1092	}
1046		1093
1047	cf::player->attach (	1094	cf::player->attach (
1048	on_command => sub {	1095	on_command => sub {
1049	my ($pl, $name, $params) = @_;	1096	my ($pl, $name, $params) = @_;
…		…
1058	cf::override;	1105	cf::override;
1059	},	1106	},
1060	on_extcmd => sub {	1107	on_extcmd => sub {
1061	my ($pl, $buf) = @_;	1108	my ($pl, $buf) = @_;
1062		1109
1063	my $msg = eval { from_json $buf };	1110	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1064		1111
1065	if (ref $msg) {	1112	if (ref $msg) {
1066	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1113	if (my $cb = $EXTCMD{$msg->{msgtype}}) {
1067	if (my %reply = $cb->($pl, $msg)) {	1114	if (my %reply = $cb->($pl, $msg)) {
1068	$pl->ext_reply ($msg->{msgid}, %reply);	1115	$pl->ext_reply ($msg->{msgid}, %reply);
…		…
1347	}	1394	}
1348		1395
1349	\@paths	1396	\@paths
1350	}	1397	}
1351		1398
		1399	=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
		1400
		1401	Expand crossfire pod fragments into protocol xml.
		1402
		1403	=cut
		1404
		1405	sub expand_cfpod {
		1406	((my $self), (local $_)) = @_;
		1407
		1408	# escape & and <
		1409	s/&/&/g;
		1410	s/(?<![BIUGH])</</g;
		1411
		1412	# this is buggy, it needs to properly take care of nested <'s
		1413
		1414	1 while
		1415	# replace B<>, I<>, U<> etc.
		1416	s/B<([^\>]*)>/<b>$1<\/b>/
		1417	\|\| s/I<([^\>]*)>/<i>$1<\/i>/
		1418	\|\| s/U<([^\>]*)>/<u>$1<\/u>/
		1419	# replace G<male\|female> tags
		1420	\|\| s{G<([^>\|])\\|([^>])>}{
		1421	$self->gender ? $2 : $1
		1422	}ge
		1423	# replace H<hint text>
		1424	\|\| s{H<([^\>]*)>}
		1425	{
		1426	("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
		1427	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
		1428	"")
		1429	[$self->{hintmode}]
		1430	}ge;
		1431
		1432	# create single paragraphs (very hackish)
		1433	s/(?<=\S)\n(?=\w)/ /g;
		1434
		1435	# compress some whitespace
		1436	s/\s+\n/\n/g; # ws line-ends
		1437	s/\n\n+/\n/g; # double lines
		1438	s/^\n+//; # beginning lines
		1439	s/\n+$//; # ending lines
		1440
		1441	$_
		1442	}
		1443
		1444	sub hintmode {
		1445	$_[0]{hintmode} = $_[1] if @_ > 1;
		1446	$_[0]{hintmode}
		1447	}
		1448
1352	=item $player->ext_reply ($msgid, %msg)	1449	=item $player->ext_reply ($msgid, %msg)
1353		1450
1354	Sends an ext reply to the player.	1451	Sends an ext reply to the player.
1355		1452
1356	=cut	1453	=cut
1357		1454
1358	sub ext_reply($$%) {	1455	sub ext_reply($$%) {
1359	my ($self, $id, %msg) = @_;	1456	my ($self, $id, %msg) = @_;
1360		1457
1361	$msg{msgid} = $id;	1458	$msg{msgid} = $id;
1362		1459	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1363	$self->send ("ext " . cf::to_json \%msg);
1364	}	1460	}
1365		1461
1366	=item $player->ext_event ($type, %msg)	1462	=item $player->ext_event ($type, %msg)
1367		1463
1368	Sends an ext event to the client.	1464	Sends an ext event to the client.
…		…
1393	my ($path) = @_;	1489	my ($path) = @_;
1394		1490
1395	my ($match, $specificity);	1491	my ($match, $specificity);
1396		1492
1397	for my $region (list) {	1493	for my $region (list) {
1398	if ($region->match && $path =~ $region->match) {	1494	if ($region->{match} && $path =~ $region->{match}) {
1399	($match, $specificity) = ($region, $region->specificity)	1495	($match, $specificity) = ($region, $region->specificity)
1400	if $region->specificity > $specificity;	1496	if $region->specificity > $specificity;
1401	}	1497	}
1402	}	1498	}
1403		1499
…		…
1523	$self->init; # pass $1 etc.	1619	$self->init; # pass $1 etc.
1524	return $self;	1620	return $self;
1525	}	1621	}
1526	}	1622	}
1527		1623
1528	Carp::carp "unable to resolve path '$path' (base '$base').";	1624	Carp::cluck "unable to resolve path '$path' (base '$base').";
1529	()	1625	()
1530	}	1626	}
1531		1627
1532	sub init {	1628	sub init {
1533	my ($self) = @_;	1629	my ($self) = @_;
…		…
1811		1907
1812	undef $MAP_PREFETCH{$path};	1908	undef $MAP_PREFETCH{$path};
1813	$MAP_PREFETCHER \|\|= cf::async {	1909	$MAP_PREFETCHER \|\|= cf::async {
1814	while (%MAP_PREFETCH) {	1910	while (%MAP_PREFETCH) {
1815	for my $path (keys %MAP_PREFETCH) {	1911	for my $path (keys %MAP_PREFETCH) {
1816	my $map = find $path	1912	if (my $map = find $path) {
1817	or next;
1818	$map->load;	1913	$map->load;
		1914	}
1819		1915
1820	delete $MAP_PREFETCH{$path};	1916	delete $MAP_PREFETCH{$path};
1821	}	1917	}
1822	}	1918	}
1823	undef $MAP_PREFETCHER;	1919	undef $MAP_PREFETCHER;
…		…
2052	my $pl = $self->contr;	2148	my $pl = $self->contr;
2053		2149
2054	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2150	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2055	my $diag = $pl->{npc_dialog};	2151	my $diag = $pl->{npc_dialog};
2056	$diag->{pl}->ext_reply (	2152	$diag->{pl}->ext_reply (
2057	$diag->{id}, msgtype => "reply", msg => $msg, add_topics => []	2153	$diag->{id},
		2154	msgtype => "reply",
		2155	msg => $diag->{pl}->expand_cfpod ($msg),
		2156	add_topics => []
2058	);	2157	);
2059		2158
2060	} else {	2159	} else {
2061	$msg = $npc->name . " says: $msg" if $npc;	2160	$msg = $npc->name . " says: $msg" if $npc;
2062	$self->message ($msg, $flags);	2161	$self->message ($msg, $flags);
…		…
2157		2256
2158	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2257	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2159	$self->enter_map ($map, $x, $y);	2258	$self->enter_map ($map, $x, $y);
2160	}	2259	}
2161		2260
2162	=item $player_object->goto ($path, $x, $y[, $check->($map)])	2261	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2163		2262
2164	Moves the player to the given map-path and coordinates by first freezing	2263	Moves the player to the given map-path and coordinates by first freezing
2165	her, loading and preparing them map, calling the provided $check callback	2264	her, loading and preparing them map, calling the provided $check callback
2166	that has to return the map if sucecssful, and then unfreezes the player on	2265	that has to return the map if sucecssful, and then unfreezes the player on
2167	the new (success) or old (failed) map position.	2266	the new (success) or old (failed) map position. In either case, $done will
		2267	be called at the end of this process.
2168		2268
2169	=cut	2269	=cut
2170		2270
2171	our $GOTOGEN;	2271	our $GOTOGEN;
2172		2272
2173	sub cf::object::player::goto {	2273	sub cf::object::player::goto {
2174	my ($self, $path, $x, $y, $check) = @_;	2274	my ($self, $path, $x, $y, $check, $done) = @_;
2175		2275
2176	# do generation counting so two concurrent goto's will be executed in-order	2276	# do generation counting so two concurrent goto's will be executed in-order
2177	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2277	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2178		2278
2179	$self->enter_link;	2279	$self->enter_link;
…		…
2199		2299
2200	if ($gen == $self->{_goto_generation}) {	2300	if ($gen == $self->{_goto_generation}) {
2201	delete $self->{_goto_generation};	2301	delete $self->{_goto_generation};
2202	$self->leave_link ($map, $x, $y);	2302	$self->leave_link ($map, $x, $y);
2203	}	2303	}
		2304
		2305	$done->() if $done;
2204	})->prio (1);	2306	})->prio (1);
2205	}	2307	}
2206		2308
2207	=item $player_object->enter_exit ($exit_object)	2309	=item $player_object->enter_exit ($exit_object)
2208		2310
…		…
2277	my $hp = $exit->stats->hp;	2379	my $hp = $exit->stats->hp;
2278	my $sp = $exit->stats->sp;	2380	my $sp = $exit->stats->sp;
2279		2381
2280	$self->enter_link;	2382	$self->enter_link;
2281		2383
		2384	# if exit is damned, update players death & WoR home-position
		2385	$self->contr->savebed ($slaying, $hp, $sp)
		2386	if $exit->flag (FLAG_DAMNED);
		2387
2282	(async {	2388	(async {
2283	$self->deactivate_recursive; # just to be sure	2389	$self->deactivate_recursive; # just to be sure
2284	unless (eval {	2390	unless (eval {
2285	$self->goto ($slaying, $hp, $sp);	2391	$self->goto ($slaying, $hp, $sp);
2286		2392
…		…
2313		2419
2314	utf8::encode $text;	2420	utf8::encode $text;
2315	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2421	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2316	}	2422	}
2317		2423
		2424	=item $client->send_msg ($color, $type, $msg, [extra...])
		2425
		2426	Send a drawinfo or msg packet to the client, formatting the msg for the
		2427	client if neccessary. C<$type> should be a string identifying the type of
		2428	the message, with C<log> being the default. If C<$color> is negative, suppress
		2429	the message unless the client supports the msg packet.
		2430
		2431	=cut
		2432
		2433	sub cf::client::send_msg {
		2434	my ($self, $color, $type, $msg, @extra) = @_;
		2435
		2436	$msg = $self->pl->expand_cfpod ($msg);
		2437
		2438	return unless @extra \|\| length $msg;
		2439
		2440	if ($self->can_msg) {
		2441	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));
		2442	} else {
		2443	# replace some tags by gcfclient-compatible ones
		2444	for ($msg) {
		2445	1 while
		2446	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2447	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2448	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2449	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2450	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2451	}
		2452
		2453	if ($color >= 0) {
		2454	if (0 && $msg =~ /\[/) {
		2455	$self->send_packet ("drawextinfo $color 4 0 $msg")
		2456	} else {
		2457	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
		2458	$self->send_packet ("drawinfo $color $msg")
		2459	}
		2460	}
		2461	}
		2462	}
		2463
2318	=item $client->ext_event ($type, %msg)	2464	=item $client->ext_event ($type, %msg)
2319		2465
2320	Sends an exti event to the client.	2466	Sends an ext event to the client.
2321		2467
2322	=cut	2468	=cut
2323		2469
2324	sub cf::client::ext_event($$%) {	2470	sub cf::client::ext_event($$%) {
2325	my ($self, $type, %msg) = @_;	2471	my ($self, $type, %msg) = @_;
2326		2472
		2473	return unless $self->extcmd;
		2474
2327	$msg{msgtype} = "event_$type";	2475	$msg{msgtype} = "event_$type";
2328	$self->send_packet ("ext " . cf::to_json \%msg);	2476	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2329	}	2477	}
2330		2478
2331	=item $success = $client->query ($flags, "text", \&cb)	2479	=item $success = $client->query ($flags, "text", \&cb)
2332		2480
2333	Queues a query to the client, calling the given callback with	2481	Queues a query to the client, calling the given callback with
2334	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,	2482	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2335	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.	2483	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2336		2484
2337	Queries can fail, so check the return code. Or don't, as queries will become	2485	Queries can fail, so check the return code. Or don't, as queries will
2338	reliable at some point in the future.	2486	become reliable at some point in the future.
2339		2487
2340	=cut	2488	=cut
2341		2489
2342	sub cf::client::query {	2490	sub cf::client::query {
2343	my ($self, $flags, $text, $cb) = @_;	2491	my ($self, $flags, $text, $cb) = @_;
…		…
2351	utf8::encode $text;	2499	utf8::encode $text;
2352	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];	2500	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2353		2501
2354	$self->send_packet ($self->{query_queue}[0][0])	2502	$self->send_packet ($self->{query_queue}[0][0])
2355	if @{ $self->{query_queue} } == 1;	2503	if @{ $self->{query_queue} } == 1;
		2504
		2505	1
2356	}	2506	}
2357		2507
2358	cf::client->attach (	2508	cf::client->attach (
		2509	on_connect => sub {
		2510	my ($ns) = @_;
		2511
		2512	$ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
		2513	},
2359	on_reply => sub {	2514	on_reply => sub {
2360	my ($ns, $msg) = @_;	2515	my ($ns, $msg) = @_;
2361		2516
2362	# this weird shuffling is so that direct followup queries	2517	# this weird shuffling is so that direct followup queries
2363	# get handled first	2518	# get handled first
…		…
2375	} else {	2530	} else {
2376	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;	2531	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2377	}	2532	}
2378	}	2533	}
2379	},	2534	},
		2535	on_exticmd => sub {
		2536	my ($ns, $buf) = @_;
		2537
		2538	my $msg = eval { $ns->{json_coder}->decode ($buf) };
		2539
		2540	if (ref $msg) {
		2541	if (my $cb = $EXTICMD{$msg->{msgtype}}) {
		2542	if (my %reply = $cb->($ns, $msg)) {
		2543	$reply{msgid} = $msg->{msgid};
		2544	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
		2545	}
		2546	}
		2547	} else {
		2548	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
		2549	}
		2550
		2551	cf::override;
		2552	},
2380	);	2553	);
2381		2554
2382	=item $client->async (\&cb)	2555	=item $client->async (\&cb)
2383		2556
2384	Create a new coroutine, running the specified callback. The coroutine will	2557	Create a new coroutine, running the specified callback. The coroutine will
…		…
2433		2606
2434	=pod	2607	=pod
2435		2608
2436	The following functions and methods are available within a safe environment:	2609	The following functions and methods are available within a safe environment:
2437		2610
2438	cf::object contr pay_amount pay_player map	2611	cf::object
		2612	contr pay_amount pay_player map x y force_find force_add
		2613	insert remove
		2614
2439	cf::object::player player	2615	cf::object::player
2440	cf::player peaceful	2616	player
2441	cf::map trigger	2617
		2618	cf::player
		2619	peaceful
		2620
		2621	cf::map
		2622	trigger
2442		2623
2443	=cut	2624	=cut
2444		2625
2445	for (	2626	for (
2446	["cf::object" => qw(contr pay_amount pay_player map)],	2627	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2628	insert remove)],
2447	["cf::object::player" => qw(player)],	2629	["cf::object::player" => qw(player)],
2448	["cf::player" => qw(peaceful)],	2630	["cf::player" => qw(peaceful)],
2449	["cf::map" => qw(trigger)],	2631	["cf::map" => qw(trigger)],
2450	) {	2632	) {
2451	no strict 'refs';	2633	no strict 'refs';
…		…
2543	{	2725	{
2544	my $faces = $facedata->{faceinfo};	2726	my $faces = $facedata->{faceinfo};
2545		2727
2546	while (my ($face, $info) = each %$faces) {	2728	while (my ($face, $info) = each %$faces) {
2547	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2729	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2548	cf::face::set $idx, $info->{visibility}, $info->{magicmap};	2730	cf::face::set_visibility $idx, $info->{visibility};
		2731	cf::face::set_magicmap $idx, $info->{magicmap};
2549	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2732	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2550	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2733	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2551	Coro::cede;	2734
		2735	cf::cede_to_tick;
2552	}	2736	}
2553		2737
2554	while (my ($face, $info) = each %$faces) {	2738	while (my ($face, $info) = each %$faces) {
2555	next unless $info->{smooth};	2739	next unless $info->{smooth};
2556	my $idx = cf::face::find $face	2740	my $idx = cf::face::find $face
2557	or next;	2741	or next;
2558	if (my $smooth = cf::face::find $info->{smooth}) {	2742	if (my $smooth = cf::face::find $info->{smooth}) {
		2743	cf::face::set_smooth $idx, $smooth;
2559	cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};	2744	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2560	} else {	2745	} else {
2561	warn "smooth face '$info->{smooth}' not found for face '$face'";	2746	warn "smooth face '$info->{smooth}' not found for face '$face'";
2562	}	2747	}
2563	Coro::cede;	2748
		2749	cf::cede_to_tick;
2564	}	2750	}
2565	}	2751	}
2566		2752
2567	{	2753	{
2568	my $anims = $facedata->{animinfo};	2754	my $anims = $facedata->{animinfo};
2569		2755
2570	while (my ($anim, $info) = each %$anims) {	2756	while (my ($anim, $info) = each %$anims) {
2571	cf::anim::set $anim, $info->{frames}, $info->{facings};	2757	cf::anim::set $anim, $info->{frames}, $info->{facings};
2572	Coro::cede;	2758	cf::cede_to_tick;
2573	}	2759	}
2574		2760
2575	cf::anim::invalidate_all; # d'oh	2761	cf::anim::invalidate_all; # d'oh
		2762	}
		2763
		2764	{
		2765	# TODO: for gcfclient pleasure, we should give resources
		2766	# that gcfclient doesn't grok a >10000 face index.
		2767	my $res = $facedata->{resource};
		2768	my $enc = JSON::XS->new->utf8->canonical;
		2769
		2770	while (my ($name, $info) = each %$res) {
		2771	my $meta = $enc->encode ({
		2772	name => $name,
		2773	type => $info->{type},
		2774	copyright => $info->{copyright}, #TODO#
		2775	});
		2776
		2777	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		2778
		2779	if ($name =~ /\.jpg$/) {
		2780	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack
		2781	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack
		2782	} else {
		2783	my $data = pack "(w/a)", $meta, $info->{data};
		2784	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
		2785
		2786	cf::face::set_type $idx, 1;
		2787	cf::face::set_data $idx, 0, $data, $chk;
		2788	}
		2789
		2790	cf::cede_to_tick;
		2791	}
2576	}	2792	}
2577		2793
2578	1	2794	1
2579	}	2795	}
2580		2796
2581	sub reload_regions {	2797	sub reload_regions {
2582	load_resource_file "$MAPDIR/regions"	2798	load_resource_file "$MAPDIR/regions"
2583	or die "unable to load regions file\n";	2799	or die "unable to load regions file\n";
		2800
		2801	for (cf::region::list) {
		2802	$_->{match} = qr/$_->{match}/
		2803	if exists $_->{match};
		2804	}
2584	}	2805	}
2585		2806
2586	sub reload_facedata {	2807	sub reload_facedata {
2587	load_facedata "$DATADIR/facedata"	2808	load_facedata "$DATADIR/facedata"
2588	or die "unable to load facedata\n";	2809	or die "unable to load facedata\n";
2589	}	2810	}
2590		2811
2591	sub reload_archetypes {	2812	sub reload_archetypes {
		2813	load_resource_file "$DATADIR/archetypes"
		2814	or die "unable to load archetypes\n";
		2815	#d# NEED to laod twice to resolve forward references
		2816	# this really needs to be done in an extra post-pass
		2817	# (which needs to be synchronous, so solve it differently)
2592	load_resource_file "$DATADIR/archetypes"	2818	load_resource_file "$DATADIR/archetypes"
2593	or die "unable to load archetypes\n";	2819	or die "unable to load archetypes\n";
2594	}	2820	}
2595		2821
2596	sub reload_treasures {	2822	sub reload_treasures {
…		…
2790	%EXT_CORO = ();	3016	%EXT_CORO = ();
2791		3017
2792	warn "removing commands";	3018	warn "removing commands";
2793	%COMMAND = ();	3019	%COMMAND = ();
2794		3020
2795	warn "removing ext commands";	3021	warn "removing ext/exti commands";
2796	%EXTCMD = ();	3022	%EXTCMD = ();
		3023	%EXTICMD = ();
2797		3024
2798	warn "unloading/nuking all extensions";	3025	warn "unloading/nuking all extensions";
2799	for my $pkg (@EXTS) {	3026	for my $pkg (@EXTS) {
2800	warn "... unloading $pkg";	3027	warn "... unloading $pkg";
2801		3028

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.282 by elmex, Tue Jun 19 18:15:34 2007 UTC vs. Revision 1.309 by elmex, Mon Jul 16 15:27:06 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.282 by elmex, Tue Jun 19 18:15:34 2007 UTC vs.
Revision 1.309 by elmex, Mon Jul 16 15:27:06 2007 UTC