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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.300 by root, Tue Jul 10 06:44:29 2007 UTC vs.
Revision 1.326 by root, Tue Jul 31 17:33:15 2007 UTC

…		…
29	use Fcntl;	29	use Fcntl;
30	use YAML::Syck ();	30	use YAML::Syck ();
31	use IO::AIO 2.32 ();	31	use IO::AIO 2.32 ();
32	use Time::HiRes;	32	use Time::HiRes;
33	use Compress::LZF;	33	use Compress::LZF;
		34	use Digest::MD5 ();
34		35
35	# configure various modules to our taste	36	# configure various modules to our taste
36	#	37	#
37	$Storable::canonical = 1; # reduce rsync transfers	38	$Storable::canonical = 1; # reduce rsync transfers
38	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
…		…
165	=item cf::wait_for_tick, cf::wait_for_tick_begin	166	=item cf::wait_for_tick, cf::wait_for_tick_begin
166		167
167	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	168	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
168	returns directly I<after> the tick processing (and consequently, can only wake one process	169	returns directly I<after> the tick processing (and consequently, can only wake one process
169	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	170	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
		171
		172	=item @cf::INVOKE_RESULTS
		173
		174	This array contains the results of the last C<invoke ()> call. When
		175	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
		176	that call.
170		177
171	=back	178	=back
172		179
173	=cut	180	=cut
174		181
…		…
315	};	322	};
316	$TICK_WATCHER->stop;	323	$TICK_WATCHER->stop;
317	$guard	324	$guard
318	}	325	}
319		326
		327	=item cf::get_slot $time[, $priority[, $name]]
		328
		329	Allocate $time seconds of blocking CPU time at priority C<$priority>:
		330	This call blocks and returns only when you have at least C<$time> seconds
		331	of cpu time till the next tick. The slot is only valid till the next cede.
		332
		333	The optional C<$name> can be used to identify the job to run. It might be
		334	used for statistical purposes and should identify the same time-class.
		335
		336	Useful for short background jobs.
		337
		338	=cut
		339
		340	our @SLOT_QUEUE;
		341	our $SLOT_QUEUE;
		342
		343	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
		344	$SLOT_QUEUE = Coro::async {
		345	my $signal = new Coro::Signal;
		346
		347	while () {
		348	next_job:
		349	my $avail = cf::till_tick;
		350	if ($avail > 0.01) {
		351	for (0 .. $#SLOT_QUEUE) {
		352	if ($SLOT_QUEUE[$_][0] < $avail) {
		353	my $job = splice @SLOT_QUEUE, $_, 1, ();
		354	$job->[2]->send;
		355	Coro::cede;
		356	goto next_job;
		357	}
		358	}
		359	}
		360
		361	if (@SLOT_QUEUE) {
		362	# we do not use wait_For_tick() as it returns immediately when tick is inactive
		363	push @cf::WAIT_FOR_TICK, $signal;
		364	$signal->wait;
		365	} else {
		366	Coro::schedule;
		367	}
		368	}
		369	};
		370
		371	sub get_slot($;$$) {
		372	my ($time, $pri, $name) = @_;
		373
		374	$time = $TICK * .6 if $time > $TICK * .6;
		375	my $sig = new Coro::Signal;
		376
		377	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
		378	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
		379	$SLOT_QUEUE->ready;
		380	$sig->wait;
		381	}
		382
320	=item cf::async { BLOCK }	383	=item cf::async { BLOCK }
321		384
322	Currently the same as Coro::async_pool, meaning you cannot use	385	Currently the same as Coro::async_pool, meaning you cannot use
323	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only	386	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
324	thing you are allowed to do is call C<prio> on it.	387	thing you are allowed to do is call C<prio> on it.
…		…
865	";	928	";
866	die if $@;	929	die if $@;
867	}	930	}
868		931
869	our $override;	932	our $override;
870	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	933	our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
871		934
872	sub override {	935	sub override {
873	$override = 1;	936	$override = 1;
874	@invoke_results = ();	937	@INVOKE_RESULTS = (@_);
875	}	938	}
876		939
877	sub do_invoke {	940	sub do_invoke {
878	my $event = shift;	941	my $event = shift;
879	my $callbacks = shift;	942	my $callbacks = shift;
880		943
881	@invoke_results = ();	944	@INVOKE_RESULTS = ();
882		945
883	local $override;	946	local $override;
884		947
885	for (@$callbacks) {	948	for (@$callbacks) {
886	eval { &{$_->[1]} };	949	eval { &{$_->[1]} };
…		…
903		966
904	Generate an object-specific event with the given arguments.	967	Generate an object-specific event with the given arguments.
905		968
906	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be	969	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
907	removed in future versions), and there is no public API to access override	970	removed in future versions), and there is no public API to access override
908	results (if you must, access C<@cf::invoke_results> directly).	971	results (if you must, access C<@cf::INVOKE_RESULTS> directly).
909		972
910	=back	973	=back
911		974
912	=cut	975	=cut
913		976
914	#############################################################################	977	#############################################################################
915	# object support	978	# object support
		979	#
		980
		981	sub _can_merge {
		982	my ($ob1, $ob2) = @_;
		983
		984	local $Storable::canonical = 1;
		985	my $fob1 = Storable::freeze $ob1;
		986	my $fob2 = Storable::freeze $ob2;
		987
		988	$fob1 eq $fob2
		989	}
916		990
917	sub reattach {	991	sub reattach {
918	# basically do the same as instantiate, without calling instantiate	992	# basically do the same as instantiate, without calling instantiate
919	my ($obj) = @_;	993	my ($obj) = @_;
920		994
…		…
1107	my ($pl, $buf) = @_;	1181	my ($pl, $buf) = @_;
1108		1182
1109	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1183	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1110		1184
1111	if (ref $msg) {	1185	if (ref $msg) {
		1186	my ($type, $reply, @payload) =
		1187	"ARRAY" eq ref $msg
		1188	? @$msg
		1189	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		1190
1112	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1191	if (my $cb = $EXTCMD{$type}) {
1113	if (my %reply = $cb->($pl, $msg)) {	1192	my @reply = $cb->($pl, @payload);
		1193
1114	$pl->ext_reply ($msg->{msgid}, %reply);	1194	$pl->ext_reply ($reply, @reply)
1115	}	1195	if $reply;
1116	}	1196	}
1117	} else {	1197	} else {
1118	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1198	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1119	}	1199	}
1120		1200
…		…
1435	s/\s+\n/\n/g; # ws line-ends	1515	s/\s+\n/\n/g; # ws line-ends
1436	s/\n\n+/\n/g; # double lines	1516	s/\n\n+/\n/g; # double lines
1437	s/^\n+//; # beginning lines	1517	s/^\n+//; # beginning lines
1438	s/\n+$//; # ending lines	1518	s/\n+$//; # ending lines
1439		1519
1440	warn $_;#d#
1441	$_	1520	$_
1442	}	1521	}
1443		1522
1444	sub hintmode {	1523	sub hintmode {
1445	$_[0]{hintmode} = $_[1] if @_ > 1;	1524	$_[0]{hintmode} = $_[1] if @_ > 1;
1446	$_[0]{hintmode}	1525	$_[0]{hintmode}
1447	}	1526	}
1448		1527
1449	=item $player->ext_reply ($msgid, %msg)	1528	=item $player->ext_reply ($msgid, @msg)
1450		1529
1451	Sends an ext reply to the player.	1530	Sends an ext reply to the player.
1452		1531
1453	=cut	1532	=cut
1454		1533
1455	sub ext_reply($$%) {	1534	sub ext_reply($$@) {
1456	my ($self, $id, %msg) = @_;	1535	my ($self, $id, @msg) = @_;
1457		1536
1458	$msg{msgid} = $id;	1537	if ($self->ns->extcmd == 2) {
		1538	$self->send ("ext " . $self->ns->{json_coder}->encode (["reply-$id", @msg]));
		1539	} elsif ($self->ns->extcmd == 1) {
		1540	#TODO: version 1, remove
		1541	unshift @msg, msgtype => "reply", msgid => $id;
1459	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));	1542	$self->send ("ext " . $self->ns->{json_coder}->encode ({@msg}));
		1543	}
1460	}	1544	}
1461		1545
1462	=item $player->ext_event ($type, %msg)	1546	=item $player->ext_msg ($type, @msg)
1463		1547
1464	Sends an ext event to the client.	1548	Sends an ext event to the client.
1465		1549
1466	=cut	1550	=cut
1467		1551
1468	sub ext_event($$%) {	1552	sub ext_msg($$@) {
1469	my ($self, $type, %msg) = @_;	1553	my ($self, $type, @msg) = @_;
1470		1554
1471	$self->ns->ext_event ($type, %msg);	1555	$self->ns->ext_msg ($type, @msg);
1472	}	1556	}
1473		1557
1474	=head3 cf::region	1558	=head3 cf::region
1475		1559
1476	=over 4	1560	=over 4
…		…
1489	my ($path) = @_;	1573	my ($path) = @_;
1490		1574
1491	my ($match, $specificity);	1575	my ($match, $specificity);
1492		1576
1493	for my $region (list) {	1577	for my $region (list) {
1494	if ($region->match && $path =~ $region->match) {	1578	if ($region->{match} && $path =~ $region->{match}) {
1495	($match, $specificity) = ($region, $region->specificity)	1579	($match, $specificity) = ($region, $region->specificity)
1496	if $region->specificity > $specificity;	1580	if $region->specificity > $specificity;
1497	}	1581	}
1498	}	1582	}
1499		1583
…		…
1619	$self->init; # pass $1 etc.	1703	$self->init; # pass $1 etc.
1620	return $self;	1704	return $self;
1621	}	1705	}
1622	}	1706	}
1623		1707
1624	Carp::carp "unable to resolve path '$path' (base '$base').";	1708	Carp::cluck "unable to resolve path '$path' (base '$base').";
1625	()	1709	()
1626	}	1710	}
1627		1711
1628	sub init {	1712	sub init {
1629	my ($self) = @_;	1713	my ($self) = @_;
…		…
1837	$self->set_darkness_map;	1921	$self->set_darkness_map;
1838	Coro::cede;	1922	Coro::cede;
1839	$self->activate;	1923	$self->activate;
1840	}	1924	}
1841		1925
		1926	$self->{last_save} = $cf::RUNTIME;
		1927	$self->last_access ($cf::RUNTIME);
		1928
1842	$self->in_memory (cf::MAP_IN_MEMORY);	1929	$self->in_memory (cf::MAP_IN_MEMORY);
1843	}	1930	}
1844		1931
1845	$self->post_load;	1932	$self->post_load;
1846	}	1933	}
…		…
1907		1994
1908	undef $MAP_PREFETCH{$path};	1995	undef $MAP_PREFETCH{$path};
1909	$MAP_PREFETCHER \|\|= cf::async {	1996	$MAP_PREFETCHER \|\|= cf::async {
1910	while (%MAP_PREFETCH) {	1997	while (%MAP_PREFETCH) {
1911	for my $path (keys %MAP_PREFETCH) {	1998	for my $path (keys %MAP_PREFETCH) {
1912	my $map = find $path	1999	if (my $map = find $path) {
1913	or next;
1914	$map->load;	2000	$map->load;
		2001	}
1915		2002
1916	delete $MAP_PREFETCH{$path};	2003	delete $MAP_PREFETCH{$path};
1917	}	2004	}
1918	}	2005	}
1919	undef $MAP_PREFETCHER;	2006	undef $MAP_PREFETCHER;
…		…
2146		2233
2147	} else {	2234	} else {
2148	my $pl = $self->contr;	2235	my $pl = $self->contr;
2149		2236
2150	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2237	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2151	my $diag = $pl->{npc_dialog};	2238	my $dialog = $pl->{npc_dialog};
2152	$diag->{pl}->ext_reply (	2239	$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		2240
2159	} else {	2241	} else {
2160	$msg = $npc->name . " says: $msg" if $npc;	2242	$msg = $npc->name . " says: $msg" if $npc;
2161	$self->message ($msg, $flags);	2243	$self->message ($msg, $flags);
2162	}	2244	}
…		…
2256		2338
2257	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2339	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2258	$self->enter_map ($map, $x, $y);	2340	$self->enter_map ($map, $x, $y);
2259	}	2341	}
2260		2342
2261	=item $player_object->goto ($path, $x, $y[, $check->($map)])	2343	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2262		2344
2263	Moves the player to the given map-path and coordinates by first freezing	2345	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	2346	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	2347	that has to return the map if sucecssful, and then unfreezes the player on
2266	the new (success) or old (failed) map position.	2348	the new (success) or old (failed) map position. In either case, $done will
		2349	be called at the end of this process.
2267		2350
2268	=cut	2351	=cut
2269		2352
2270	our $GOTOGEN;	2353	our $GOTOGEN;
2271		2354
2272	sub cf::object::player::goto {	2355	sub cf::object::player::goto {
2273	my ($self, $path, $x, $y, $check) = @_;	2356	my ($self, $path, $x, $y, $check, $done) = @_;
2274		2357
2275	# do generation counting so two concurrent goto's will be executed in-order	2358	# do generation counting so two concurrent goto's will be executed in-order
2276	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2359	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2277		2360
2278	$self->enter_link;	2361	$self->enter_link;
…		…
2298		2381
2299	if ($gen == $self->{_goto_generation}) {	2382	if ($gen == $self->{_goto_generation}) {
2300	delete $self->{_goto_generation};	2383	delete $self->{_goto_generation};
2301	$self->leave_link ($map, $x, $y);	2384	$self->leave_link ($map, $x, $y);
2302	}	2385	}
		2386
		2387	$done->() if $done;
2303	})->prio (1);	2388	})->prio (1);
2304	}	2389	}
2305		2390
2306	=item $player_object->enter_exit ($exit_object)	2391	=item $player_object->enter_exit ($exit_object)
2307		2392
…		…
2416		2501
2417	utf8::encode $text;	2502	utf8::encode $text;
2418	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2503	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2419	}	2504	}
2420		2505
2421	=item $client->send_msg ($color, $type, $msg, [extra...])	2506	=item $client->send_msg ($channel, $msg, $color, [extra...])
2422		2507
2423	Send a drawinfo or msg packet to the client, formatting the msg for the	2508	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	2509	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	2510	the message, with C<log> being the default. If C<$color> is negative, suppress
2426	the message unless the client supports the msg packet.	2511	the message unless the client supports the msg packet.
2427		2512
2428	=cut	2513	=cut
2429		2514
2430	sub cf::client::send_msg {	2515	sub cf::client::send_msg {
2431	my ($self, $color, $type, $msg, @extra) = @_;	2516	my ($self, $channel, $msg, $color, @extra) = @_;
2432		2517
2433	$msg = $self->pl->expand_cfpod ($msg);	2518	$msg = $self->pl->expand_cfpod ($msg);
2434		2519
		2520	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2521
		2522	if (ref $channel) {
		2523	# send meta info to client, if not yet sent
		2524	unless (exists $self->{channel}{$channel->{id}}) {
		2525	$self->{channel}{$channel->{id}} = $channel;
		2526	$self->ext_msg (channel_info => $channel);
		2527	}
		2528
		2529	$channel = $channel->{id};
		2530	}
		2531
2435	return unless @extra \|\| length $msg;	2532	return unless @extra \|\| length $msg;
2436		2533
2437	if ($self->can_msg) {	2534	if ($self->can_msg) {
		2535	# default colour, mask it out
		2536	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2537	if $color & cf::NDI_DEF;
		2538
2438	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));	2539	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2540	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2439	} else {	2541	} 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) {	2542	if ($color >= 0) {
		2543	# replace some tags by gcfclient-compatible ones
		2544	for ($msg) {
		2545	1 while
		2546	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2547	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2548	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2549	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2550	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2551	}
		2552
		2553	$color &= cf::NDI_COLOR_MASK;
		2554
2451	if (0 && $msg =~ /\[/) {	2555	if (0 && $msg =~ /\[/) {
2452	$self->send_packet ("drawextinfo $color 4 0 $msg")	2556	$self->send_packet ("drawextinfo $color 4 0 $msg")
2453	} else {	2557	} else {
2454	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2558	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2455	$self->send_packet ("drawinfo $color $msg")	2559	$self->send_packet ("drawinfo $color $msg")
2456	}	2560	}
2457	}	2561	}
2458	}	2562	}
2459	}	2563	}
2460		2564
2461	=item $client->ext_event ($type, %msg)	2565	=item $client->ext_msg ($type, @msg)
2462		2566
2463	Sends an ext event to the client.	2567	Sends an ext event to the client.
2464		2568
2465	=cut	2569	=cut
2466		2570
2467	sub cf::client::ext_event($$%) {	2571	sub cf::client::ext_msg($$@) {
2468	my ($self, $type, %msg) = @_;	2572	my ($self, $type, @msg) = @_;
2469		2573
		2574	my $extcmd = $self->extcmd;
		2575
		2576	if ($extcmd == 2) {
		2577	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2578	} elsif ($extcmd == 1) { # TODO: remove
2470	$msg{msgtype} = "event_$type";	2579	push @msg, msgtype => "event_$type";
2471	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2580	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2581	}
2472	}	2582	}
2473		2583
2474	=item $success = $client->query ($flags, "text", \&cb)	2584	=item $success = $client->query ($flags, "text", \&cb)
2475		2585
2476	Queues a query to the client, calling the given callback with	2586	Queues a query to the client, calling the given callback with
…		…
2531	my ($ns, $buf) = @_;	2641	my ($ns, $buf) = @_;
2532		2642
2533	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2643	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2534		2644
2535	if (ref $msg) {	2645	if (ref $msg) {
		2646	my ($type, $reply, @payload) =
		2647	"ARRAY" eq ref $msg
		2648	? @$msg
		2649	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2650
2536	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2651	if (my $cb = $EXTICMD{$type}) {
2537	if (my %reply = $cb->($ns, $msg)) {	2652	my @reply = $cb->($ns, @payload);
2538	$reply{msgid} = $msg->{msgid};	2653
2539	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));	2654	$ns->ext_reply ($reply, @reply)
2540	}	2655	if $reply;
2541	}	2656	}
2542	} else {	2657	} else {
2543	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2658	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2544	}	2659	}
2545		2660
…		…
2720	{	2835	{
2721	my $faces = $facedata->{faceinfo};	2836	my $faces = $facedata->{faceinfo};
2722		2837
2723	while (my ($face, $info) = each %$faces) {	2838	while (my ($face, $info) = each %$faces) {
2724	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2839	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2725	cf::face::set $idx, $info->{visibility}, $info->{magicmap};	2840	cf::face::set_visibility $idx, $info->{visibility};
		2841	cf::face::set_magicmap $idx, $info->{magicmap};
2726	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2842	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2727	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2843	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2728	Coro::cede;	2844
		2845	cf::cede_to_tick;
2729	}	2846	}
2730		2847
2731	while (my ($face, $info) = each %$faces) {	2848	while (my ($face, $info) = each %$faces) {
2732	next unless $info->{smooth};	2849	next unless $info->{smooth};
2733	my $idx = cf::face::find $face	2850	my $idx = cf::face::find $face
2734	or next;	2851	or next;
2735	if (my $smooth = cf::face::find $info->{smooth}) {	2852	if (my $smooth = cf::face::find $info->{smooth}) {
		2853	cf::face::set_smooth $idx, $smooth;
2736	cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};	2854	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2737	} else {	2855	} else {
2738	warn "smooth face '$info->{smooth}' not found for face '$face'";	2856	warn "smooth face '$info->{smooth}' not found for face '$face'";
2739	}	2857	}
2740	Coro::cede;	2858
		2859	cf::cede_to_tick;
2741	}	2860	}
2742	}	2861	}
2743		2862
2744	{	2863	{
2745	my $anims = $facedata->{animinfo};	2864	my $anims = $facedata->{animinfo};
2746		2865
2747	while (my ($anim, $info) = each %$anims) {	2866	while (my ($anim, $info) = each %$anims) {
2748	cf::anim::set $anim, $info->{frames}, $info->{facings};	2867	cf::anim::set $anim, $info->{frames}, $info->{facings};
2749	Coro::cede;	2868	cf::cede_to_tick;
2750	}	2869	}
2751		2870
2752	cf::anim::invalidate_all; # d'oh	2871	cf::anim::invalidate_all; # d'oh
2753	}	2872	}
2754		2873
		2874	{
		2875	# TODO: for gcfclient pleasure, we should give resources
		2876	# that gcfclient doesn't grok a >10000 face index.
		2877	my $res = $facedata->{resource};
		2878	my $enc = JSON::XS->new->utf8->canonical;
		2879
		2880	my $soundconf = delete $res->{"res/sound.conf"};
		2881
		2882	while (my ($name, $info) = each %$res) {
		2883	my $meta = $enc->encode ({
		2884	name => $name,
		2885	%{ $info->{meta} \|\| {} },
		2886	});
		2887
		2888	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		2889
		2890	if ($info->{type} & 1) {
		2891	# prepend meta info
		2892
		2893	my $data = pack "(w/a)", $meta, $info->{data};
		2894	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
		2895
		2896	cf::face::set_data $idx, 0, $data, $chk;
		2897	} else {
		2898	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};
		2899	}
		2900
		2901	cf::face::set_type $idx, $info->{type};
		2902
		2903	cf::cede_to_tick;
		2904	}
		2905
		2906	if ($soundconf) {
		2907	$soundconf = $enc->decode (delete $soundconf->{data});
		2908
		2909	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		2910	my $sound = $soundconf->{compat}[$_]
		2911	or next;
		2912
		2913	my $face = cf::face::find "sound/$sound->[1]";
		2914	cf::sound::set $sound->[0] => $face;
		2915	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		2916	}
		2917
		2918	while (my ($k, $v) = each %{$soundconf->{event}}) {
		2919	my $face = cf::face::find "sound/$v";
		2920	cf::sound::set $k => $face;
		2921	}
		2922	}
		2923	}
		2924
2755	1	2925	1
2756	}	2926	}
		2927
		2928	register_exticmd fx_want => sub {
		2929	my ($ns, $want) = @_;
		2930
		2931	while (my ($k, $v) = each %$want) {
		2932	$ns->fx_want ($k, $v);
		2933	}
		2934	};
2757		2935
2758	sub reload_regions {	2936	sub reload_regions {
2759	load_resource_file "$MAPDIR/regions"	2937	load_resource_file "$MAPDIR/regions"
2760	or die "unable to load regions file\n";	2938	or die "unable to load regions file\n";
		2939
		2940	for (cf::region::list) {
		2941	$_->{match} = qr/$_->{match}/
		2942	if exists $_->{match};
		2943	}
2761	}	2944	}
2762		2945
2763	sub reload_facedata {	2946	sub reload_facedata {
2764	load_facedata "$DATADIR/facedata"	2947	load_facedata "$DATADIR/facedata"
2765	or die "unable to load facedata\n";	2948	or die "unable to load facedata\n";

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.300 by root, Tue Jul 10 06:44:29 2007 UTC vs. Revision 1.326 by root, Tue Jul 31 17:33:15 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.300 by root, Tue Jul 10 06:44:29 2007 UTC vs.
Revision 1.326 by root, Tue Jul 31 17:33:15 2007 UTC