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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC vs.
Revision 1.332 by root, Sat Aug 18 17:33:53 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 1.4 ();
26	use BDB ();	27	use BDB ();
27	use Data::Dumper;	28	use Data::Dumper;
28	use Digest::MD5;	29	use Digest::MD5;
…		…
166	=item cf::wait_for_tick, cf::wait_for_tick_begin	167	=item cf::wait_for_tick, cf::wait_for_tick_begin
167		168
168	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	169	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
169	returns directly I<after> the tick processing (and consequently, can only wake one process	170	returns directly I<after> the tick processing (and consequently, can only wake one process
170	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	171	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
		172
		173	=item @cf::INVOKE_RESULTS
		174
		175	This array contains the results of the last C<invoke ()> call. When
		176	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
		177	that call.
171		178
172	=back	179	=back
173		180
174	=cut	181	=cut
175		182
…		…
316	};	323	};
317	$TICK_WATCHER->stop;	324	$TICK_WATCHER->stop;
318	$guard	325	$guard
319	}	326	}
320		327
		328	=item cf::get_slot $time[, $priority[, $name]]
		329
		330	Allocate $time seconds of blocking CPU time at priority C<$priority>:
		331	This call blocks and returns only when you have at least C<$time> seconds
		332	of cpu time till the next tick. The slot is only valid till the next cede.
		333
		334	The optional C<$name> can be used to identify the job to run. It might be
		335	used for statistical purposes and should identify the same time-class.
		336
		337	Useful for short background jobs.
		338
		339	=cut
		340
		341	our @SLOT_QUEUE;
		342	our $SLOT_QUEUE;
		343
		344	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
		345	$SLOT_QUEUE = Coro::async {
		346	my $signal = new Coro::Signal;
		347
		348	while () {
		349	next_job:
		350	my $avail = cf::till_tick;
		351	if ($avail > 0.01) {
		352	for (0 .. $#SLOT_QUEUE) {
		353	if ($SLOT_QUEUE[$_][0] < $avail) {
		354	my $job = splice @SLOT_QUEUE, $_, 1, ();
		355	$job->[2]->send;
		356	Coro::cede;
		357	goto next_job;
		358	}
		359	}
		360	}
		361
		362	if (@SLOT_QUEUE) {
		363	# we do not use wait_For_tick() as it returns immediately when tick is inactive
		364	push @cf::WAIT_FOR_TICK, $signal;
		365	$signal->wait;
		366	} else {
		367	Coro::schedule;
		368	}
		369	}
		370	};
		371
		372	sub get_slot($;$$) {
		373	my ($time, $pri, $name) = @_;
		374
		375	$time = $TICK * .6 if $time > $TICK * .6;
		376	my $sig = new Coro::Signal;
		377
		378	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
		379	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
		380	$SLOT_QUEUE->ready;
		381	$sig->wait;
		382	}
		383
321	=item cf::async { BLOCK }	384	=item cf::async { BLOCK }
322		385
323	Currently the same as Coro::async_pool, meaning you cannot use	386	Currently the same as Coro::async_pool, meaning you cannot use
324	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only	387	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
325	thing you are allowed to do is call C<prio> on it.	388	thing you are allowed to do is call C<prio> on it.
…		…
410	Coro::Storable. May, of course, block. Note that the executed sub may	473	Coro::Storable. May, of course, block. Note that the executed sub may
411	never block itself or use any form of Event handling.	474	never block itself or use any form of Event handling.
412		475
413	=cut	476	=cut
414		477
415	sub _store_scalar {
416	open my $fh, ">", \my $buf
417	or die "fork_call: cannot open fh-to-buf in child : $!";
418	Storable::store_fd $_[0], $fh;
419	close $fh;
420
421	$buf
422	}
423
424	sub fork_call(&@) {	478	sub fork_call(&@) {
425	my ($cb, @args) = @_;	479	my ($cb, @args) = @_;
426		480
427	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC	481	# we seemingly have to make a local copy of the whole thing,
428	# or die "socketpair: $!";	482	# otherwise perl prematurely frees the stuff :/
429	pipe my $fh1, my $fh2	483	# TODO: investigate and fix (liekly this will be rather laborious)
430	or die "pipe: $!";
431		484
432	if (my $pid = fork) {	485	my @res = Coro::Util::fork_eval {
433	close $fh2;
434
435	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
436	warn "pst<$res>" unless $res =~ /^pst/;
437	$res = Coro::Storable::thaw $res;
438
439	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
440
441	Carp::confess $$res unless "ARRAY" eq ref $res;
442
443	return wantarray ? @$res : $res->[-1];
444	} else {
445	reset_signals;	486	reset_signals;
446	local $SIG{__WARN__};	487	&$cb
447	local $SIG{__DIE__};	488	}, @args;
448	# just in case, this hack effectively disables event
449	# in the child. cleaner and slower would be canceling all watchers,
450	# but this works for the time being.
451	local $Coro::idle;
452	$Coro::current->prio (Coro::PRIO_MAX);
453		489
454	eval {	490	wantarray ? @res : $res[-1]
455	close $fh1;
456
457	my @res = eval { $cb->(@args) };
458
459	syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
460	close $fh2;
461	};
462
463	warn $@ if $@;
464	_exit 0;
465	}
466	}	491	}
467		492
468	=item $value = cf::db_get $family => $key	493	=item $value = cf::db_get $family => $key
469		494
470	Returns a single value from the environment database.	495	Returns a single value from the environment database.
…		…
866	";	891	";
867	die if $@;	892	die if $@;
868	}	893	}
869		894
870	our $override;	895	our $override;
871	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	896	our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
872		897
873	sub override {	898	sub override {
874	$override = 1;	899	$override = 1;
875	@invoke_results = ();	900	@INVOKE_RESULTS = (@_);
876	}	901	}
877		902
878	sub do_invoke {	903	sub do_invoke {
879	my $event = shift;	904	my $event = shift;
880	my $callbacks = shift;	905	my $callbacks = shift;
881		906
882	@invoke_results = ();	907	@INVOKE_RESULTS = ();
883		908
884	local $override;	909	local $override;
885		910
886	for (@$callbacks) {	911	for (@$callbacks) {
887	eval { &{$_->[1]} };	912	eval { &{$_->[1]} };
…		…
904		929
905	Generate an object-specific event with the given arguments.	930	Generate an object-specific event with the given arguments.
906		931
907	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be	932	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
908	removed in future versions), and there is no public API to access override	933	removed in future versions), and there is no public API to access override
909	results (if you must, access C<@cf::invoke_results> directly).	934	results (if you must, access C<@cf::INVOKE_RESULTS> directly).
910		935
911	=back	936	=back
912		937
913	=cut	938	=cut
914		939
915	#############################################################################	940	#############################################################################
916	# object support	941	# object support
		942	#
		943
		944	sub _can_merge {
		945	my ($ob1, $ob2) = @_;
		946
		947	local $Storable::canonical = 1;
		948	my $fob1 = Storable::freeze $ob1;
		949	my $fob2 = Storable::freeze $ob2;
		950
		951	$fob1 eq $fob2
		952	}
917		953
918	sub reattach {	954	sub reattach {
919	# basically do the same as instantiate, without calling instantiate	955	# basically do the same as instantiate, without calling instantiate
920	my ($obj) = @_;	956	my ($obj) = @_;
921		957
…		…
1108	my ($pl, $buf) = @_;	1144	my ($pl, $buf) = @_;
1109		1145
1110	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1146	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1111		1147
1112	if (ref $msg) {	1148	if (ref $msg) {
		1149	my ($type, $reply, @payload) =
		1150	"ARRAY" eq ref $msg
		1151	? @$msg
		1152	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		1153
1113	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1154	if (my $cb = $EXTCMD{$type}) {
1114	if (my %reply = $cb->($pl, $msg)) {	1155	my @reply = $cb->($pl, @payload);
		1156
1115	$pl->ext_reply ($msg->{msgid}, %reply);	1157	$pl->ext_reply ($reply, @reply)
1116	}	1158	if $reply;
1117	}	1159	}
1118	} else {	1160	} else {
1119	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1161	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1120	}	1162	}
1121		1163
…		…
1291	$self->{deny_save} = 1;	1333	$self->{deny_save} = 1;
1292		1334
1293	$cf::PLAYER{$login} = $self;	1335	$cf::PLAYER{$login} = $self;
1294		1336
1295	$self	1337	$self
		1338	}
		1339
		1340	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1341
		1342	=cut
		1343
		1344	sub send_msg {
		1345	my $ns = shift->ns
		1346	or return;
		1347	$ns->send_msg (@_);
1296	}	1348	}
1297		1349
1298	=item $pl->quit_character	1350	=item $pl->quit_character
1299		1351
1300	Nukes the player without looking back. If logged in, the connection will	1352	Nukes the player without looking back. If logged in, the connection will
…		…
1444	sub hintmode {	1496	sub hintmode {
1445	$_[0]{hintmode} = $_[1] if @_ > 1;	1497	$_[0]{hintmode} = $_[1] if @_ > 1;
1446	$_[0]{hintmode}	1498	$_[0]{hintmode}
1447	}	1499	}
1448		1500
1449	=item $player->ext_reply ($msgid, %msg)	1501	=item $player->ext_reply ($msgid, @msg)
1450		1502
1451	Sends an ext reply to the player.	1503	Sends an ext reply to the player.
1452		1504
1453	=cut	1505	=cut
1454		1506
1455	sub ext_reply($$%) {	1507	sub ext_reply($$@) {
1456	my ($self, $id, %msg) = @_;	1508	my ($self, $id, @msg) = @_;
1457		1509
1458	$msg{msgid} = $id;	1510	if ($self->ns->extcmd == 2) {
		1511	$self->send ("ext " . $self->ns->{json_coder}->encode (["reply-$id", @msg]));
		1512	} elsif ($self->ns->extcmd == 1) {
		1513	#TODO: version 1, remove
		1514	unshift @msg, msgtype => "reply", msgid => $id;
1459	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));	1515	$self->send ("ext " . $self->ns->{json_coder}->encode ({@msg}));
		1516	}
1460	}	1517	}
1461		1518
1462	=item $player->ext_event ($type, %msg)	1519	=item $player->ext_msg ($type, @msg)
1463		1520
1464	Sends an ext event to the client.	1521	Sends an ext event to the client.
1465		1522
1466	=cut	1523	=cut
1467		1524
1468	sub ext_event($$%) {	1525	sub ext_msg($$@) {
1469	my ($self, $type, %msg) = @_;	1526	my ($self, $type, @msg) = @_;
1470		1527
1471	$self->ns->ext_event ($type, %msg);	1528	$self->ns->ext_msg ($type, @msg);
1472	}	1529	}
1473		1530
1474	=head3 cf::region	1531	=head3 cf::region
1475		1532
1476	=over 4	1533	=over 4
…		…
1837	$self->set_darkness_map;	1894	$self->set_darkness_map;
1838	Coro::cede;	1895	Coro::cede;
1839	$self->activate;	1896	$self->activate;
1840	}	1897	}
1841		1898
		1899	$self->{last_save} = $cf::RUNTIME;
		1900	$self->last_access ($cf::RUNTIME);
		1901
1842	$self->in_memory (cf::MAP_IN_MEMORY);	1902	$self->in_memory (cf::MAP_IN_MEMORY);
1843	}	1903	}
1844		1904
1845	$self->post_load;	1905	$self->post_load;
1846	}	1906	}
…		…
2146		2206
2147	} else {	2207	} else {
2148	my $pl = $self->contr;	2208	my $pl = $self->contr;
2149		2209
2150	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2210	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2151	my $diag = $pl->{npc_dialog};	2211	my $dialog = $pl->{npc_dialog};
2152	$diag->{pl}->ext_reply (	2212	$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		2213
2159	} else {	2214	} else {
2160	$msg = $npc->name . " says: $msg" if $npc;	2215	$msg = $npc->name . " says: $msg" if $npc;
2161	$self->message ($msg, $flags);	2216	$self->message ($msg, $flags);
2162	}	2217	}
2163	}	2218	}
		2219	}
		2220
		2221	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2222
		2223	=cut
		2224
		2225	sub cf::object::send_msg {
		2226	my $pl = shift->contr
		2227	or return;
		2228	$pl->send_msg (@_);
2164	}	2229	}
2165		2230
2166	=item $player_object->may ("access")	2231	=item $player_object->may ("access")
2167		2232
2168	Returns wether the given player is authorized to access resource "access"	2233	Returns wether the given player is authorized to access resource "access"
…		…
2419		2484
2420	utf8::encode $text;	2485	utf8::encode $text;
2421	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2486	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2422	}	2487	}
2423		2488
2424	=item $client->send_msg ($color, $type, $msg, [extra...])	2489	=item $client->send_msg ($channel, $msg, $color, [extra...])
2425		2490
2426	Send a drawinfo or msg packet to the client, formatting the msg for the	2491	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	2492	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	2493	the message, with C<log> being the default. If C<$color> is negative, suppress
2429	the message unless the client supports the msg packet.	2494	the message unless the client supports the msg packet.
2430		2495
2431	=cut	2496	=cut
2432		2497
2433	sub cf::client::send_msg {	2498	sub cf::client::send_msg {
2434	my ($self, $color, $type, $msg, @extra) = @_;	2499	my ($self, $channel, $msg, $color, @extra) = @_;
2435		2500
2436	$msg = $self->pl->expand_cfpod ($msg);	2501	$msg = $self->pl->expand_cfpod ($msg);
2437		2502
		2503	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2504
		2505	if (ref $channel) {
		2506	# send meta info to client, if not yet sent
		2507	unless (exists $self->{channel}{$channel->{id}}) {
		2508	$self->{channel}{$channel->{id}} = $channel;
		2509	$self->ext_msg (channel_info => $channel);
		2510	}
		2511
		2512	$channel = $channel->{id};
		2513	}
		2514
2438	return unless @extra \|\| length $msg;	2515	return unless @extra \|\| length $msg;
2439		2516
2440	if ($self->can_msg) {	2517	if ($self->can_msg) {
		2518	# default colour, mask it out
		2519	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2520	if $color & cf::NDI_DEF;
		2521
2441	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));	2522	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2523	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2442	} else {	2524	} 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) {	2525	if ($color >= 0) {
		2526	# replace some tags by gcfclient-compatible ones
		2527	for ($msg) {
		2528	1 while
		2529	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2530	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2531	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2532	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2533	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2534	}
		2535
		2536	$color &= cf::NDI_COLOR_MASK;
		2537
		2538	utf8::encode $msg;
		2539
2454	if (0 && $msg =~ /\[/) {	2540	if (0 && $msg =~ /\[/) {
		2541	# COMMAND/INFO
2455	$self->send_packet ("drawextinfo $color 4 0 $msg")	2542	$self->send_packet ("drawextinfo $color 10 8 $msg")
2456	} else {	2543	} else {
2457	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2544	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2458	$self->send_packet ("drawinfo $color $msg")	2545	$self->send_packet ("drawinfo $color $msg")
2459	}	2546	}
2460	}	2547	}
2461	}	2548	}
2462	}	2549	}
2463		2550
2464	=item $client->ext_event ($type, %msg)	2551	=item $client->ext_msg ($type, @msg)
2465		2552
2466	Sends an ext event to the client.	2553	Sends an ext event to the client.
2467		2554
2468	=cut	2555	=cut
2469		2556
2470	sub cf::client::ext_event($$%) {	2557	sub cf::client::ext_msg($$@) {
2471	my ($self, $type, %msg) = @_;	2558	my ($self, $type, @msg) = @_;
2472		2559
2473	return unless $self->extcmd;	2560	my $extcmd = $self->extcmd;
2474		2561
		2562	if ($extcmd == 2) {
		2563	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2564	} elsif ($extcmd == 1) { # TODO: remove
2475	$msg{msgtype} = "event_$type";	2565	push @msg, msgtype => "event_$type";
2476	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2566	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2567	}
2477	}	2568	}
2478		2569
2479	=item $success = $client->query ($flags, "text", \&cb)	2570	=item $success = $client->query ($flags, "text", \&cb)
2480		2571
2481	Queues a query to the client, calling the given callback with	2572	Queues a query to the client, calling the given callback with
…		…
2536	my ($ns, $buf) = @_;	2627	my ($ns, $buf) = @_;
2537		2628
2538	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2629	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2539		2630
2540	if (ref $msg) {	2631	if (ref $msg) {
		2632	my ($type, $reply, @payload) =
		2633	"ARRAY" eq ref $msg
		2634	? @$msg
		2635	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2636
2541	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2637	if (my $cb = $EXTICMD{$type}) {
2542	if (my %reply = $cb->($ns, $msg)) {	2638	my @reply = $cb->($ns, @payload);
2543	$reply{msgid} = $msg->{msgid};	2639
2544	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));	2640	$ns->ext_reply ($reply, @reply)
2545	}	2641	if $reply;
2546	}	2642	}
2547	} else {	2643	} else {
2548	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2644	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2549	}	2645	}
2550		2646
…		…
2598	our $safe = new Safe "safe";	2694	our $safe = new Safe "safe";
2599	our $safe_hole = new Safe::Hole;	2695	our $safe_hole = new Safe::Hole;
2600		2696
2601	$SIG{FPE} = 'IGNORE';	2697	$SIG{FPE} = 'IGNORE';
2602		2698
2603	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2699	$safe->permit_only (Opcode::opset qw(
		2700	:base_core :base_mem :base_orig :base_math
		2701	grepstart grepwhile mapstart mapwhile
		2702	sort time
		2703	));
2604		2704
2605	# here we export the classes and methods available to script code	2705	# here we export the classes and methods available to script code
2606		2706
2607	=pod	2707	=pod
2608		2708
2609	The following functions and methods are available within a safe environment:	2709	The following functions and methods are available within a safe environment:
2610		2710
2611	cf::object	2711	cf::object
2612	contr pay_amount pay_player map x y force_find force_add	2712	contr pay_amount pay_player map x y force_find force_add
2613	insert remove	2713	insert remove name archname title slaying race
2614		2714
2615	cf::object::player	2715	cf::object::player
2616	player	2716	player
2617		2717
2618	cf::player	2718	cf::player
…		…
2623		2723
2624	=cut	2724	=cut
2625		2725
2626	for (	2726	for (
2627	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2727	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2628	insert remove)],	2728	insert remove inv name archname title slaying race)],
2629	["cf::object::player" => qw(player)],	2729	["cf::object::player" => qw(player)],
2630	["cf::player" => qw(peaceful)],	2730	["cf::player" => qw(peaceful)],
2631	["cf::map" => qw(trigger)],	2731	["cf::map" => qw(trigger)],
2632	) {	2732	) {
2633	no strict 'refs';	2733	no strict 'refs';
…		…
2765	# TODO: for gcfclient pleasure, we should give resources	2865	# TODO: for gcfclient pleasure, we should give resources
2766	# that gcfclient doesn't grok a >10000 face index.	2866	# that gcfclient doesn't grok a >10000 face index.
2767	my $res = $facedata->{resource};	2867	my $res = $facedata->{resource};
2768	my $enc = JSON::XS->new->utf8->canonical;	2868	my $enc = JSON::XS->new->utf8->canonical;
2769		2869
		2870	my $soundconf = delete $res->{"res/sound.conf"};
		2871
2770	while (my ($name, $info) = each %$res) {	2872	while (my ($name, $info) = each %$res) {
2771	my $meta = $enc->encode ({	2873	my $meta = $enc->encode ({
2772	name => $name,	2874	name => $name,
2773	type => $info->{type},	2875	%{ $info->{meta} \|\| {} },
2774	copyright => $info->{copyright}, #TODO#
2775	});	2876	});
2776		2877
2777	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	2878	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
2778		2879
2779	if ($name =~ /\.jpg$/) {	2880	if ($info->{type} & 1) {
2780	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack	2881	# prepend meta info
2781	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack	2882
2782	} else {
2783	my $data = pack "(w/a)", $meta, $info->{data};	2883	my $data = pack "(w/a)", $meta, $info->{data};
2784	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata	2884	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2785		2885
2786	cf::face::set_type $idx, 1;
2787	cf::face::set_data $idx, 0, $data, $chk;	2886	cf::face::set_data $idx, 0, $data, $chk;
		2887	} else {
		2888	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};
2788	}	2889	}
2789		2890
		2891	cf::face::set_type $idx, $info->{type};
		2892
2790	cf::cede_to_tick;	2893	cf::cede_to_tick;
2791	}	2894	}
		2895
		2896	if ($soundconf) {
		2897	$soundconf = $enc->decode (delete $soundconf->{data});
		2898
		2899	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		2900	my $sound = $soundconf->{compat}[$_]
		2901	or next;
		2902
		2903	my $face = cf::face::find "sound/$sound->[1]";
		2904	cf::sound::set $sound->[0] => $face;
		2905	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		2906	}
		2907
		2908	while (my ($k, $v) = each %{$soundconf->{event}}) {
		2909	my $face = cf::face::find "sound/$v";
		2910	cf::sound::set $k => $face;
		2911	}
		2912	}
2792	}	2913	}
2793		2914
2794	1	2915	1
2795	}	2916	}
		2917
		2918	register_exticmd fx_want => sub {
		2919	my ($ns, $want) = @_;
		2920
		2921	while (my ($k, $v) = each %$want) {
		2922	$ns->fx_want ($k, $v);
		2923	}
		2924	};
2796		2925
2797	sub reload_regions {	2926	sub reload_regions {
2798	load_resource_file "$MAPDIR/regions"	2927	load_resource_file "$MAPDIR/regions"
2799	or die "unable to load regions file\n";	2928	or die "unable to load regions file\n";
2800		2929

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC vs. Revision 1.332 by root, Sat Aug 18 17:33:53 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC vs.
Revision 1.332 by root, Sat Aug 18 17:33:53 2007 UTC