[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.335 by root, Mon Aug 20 22:21:48 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;
29	use Fcntl;	30	use Fcntl;
30	use YAML::Syck ();	31	use YAML::Syck ();
31	use IO::AIO 2.32 ();	32	use IO::AIO 2.32 ();
32	use Time::HiRes;	33	use Time::HiRes;
33	use Compress::LZF;	34	use Compress::LZF;
		35	use Digest::MD5 ();
34		36
35	# configure various modules to our taste	37	# configure various modules to our taste
36	#	38	#
37	$Storable::canonical = 1; # reduce rsync transfers	39	$Storable::canonical = 1; # reduce rsync transfers
38	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator	40	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	167	=item cf::wait_for_tick, cf::wait_for_tick_begin
166		168
167	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
168	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
169	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.
170		178
171	=back	179	=back
172		180
173	=cut	181	=cut
174		182
…		…
315	};	323	};
316	$TICK_WATCHER->stop;	324	$TICK_WATCHER->stop;
317	$guard	325	$guard
318	}	326	}
319		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
320	=item cf::async { BLOCK }	384	=item cf::async { BLOCK }
321		385
322	Currently the same as Coro::async_pool, meaning you cannot use	386	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	387	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.	388	thing you are allowed to do is call C<prio> on it.
…		…
409	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
410	never block itself or use any form of Event handling.	474	never block itself or use any form of Event handling.
411		475
412	=cut	476	=cut
413		477
414	sub _store_scalar {
415	open my $fh, ">", \my $buf
416	or die "fork_call: cannot open fh-to-buf in child : $!";
417	Storable::store_fd $_[0], $fh;
418	close $fh;
419
420	$buf
421	}
422
423	sub fork_call(&@) {	478	sub fork_call(&@) {
424	my ($cb, @args) = @_;	479	my ($cb, @args) = @_;
425		480
426	# 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,
427	# or die "socketpair: $!";	482	# otherwise perl prematurely frees the stuff :/
428	pipe my $fh1, my $fh2	483	# TODO: investigate and fix (liekly this will be rather laborious)
429	or die "pipe: $!";
430		484
431	if (my $pid = fork) {	485	my @res = Coro::Util::fork_eval {
432	close $fh2;
433
434	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
435	warn "pst<$res>" unless $res =~ /^pst/;
436	$res = Coro::Storable::thaw $res;
437
438	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
439
440	Carp::confess $$res unless "ARRAY" eq ref $res;
441
442	return wantarray ? @$res : $res->[-1];
443	} else {
444	reset_signals;	486	reset_signals;
445	local $SIG{__WARN__};	487	&$cb
446	local $SIG{__DIE__};	488	}, @args;
447	# just in case, this hack effectively disables event
448	# in the child. cleaner and slower would be canceling all watchers,
449	# but this works for the time being.
450	local $Coro::idle;
451	$Coro::current->prio (Coro::PRIO_MAX);
452		489
453	eval {	490	wantarray ? @res : $res[-1]
454	close $fh1;
455
456	my @res = eval { $cb->(@args) };
457
458	syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
459	close $fh2;
460	};
461
462	warn $@ if $@;
463	_exit 0;
464	}
465	}	491	}
466		492
467	=item $value = cf::db_get $family => $key	493	=item $value = cf::db_get $family => $key
468		494
469	Returns a single value from the environment database.	495	Returns a single value from the environment database.
…		…
865	";	891	";
866	die if $@;	892	die if $@;
867	}	893	}
868		894
869	our $override;	895	our $override;
870	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?
871		897
872	sub override {	898	sub override {
873	$override = 1;	899	$override = 1;
874	@invoke_results = ();	900	@INVOKE_RESULTS = (@_);
875	}	901	}
876		902
877	sub do_invoke {	903	sub do_invoke {
878	my $event = shift;	904	my $event = shift;
879	my $callbacks = shift;	905	my $callbacks = shift;
880		906
881	@invoke_results = ();	907	@INVOKE_RESULTS = ();
882		908
883	local $override;	909	local $override;
884		910
885	for (@$callbacks) {	911	for (@$callbacks) {
886	eval { &{$_->[1]} };	912	eval { &{$_->[1]} };
…		…
903		929
904	Generate an object-specific event with the given arguments.	930	Generate an object-specific event with the given arguments.
905		931
906	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
907	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
908	results (if you must, access C<@cf::invoke_results> directly).	934	results (if you must, access C<@cf::INVOKE_RESULTS> directly).
909		935
910	=back	936	=back
911		937
912	=cut	938	=cut
913		939
914	#############################################################################	940	#############################################################################
915	# 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	}
916		953
917	sub reattach {	954	sub reattach {
918	# basically do the same as instantiate, without calling instantiate	955	# basically do the same as instantiate, without calling instantiate
919	my ($obj) = @_;	956	my ($obj) = @_;
920		957
…		…
1107	my ($pl, $buf) = @_;	1144	my ($pl, $buf) = @_;
1108		1145
1109	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1146	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1110		1147
1111	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
1112	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1154	if (my $cb = $EXTCMD{$type}) {
1113	if (my %reply = $cb->($pl, $msg)) {	1155	my @reply = $cb->($pl, @payload);
		1156
1114	$pl->ext_reply ($msg->{msgid}, %reply);	1157	$pl->ext_reply ($reply, @reply)
1115	}	1158	if $reply;
1116	}	1159	}
1117	} else {	1160	} else {
1118	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1161	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1119	}	1162	}
1120		1163
…		…
1290	$self->{deny_save} = 1;	1333	$self->{deny_save} = 1;
1291		1334
1292	$cf::PLAYER{$login} = $self;	1335	$cf::PLAYER{$login} = $self;
1293		1336
1294	$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 (@_);
1295	}	1348	}
1296		1349
1297	=item $pl->quit_character	1350	=item $pl->quit_character
1298		1351
1299	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
…		…
1435	s/\s+\n/\n/g; # ws line-ends	1488	s/\s+\n/\n/g; # ws line-ends
1436	s/\n\n+/\n/g; # double lines	1489	s/\n\n+/\n/g; # double lines
1437	s/^\n+//; # beginning lines	1490	s/^\n+//; # beginning lines
1438	s/\n+$//; # ending lines	1491	s/\n+$//; # ending lines
1439		1492
1440	warn $_;#d#
1441	$_	1493	$_
1442	}	1494	}
1443		1495
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
…		…
1489	my ($path) = @_;	1546	my ($path) = @_;
1490		1547
1491	my ($match, $specificity);	1548	my ($match, $specificity);
1492		1549
1493	for my $region (list) {	1550	for my $region (list) {
1494	if ($region->match && $path =~ $region->match) {	1551	if ($region->{match} && $path =~ $region->{match}) {
1495	($match, $specificity) = ($region, $region->specificity)	1552	($match, $specificity) = ($region, $region->specificity)
1496	if $region->specificity > $specificity;	1553	if $region->specificity > $specificity;
1497	}	1554	}
1498	}	1555	}
1499		1556
…		…
1619	$self->init; # pass $1 etc.	1676	$self->init; # pass $1 etc.
1620	return $self;	1677	return $self;
1621	}	1678	}
1622	}	1679	}
1623		1680
1624	Carp::carp "unable to resolve path '$path' (base '$base').";	1681	Carp::cluck "unable to resolve path '$path' (base '$base').";
1625	()	1682	()
1626	}	1683	}
1627		1684
1628	sub init {	1685	sub init {
1629	my ($self) = @_;	1686	my ($self) = @_;
…		…
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	}
…		…
1856		1916
1857	$self	1917	$self
1858	}	1918	}
1859		1919
1860	# find and load all maps in the 3x3 area around a map	1920	# find and load all maps in the 3x3 area around a map
1861	sub load_diag {	1921	sub load_neighbours {
1862	my ($map) = @_;	1922	my ($map) = @_;
1863		1923
1864	my @diag; # diagonal neighbours	1924	my @neigh; # diagonal neighbours
1865		1925
1866	for (0 .. 3) {	1926	for (0 .. 3) {
1867	my $neigh = $map->tile_path ($_)	1927	my $neigh = $map->tile_path ($_)
1868	or next;	1928	or next;
1869	$neigh = find $neigh, $map	1929	$neigh = find $neigh, $map
1870	or next;	1930	or next;
1871	$neigh->load;	1931	$neigh->load;
1872		1932
		1933	push @neigh,
1873	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],	1934	[$neigh->tile_path (($_ + 3) % 4), $neigh],
1874	[$neigh->tile_path (($_ + 1) % 4), $neigh];	1935	[$neigh->tile_path (($_ + 1) % 4), $neigh];
1875	}	1936	}
1876		1937
1877	for (@diag) {	1938	for (grep defined $_->[0], @neigh) {
		1939	my ($path, $origin) = @$_;
1878	my $neigh = find @$_	1940	my $neigh = find $path, $origin
1879	or next;	1941	or next;
1880	$neigh->load;	1942	$neigh->load;
1881	}	1943	}
1882	}	1944	}
1883		1945
…		…
1907		1969
1908	undef $MAP_PREFETCH{$path};	1970	undef $MAP_PREFETCH{$path};
1909	$MAP_PREFETCHER \|\|= cf::async {	1971	$MAP_PREFETCHER \|\|= cf::async {
1910	while (%MAP_PREFETCH) {	1972	while (%MAP_PREFETCH) {
1911	for my $path (keys %MAP_PREFETCH) {	1973	for my $path (keys %MAP_PREFETCH) {
1912	my $map = find $path	1974	if (my $map = find $path) {
1913	or next;
1914	$map->load;	1975	$map->load;
		1976	}
1915		1977
1916	delete $MAP_PREFETCH{$path};	1978	delete $MAP_PREFETCH{$path};
1917	}	1979	}
1918	}	1980	}
1919	undef $MAP_PREFETCHER;	1981	undef $MAP_PREFETCHER;
…		…
2146		2208
2147	} else {	2209	} else {
2148	my $pl = $self->contr;	2210	my $pl = $self->contr;
2149		2211
2150	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2212	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2151	my $diag = $pl->{npc_dialog};	2213	my $dialog = $pl->{npc_dialog};
2152	$diag->{pl}->ext_reply (	2214	$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		2215
2159	} else {	2216	} else {
2160	$msg = $npc->name . " says: $msg" if $npc;	2217	$msg = $npc->name . " says: $msg" if $npc;
2161	$self->message ($msg, $flags);	2218	$self->message ($msg, $flags);
2162	}	2219	}
2163	}	2220	}
		2221	}
		2222
		2223	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2224
		2225	=cut
		2226
		2227	sub cf::object::send_msg {
		2228	my $pl = shift->contr
		2229	or return;
		2230	$pl->send_msg (@_);
2164	}	2231	}
2165		2232
2166	=item $player_object->may ("access")	2233	=item $player_object->may ("access")
2167		2234
2168	Returns wether the given player is authorized to access resource "access"	2235	Returns wether the given player is authorized to access resource "access"
…		…
2247	# use -1 or undef as default coordinates, not 0, 0	2314	# use -1 or undef as default coordinates, not 0, 0
2248	($x, $y) = ($map->enter_x, $map->enter_y)	2315	($x, $y) = ($map->enter_x, $map->enter_y)
2249	if $x <=0 && $y <= 0;	2316	if $x <=0 && $y <= 0;
2250		2317
2251	$map->load;	2318	$map->load;
2252	$map->load_diag;	2319	$map->load_neighbours;
2253		2320
2254	return unless $self->contr->active;	2321	return unless $self->contr->active;
2255	$self->activate_recursive;	2322	$self->activate_recursive;
2256		2323
2257	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2324	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2258	$self->enter_map ($map, $x, $y);	2325	$self->enter_map ($map, $x, $y);
2259	}	2326	}
2260		2327
2261	=item $player_object->goto ($path, $x, $y[, $check->($map)])	2328	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2262		2329
2263	Moves the player to the given map-path and coordinates by first freezing	2330	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	2331	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	2332	that has to return the map if sucecssful, and then unfreezes the player on
2266	the new (success) or old (failed) map position.	2333	the new (success) or old (failed) map position. In either case, $done will
		2334	be called at the end of this process.
2267		2335
2268	=cut	2336	=cut
2269		2337
2270	our $GOTOGEN;	2338	our $GOTOGEN;
2271		2339
2272	sub cf::object::player::goto {	2340	sub cf::object::player::goto {
2273	my ($self, $path, $x, $y, $check) = @_;	2341	my ($self, $path, $x, $y, $check, $done) = @_;
2274		2342
2275	# do generation counting so two concurrent goto's will be executed in-order	2343	# do generation counting so two concurrent goto's will be executed in-order
2276	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2344	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2277		2345
2278	$self->enter_link;	2346	$self->enter_link;
…		…
2298		2366
2299	if ($gen == $self->{_goto_generation}) {	2367	if ($gen == $self->{_goto_generation}) {
2300	delete $self->{_goto_generation};	2368	delete $self->{_goto_generation};
2301	$self->leave_link ($map, $x, $y);	2369	$self->leave_link ($map, $x, $y);
2302	}	2370	}
		2371
		2372	$done->() if $done;
2303	})->prio (1);	2373	})->prio (1);
2304	}	2374	}
2305		2375
2306	=item $player_object->enter_exit ($exit_object)	2376	=item $player_object->enter_exit ($exit_object)
2307		2377
…		…
2416		2486
2417	utf8::encode $text;	2487	utf8::encode $text;
2418	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2488	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2419	}	2489	}
2420		2490
2421	=item $client->send_msg ($color, $type, $msg, [extra...])	2491	=item $client->send_msg ($channel, $msg, $color, [extra...])
2422		2492
2423	Send a drawinfo or msg packet to the client, formatting the msg for the	2493	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	2494	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	2495	the message, with C<log> being the default. If C<$color> is negative, suppress
2426	the message unless the client supports the msg packet.	2496	the message unless the client supports the msg packet.
2427		2497
2428	=cut	2498	=cut
2429		2499
2430	sub cf::client::send_msg {	2500	sub cf::client::send_msg {
2431	my ($self, $color, $type, $msg, @extra) = @_;	2501	my ($self, $channel, $msg, $color, @extra) = @_;
2432		2502
2433	$msg = $self->pl->expand_cfpod ($msg);	2503	$msg = $self->pl->expand_cfpod ($msg);
2434		2504
		2505	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2506
		2507	if (ref $channel) {
		2508	# send meta info to client, if not yet sent
		2509	unless (exists $self->{channel}{$channel->{id}}) {
		2510	$self->{channel}{$channel->{id}} = $channel;
		2511	$self->ext_msg (channel_info => $channel);
		2512	}
		2513
		2514	$channel = $channel->{id};
		2515	}
		2516
2435	return unless @extra \|\| length $msg;	2517	return unless @extra \|\| length $msg;
2436		2518
2437	if ($self->can_msg) {	2519	if ($self->can_msg) {
		2520	# default colour, mask it out
		2521	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2522	if $color & cf::NDI_DEF;
		2523
2438	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));	2524	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2525	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2439	} else {	2526	} 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) {	2527	if ($color >= 0) {
		2528	# replace some tags by gcfclient-compatible ones
		2529	for ($msg) {
		2530	1 while
		2531	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2532	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2533	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2534	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2535	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2536	}
		2537
		2538	$color &= cf::NDI_COLOR_MASK;
		2539
		2540	utf8::encode $msg;
		2541
2451	if (0 && $msg =~ /\[/) {	2542	if (0 && $msg =~ /\[/) {
		2543	# COMMAND/INFO
2452	$self->send_packet ("drawextinfo $color 4 0 $msg")	2544	$self->send_packet ("drawextinfo $color 10 8 $msg")
2453	} else {	2545	} else {
2454	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2546	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2455	$self->send_packet ("drawinfo $color $msg")	2547	$self->send_packet ("drawinfo $color $msg")
2456	}	2548	}
2457	}	2549	}
2458	}	2550	}
2459	}	2551	}
2460		2552
2461	=item $client->ext_event ($type, %msg)	2553	=item $client->ext_msg ($type, @msg)
2462		2554
2463	Sends an ext event to the client.	2555	Sends an ext event to the client.
2464		2556
2465	=cut	2557	=cut
2466		2558
2467	sub cf::client::ext_event($$%) {	2559	sub cf::client::ext_msg($$@) {
2468	my ($self, $type, %msg) = @_;	2560	my ($self, $type, @msg) = @_;
2469		2561
		2562	my $extcmd = $self->extcmd;
		2563
		2564	if ($extcmd == 2) {
		2565	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2566	} elsif ($extcmd == 1) { # TODO: remove
2470	$msg{msgtype} = "event_$type";	2567	push @msg, msgtype => "event_$type";
2471	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2568	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2569	}
2472	}	2570	}
2473		2571
2474	=item $success = $client->query ($flags, "text", \&cb)	2572	=item $success = $client->query ($flags, "text", \&cb)
2475		2573
2476	Queues a query to the client, calling the given callback with	2574	Queues a query to the client, calling the given callback with
…		…
2531	my ($ns, $buf) = @_;	2629	my ($ns, $buf) = @_;
2532		2630
2533	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2631	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2534		2632
2535	if (ref $msg) {	2633	if (ref $msg) {
		2634	my ($type, $reply, @payload) =
		2635	"ARRAY" eq ref $msg
		2636	? @$msg
		2637	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2638
2536	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2639	if (my $cb = $EXTICMD{$type}) {
2537	if (my %reply = $cb->($ns, $msg)) {	2640	my @reply = $cb->($ns, @payload);
2538	$reply{msgid} = $msg->{msgid};	2641
2539	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));	2642	$ns->ext_reply ($reply, @reply)
2540	}	2643	if $reply;
2541	}	2644	}
2542	} else {	2645	} else {
2543	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2646	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2544	}	2647	}
2545		2648
…		…
2593	our $safe = new Safe "safe";	2696	our $safe = new Safe "safe";
2594	our $safe_hole = new Safe::Hole;	2697	our $safe_hole = new Safe::Hole;
2595		2698
2596	$SIG{FPE} = 'IGNORE';	2699	$SIG{FPE} = 'IGNORE';
2597		2700
2598	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2701	$safe->permit_only (Opcode::opset qw(
		2702	:base_core :base_mem :base_orig :base_math
		2703	grepstart grepwhile mapstart mapwhile
		2704	sort time
		2705	));
2599		2706
2600	# here we export the classes and methods available to script code	2707	# here we export the classes and methods available to script code
2601		2708
2602	=pod	2709	=pod
2603		2710
2604	The following functions and methods are available within a safe environment:	2711	The following functions and methods are available within a safe environment:
2605		2712
2606	cf::object	2713	cf::object
2607	contr pay_amount pay_player map x y force_find force_add	2714	contr pay_amount pay_player map x y force_find force_add
2608	insert remove	2715	insert remove name archname title slaying race
2609		2716
2610	cf::object::player	2717	cf::object::player
2611	player	2718	player
2612		2719
2613	cf::player	2720	cf::player
…		…
2618		2725
2619	=cut	2726	=cut
2620		2727
2621	for (	2728	for (
2622	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2729	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2623	insert remove)],	2730	insert remove inv name archname title slaying race)],
2624	["cf::object::player" => qw(player)],	2731	["cf::object::player" => qw(player)],
2625	["cf::player" => qw(peaceful)],	2732	["cf::player" => qw(peaceful)],
2626	["cf::map" => qw(trigger)],	2733	["cf::map" => qw(trigger)],
2627	) {	2734	) {
2628	no strict 'refs';	2735	no strict 'refs';
…		…
2704	# the server's init and main functions	2811	# the server's init and main functions
2705		2812
2706	sub load_facedata($) {	2813	sub load_facedata($) {
2707	my ($path) = @_;	2814	my ($path) = @_;
2708		2815
		2816	my $enc = JSON::XS->new->utf8->canonical;
		2817
2709	warn "loading facedata from $path\n";	2818	warn "loading facedata from $path\n";
2710		2819
2711	my $facedata;	2820	my $facedata;
2712	0 < aio_load $path, $facedata	2821	0 < aio_load $path, $facedata
2713	or die "$path: $!";	2822	or die "$path: $!";
…		…
2715	$facedata = Coro::Storable::thaw $facedata;	2824	$facedata = Coro::Storable::thaw $facedata;
2716		2825
2717	$facedata->{version} == 2	2826	$facedata->{version} == 2
2718	or cf::cleanup "$path: version mismatch, cannot proceed.";	2827	or cf::cleanup "$path: version mismatch, cannot proceed.";
2719		2828
		2829	# patch in the exptable
		2830	$facedata->{resource}{"res/exp_table"} = {
		2831	type => FT_RSRC,
		2832	data => $enc->encode ([map cf::level_to_min_exp $_, 0 .. cf::settings->max_level]),
		2833	};
		2834	cf::cede_to_tick;
		2835
2720	{	2836	{
2721	my $faces = $facedata->{faceinfo};	2837	my $faces = $facedata->{faceinfo};
2722		2838
2723	while (my ($face, $info) = each %$faces) {	2839	while (my ($face, $info) = each %$faces) {
2724	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2840	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2725	cf::face::set $idx, $info->{visibility}, $info->{magicmap};	2841	cf::face::set_visibility $idx, $info->{visibility};
		2842	cf::face::set_magicmap $idx, $info->{magicmap};
2726	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2843	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2727	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2844	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2728	Coro::cede;	2845
		2846	cf::cede_to_tick;
2729	}	2847	}
2730		2848
2731	while (my ($face, $info) = each %$faces) {	2849	while (my ($face, $info) = each %$faces) {
2732	next unless $info->{smooth};	2850	next unless $info->{smooth};
2733	my $idx = cf::face::find $face	2851	my $idx = cf::face::find $face
2734	or next;	2852	or next;
2735	if (my $smooth = cf::face::find $info->{smooth}) {	2853	if (my $smooth = cf::face::find $info->{smooth}) {
		2854	cf::face::set_smooth $idx, $smooth;
2736	cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};	2855	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2737	} else {	2856	} else {
2738	warn "smooth face '$info->{smooth}' not found for face '$face'";	2857	warn "smooth face '$info->{smooth}' not found for face '$face'";
2739	}	2858	}
2740	Coro::cede;	2859
		2860	cf::cede_to_tick;
2741	}	2861	}
2742	}	2862	}
2743		2863
2744	{	2864	{
2745	my $anims = $facedata->{animinfo};	2865	my $anims = $facedata->{animinfo};
2746		2866
2747	while (my ($anim, $info) = each %$anims) {	2867	while (my ($anim, $info) = each %$anims) {
2748	cf::anim::set $anim, $info->{frames}, $info->{facings};	2868	cf::anim::set $anim, $info->{frames}, $info->{facings};
2749	Coro::cede;	2869	cf::cede_to_tick;
2750	}	2870	}
2751		2871
2752	cf::anim::invalidate_all; # d'oh	2872	cf::anim::invalidate_all; # d'oh
2753	}	2873	}
2754		2874
		2875	{
		2876	# TODO: for gcfclient pleasure, we should give resources
		2877	# that gcfclient doesn't grok a >10000 face index.
		2878	my $res = $facedata->{resource};
		2879
		2880	my $soundconf = delete $res->{"res/sound.conf"};
		2881
		2882	while (my ($name, $info) = each %$res) {
		2883	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		2884	my $data;
		2885
		2886	if ($info->{type} & 1) {
		2887	# prepend meta info
		2888
		2889	my $meta = $enc->encode ({
		2890	name => $name,
		2891	%{ $info->{meta} \|\| {} },
		2892	});
		2893
		2894	$data = pack "(w/a)", $meta, $info->{data};
		2895	}
		2896
		2897	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
		2898	cf::face::set_type $idx, $info->{type};
		2899
		2900	cf::cede_to_tick;
		2901	}
		2902
		2903	if ($soundconf) {
		2904	$soundconf = $enc->decode (delete $soundconf->{data});
		2905
		2906	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		2907	my $sound = $soundconf->{compat}[$_]
		2908	or next;
		2909
		2910	my $face = cf::face::find "sound/$sound->[1]";
		2911	cf::sound::set $sound->[0] => $face;
		2912	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		2913	}
		2914
		2915	while (my ($k, $v) = each %{$soundconf->{event}}) {
		2916	my $face = cf::face::find "sound/$v";
		2917	cf::sound::set $k => $face;
		2918	}
		2919	}
		2920	}
		2921
2755	1	2922	1
2756	}	2923	}
		2924
		2925	register_exticmd fx_want => sub {
		2926	my ($ns, $want) = @_;
		2927
		2928	while (my ($k, $v) = each %$want) {
		2929	$ns->fx_want ($k, $v);
		2930	}
		2931	};
2757		2932
2758	sub reload_regions {	2933	sub reload_regions {
2759	load_resource_file "$MAPDIR/regions"	2934	load_resource_file "$MAPDIR/regions"
2760	or die "unable to load regions file\n";	2935	or die "unable to load regions file\n";
		2936
		2937	for (cf::region::list) {
		2938	$_->{match} = qr/$_->{match}/
		2939	if exists $_->{match};
		2940	}
2761	}	2941	}
2762		2942
2763	sub reload_facedata {	2943	sub reload_facedata {
2764	load_facedata "$DATADIR/facedata"	2944	load_facedata "$DATADIR/facedata"
2765	or die "unable to load facedata\n";	2945	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.335 by root, Mon Aug 20 22:21:48 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.335 by root, Mon Aug 20 22:21:48 2007 UTC