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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.303 by root, Wed Jul 11 15:57:31 2007 UTC vs.
Revision 1.341 by elmex, Sat Aug 25 16:51:38 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
		1154	my @reply;
		1155
1113	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1156	if (my $cb = $EXTCMD{$type}) {
1114	if (my %reply = $cb->($pl, $msg)) {	1157	@reply = $cb->($pl, @payload);
1115	$pl->ext_reply ($msg->{msgid}, %reply);
1116	}
1117	}	1158	}
		1159
		1160	$pl->ext_reply ($reply, @reply)
		1161	if $reply;
		1162
1118	} else {	1163	} else {
1119	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1164	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1120	}	1165	}
1121		1166
1122	cf::override;	1167	cf::override;
…		…
1291	$self->{deny_save} = 1;	1336	$self->{deny_save} = 1;
1292		1337
1293	$cf::PLAYER{$login} = $self;	1338	$cf::PLAYER{$login} = $self;
1294		1339
1295	$self	1340	$self
		1341	}
		1342
		1343	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1344
		1345	=cut
		1346
		1347	sub send_msg {
		1348	my $ns = shift->ns
		1349	or return;
		1350	$ns->send_msg (@_);
1296	}	1351	}
1297		1352
1298	=item $pl->quit_character	1353	=item $pl->quit_character
1299		1354
1300	Nukes the player without looking back. If logged in, the connection will	1355	Nukes the player without looking back. If logged in, the connection will
…		…
1444	sub hintmode {	1499	sub hintmode {
1445	$_[0]{hintmode} = $_[1] if @_ > 1;	1500	$_[0]{hintmode} = $_[1] if @_ > 1;
1446	$_[0]{hintmode}	1501	$_[0]{hintmode}
1447	}	1502	}
1448		1503
1449	=item $player->ext_reply ($msgid, %msg)	1504	=item $player->ext_reply ($msgid, @msg)
1450		1505
1451	Sends an ext reply to the player.	1506	Sends an ext reply to the player.
1452		1507
1453	=cut	1508	=cut
1454		1509
1455	sub ext_reply($$%) {	1510	sub ext_reply($$@) {
1456	my ($self, $id, %msg) = @_;	1511	my ($self, $id, @msg) = @_;
1457		1512
1458	$msg{msgid} = $id;	1513	$self->ns->ext_reply ($id, @msg)
1459	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1460	}	1514	}
1461		1515
1462	=item $player->ext_event ($type, %msg)	1516	=item $player->ext_msg ($type, @msg)
1463		1517
1464	Sends an ext event to the client.	1518	Sends an ext event to the client.
1465		1519
1466	=cut	1520	=cut
1467		1521
1468	sub ext_event($$%) {	1522	sub ext_msg($$@) {
1469	my ($self, $type, %msg) = @_;	1523	my ($self, $type, @msg) = @_;
1470		1524
1471	$self->ns->ext_event ($type, %msg);	1525	$self->ns->ext_msg ($type, @msg);
1472	}	1526	}
1473		1527
1474	=head3 cf::region	1528	=head3 cf::region
1475		1529
1476	=over 4	1530	=over 4
…		…
1489	my ($path) = @_;	1543	my ($path) = @_;
1490		1544
1491	my ($match, $specificity);	1545	my ($match, $specificity);
1492		1546
1493	for my $region (list) {	1547	for my $region (list) {
1494	if ($region->match && $path =~ $region->match) {	1548	if ($region->{match} && $path =~ $region->{match}) {
1495	($match, $specificity) = ($region, $region->specificity)	1549	($match, $specificity) = ($region, $region->specificity)
1496	if $region->specificity > $specificity;	1550	if $region->specificity > $specificity;
1497	}	1551	}
1498	}	1552	}
1499		1553
…		…
1619	$self->init; # pass $1 etc.	1673	$self->init; # pass $1 etc.
1620	return $self;	1674	return $self;
1621	}	1675	}
1622	}	1676	}
1623		1677
1624	Carp::carp "unable to resolve path '$path' (base '$base').";	1678	Carp::cluck "unable to resolve path '$path' (base '$base').";
1625	()	1679	()
1626	}	1680	}
1627		1681
1628	sub init {	1682	sub init {
1629	my ($self) = @_;	1683	my ($self) = @_;
…		…
1837	$self->set_darkness_map;	1891	$self->set_darkness_map;
1838	Coro::cede;	1892	Coro::cede;
1839	$self->activate;	1893	$self->activate;
1840	}	1894	}
1841		1895
		1896	$self->{last_save} = $cf::RUNTIME;
		1897	$self->last_access ($cf::RUNTIME);
		1898
1842	$self->in_memory (cf::MAP_IN_MEMORY);	1899	$self->in_memory (cf::MAP_IN_MEMORY);
1843	}	1900	}
1844		1901
1845	$self->post_load;	1902	$self->post_load;
1846	}	1903	}
…		…
1856		1913
1857	$self	1914	$self
1858	}	1915	}
1859		1916
1860	# find and load all maps in the 3x3 area around a map	1917	# find and load all maps in the 3x3 area around a map
1861	sub load_diag {	1918	sub load_neighbours {
1862	my ($map) = @_;	1919	my ($map) = @_;
1863		1920
1864	my @diag; # diagonal neighbours	1921	my @neigh; # diagonal neighbours
1865		1922
1866	for (0 .. 3) {	1923	for (0 .. 3) {
1867	my $neigh = $map->tile_path ($_)	1924	my $neigh = $map->tile_path ($_)
1868	or next;	1925	or next;
1869	$neigh = find $neigh, $map	1926	$neigh = find $neigh, $map
1870	or next;	1927	or next;
1871	$neigh->load;	1928	$neigh->load;
1872		1929
		1930	push @neigh,
1873	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],	1931	[$neigh->tile_path (($_ + 3) % 4), $neigh],
1874	[$neigh->tile_path (($_ + 1) % 4), $neigh];	1932	[$neigh->tile_path (($_ + 1) % 4), $neigh];
1875	}	1933	}
1876		1934
1877	for (@diag) {	1935	for (grep defined $_->[0], @neigh) {
		1936	my ($path, $origin) = @$_;
1878	my $neigh = find @$_	1937	my $neigh = find $path, $origin
1879	or next;	1938	or next;
1880	$neigh->load;	1939	$neigh->load;
1881	}	1940	}
1882	}	1941	}
1883		1942
…		…
1888	}	1947	}
1889		1948
1890	sub do_load_sync {	1949	sub do_load_sync {
1891	my ($map) = @_;	1950	my ($map) = @_;
1892		1951
		1952	cf::LOG cf::llevDebug \| cf::logBacktrace, "do_load_sync"
		1953	if $Coro::current != $Coro::main;
		1954
1893	cf::sync_job { $map->load };	1955	cf::sync_job { $map->load };
1894	}	1956	}
1895		1957
1896	our %MAP_PREFETCH;	1958	our %MAP_PREFETCH;
1897	our $MAP_PREFETCHER = undef;	1959	our $MAP_PREFETCHER = undef;
1898		1960
1899	sub find_async {	1961	sub find_async {
1900	my ($path, $origin) = @_;	1962	my ($path, $origin, $load) = @_;
1901		1963
1902	$path = normalise $path, $origin && $origin->{path};	1964	$path = normalise $path, $origin && $origin->{path};
1903		1965
1904	if (my $map = $cf::MAP{$path}) {	1966	if (my $map = $cf::MAP{$path}) {
1905	return $map if $map->in_memory == cf::MAP_IN_MEMORY;	1967	return $map if !$load \|\| $map->in_memory == cf::MAP_IN_MEMORY;
1906	}	1968	}
1907		1969
1908	undef $MAP_PREFETCH{$path};	1970	$MAP_PREFETCH{$path} \|= $load;
		1971
1909	$MAP_PREFETCHER \|\|= cf::async {	1972	$MAP_PREFETCHER \|\|= cf::async {
1910	while (%MAP_PREFETCH) {	1973	while (%MAP_PREFETCH) {
1911	for my $path (keys %MAP_PREFETCH) {	1974	while (my ($k, $v) = each %MAP_PREFETCH) {
1912	my $map = find $path	1975	if (my $map = find $k) {
1913	or next;
1914	$map->load;	1976	$map->load if $v;
		1977	}
1915		1978
1916	delete $MAP_PREFETCH{$path};	1979	delete $MAP_PREFETCH{$k};
1917	}	1980	}
1918	}	1981	}
1919	undef $MAP_PREFETCHER;	1982	undef $MAP_PREFETCHER;
1920	};	1983	};
1921	$MAP_PREFETCHER->prio (6);	1984	$MAP_PREFETCHER->prio (6);
…		…
2146		2209
2147	} else {	2210	} else {
2148	my $pl = $self->contr;	2211	my $pl = $self->contr;
2149		2212
2150	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2213	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2151	my $diag = $pl->{npc_dialog};	2214	my $dialog = $pl->{npc_dialog};
2152	$diag->{pl}->ext_reply (	2215	$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		2216
2159	} else {	2217	} else {
2160	$msg = $npc->name . " says: $msg" if $npc;	2218	$msg = $npc->name . " says: $msg" if $npc;
2161	$self->message ($msg, $flags);	2219	$self->message ($msg, $flags);
2162	}	2220	}
2163	}	2221	}
		2222	}
		2223
		2224	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2225
		2226	=cut
		2227
		2228	sub cf::object::send_msg {
		2229	my $pl = shift->contr
		2230	or return;
		2231	$pl->send_msg (@_);
2164	}	2232	}
2165		2233
2166	=item $player_object->may ("access")	2234	=item $player_object->may ("access")
2167		2235
2168	Returns wether the given player is authorized to access resource "access"	2236	Returns wether the given player is authorized to access resource "access"
…		…
2247	# use -1 or undef as default coordinates, not 0, 0	2315	# use -1 or undef as default coordinates, not 0, 0
2248	($x, $y) = ($map->enter_x, $map->enter_y)	2316	($x, $y) = ($map->enter_x, $map->enter_y)
2249	if $x <=0 && $y <= 0;	2317	if $x <=0 && $y <= 0;
2250		2318
2251	$map->load;	2319	$map->load;
2252	$map->load_diag;	2320	$map->load_neighbours;
2253		2321
2254	return unless $self->contr->active;	2322	return unless $self->contr->active;
2255	$self->activate_recursive;	2323	$self->activate_recursive;
2256		2324
2257	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2325	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2258	$self->enter_map ($map, $x, $y);	2326	$self->enter_map ($map, $x, $y);
2259	}	2327	}
2260		2328
2261	=item $player_object->goto ($path, $x, $y[, $check->($map)])	2329	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2262		2330
2263	Moves the player to the given map-path and coordinates by first freezing	2331	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	2332	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	2333	that has to return the map if sucecssful, and then unfreezes the player on
2266	the new (success) or old (failed) map position.	2334	the new (success) or old (failed) map position. In either case, $done will
		2335	be called at the end of this process.
2267		2336
2268	=cut	2337	=cut
2269		2338
2270	our $GOTOGEN;	2339	our $GOTOGEN;
2271		2340
2272	sub cf::object::player::goto {	2341	sub cf::object::player::goto {
2273	my ($self, $path, $x, $y, $check) = @_;	2342	my ($self, $path, $x, $y, $check, $done) = @_;
2274		2343
2275	# do generation counting so two concurrent goto's will be executed in-order	2344	# do generation counting so two concurrent goto's will be executed in-order
2276	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2345	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2277		2346
2278	$self->enter_link;	2347	$self->enter_link;
…		…
2298		2367
2299	if ($gen == $self->{_goto_generation}) {	2368	if ($gen == $self->{_goto_generation}) {
2300	delete $self->{_goto_generation};	2369	delete $self->{_goto_generation};
2301	$self->leave_link ($map, $x, $y);	2370	$self->leave_link ($map, $x, $y);
2302	}	2371	}
		2372
		2373	$done->() if $done;
2303	})->prio (1);	2374	})->prio (1);
2304	}	2375	}
2305		2376
2306	=item $player_object->enter_exit ($exit_object)	2377	=item $player_object->enter_exit ($exit_object)
2307		2378
…		…
2416		2487
2417	utf8::encode $text;	2488	utf8::encode $text;
2418	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2489	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2419	}	2490	}
2420		2491
2421	=item $client->send_msg ($color, $type, $msg, [extra...])	2492	=item $client->send_msg ($channel, $msg, $color, [extra...])
2422		2493
2423	Send a drawinfo or msg packet to the client, formatting the msg for the	2494	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	2495	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	2496	the message, with C<log> being the default. If C<$color> is negative, suppress
2426	the message unless the client supports the msg packet.	2497	the message unless the client supports the msg packet.
2427		2498
2428	=cut	2499	=cut
2429		2500
2430	sub cf::client::send_msg {	2501	sub cf::client::send_msg {
2431	my ($self, $color, $type, $msg, @extra) = @_;	2502	my ($self, $channel, $msg, $color, @extra) = @_;
2432		2503
2433	$msg = $self->pl->expand_cfpod ($msg);	2504	$msg = $self->pl->expand_cfpod ($msg);
2434		2505
		2506	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2507
		2508	if (ref $channel) {
		2509	# send meta info to client, if not yet sent
		2510	unless (exists $self->{channel}{$channel->{id}}) {
		2511	$self->{channel}{$channel->{id}} = $channel;
		2512	$self->ext_msg (channel_info => $channel);
		2513	}
		2514
		2515	$channel = $channel->{id};
		2516	}
		2517
2435	return unless @extra \|\| length $msg;	2518	return unless @extra \|\| length $msg;
2436		2519
2437	if ($self->can_msg) {	2520	if ($self->can_msg) {
		2521	# default colour, mask it out
		2522	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2523	if $color & cf::NDI_DEF;
		2524
2438	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));	2525	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2526	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2439	} else {	2527	} 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) {	2528	if ($color >= 0) {
		2529	# replace some tags by gcfclient-compatible ones
		2530	for ($msg) {
		2531	1 while
		2532	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2533	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2534	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2535	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2536	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2537	}
		2538
		2539	$color &= cf::NDI_COLOR_MASK;
		2540
		2541	utf8::encode $msg;
		2542
2451	if (0 && $msg =~ /\[/) {	2543	if (0 && $msg =~ /\[/) {
		2544	# COMMAND/INFO
2452	$self->send_packet ("drawextinfo $color 4 0 $msg")	2545	$self->send_packet ("drawextinfo $color 10 8 $msg")
2453	} else {	2546	} else {
2454	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2547	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2455	$self->send_packet ("drawinfo $color $msg")	2548	$self->send_packet ("drawinfo $color $msg")
2456	}	2549	}
2457	}	2550	}
2458	}	2551	}
2459	}	2552	}
2460		2553
2461	=item $client->ext_event ($type, %msg)	2554	=item $client->ext_msg ($type, @msg)
2462		2555
2463	Sends an ext event to the client.	2556	Sends an ext event to the client.
2464		2557
2465	=cut	2558	=cut
2466		2559
2467	sub cf::client::ext_event($$%) {	2560	sub cf::client::ext_msg($$@) {
2468	my ($self, $type, %msg) = @_;	2561	my ($self, $type, @msg) = @_;
2469		2562
		2563	my $extcmd = $self->extcmd;
		2564
		2565	if ($extcmd == 2) {
		2566	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2567	} elsif ($extcmd == 1) { # TODO: remove
2470	$msg{msgtype} = "event_$type";	2568	push @msg, msgtype => "event_$type";
2471	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2569	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2570	}
		2571	}
		2572
		2573	=item $client->ext_reply ($msgid, @msg)
		2574
		2575	Sends an ext reply to the client.
		2576
		2577	=cut
		2578
		2579	sub cf::client::ext_reply($$@) {
		2580	my ($self, $id, @msg) = @_;
		2581
		2582	if ($self->extcmd == 2) {
		2583	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
		2584	} elsif ($self->ns->extcmd == 1) {
		2585	#TODO: version 1, remove
		2586	unshift @msg, msgtype => "reply", msgid => $id;
		2587	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2588	}
2472	}	2589	}
2473		2590
2474	=item $success = $client->query ($flags, "text", \&cb)	2591	=item $success = $client->query ($flags, "text", \&cb)
2475		2592
2476	Queues a query to the client, calling the given callback with	2593	Queues a query to the client, calling the given callback with
…		…
2531	my ($ns, $buf) = @_;	2648	my ($ns, $buf) = @_;
2532		2649
2533	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2650	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2534		2651
2535	if (ref $msg) {	2652	if (ref $msg) {
		2653	my ($type, $reply, @payload) =
		2654	"ARRAY" eq ref $msg
		2655	? @$msg
		2656	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2657
		2658	my @reply;
		2659
2536	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2660	if (my $cb = $EXTICMD{$type}) {
2537	if (my %reply = $cb->($ns, $msg)) {	2661	@reply = $cb->($ns, @payload);
2538	$reply{msgid} = $msg->{msgid};
2539	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2540	}
2541	}	2662	}
		2663
		2664	$ns->ext_reply ($reply, @reply)
		2665	if $reply;
		2666
2542	} else {	2667	} else {
2543	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2668	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2544	}	2669	}
2545		2670
2546	cf::override;	2671	cf::override;
…		…
2593	our $safe = new Safe "safe";	2718	our $safe = new Safe "safe";
2594	our $safe_hole = new Safe::Hole;	2719	our $safe_hole = new Safe::Hole;
2595		2720
2596	$SIG{FPE} = 'IGNORE';	2721	$SIG{FPE} = 'IGNORE';
2597		2722
2598	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2723	$safe->permit_only (Opcode::opset qw(
		2724	:base_core :base_mem :base_orig :base_math
		2725	grepstart grepwhile mapstart mapwhile
		2726	sort time
		2727	));
2599		2728
2600	# here we export the classes and methods available to script code	2729	# here we export the classes and methods available to script code
2601		2730
2602	=pod	2731	=pod
2603		2732
2604	The following functions and methods are available within a safe environment:	2733	The following functions and methods are available within a safe environment:
2605		2734
2606	cf::object	2735	cf::object
2607	contr pay_amount pay_player map x y force_find force_add	2736	contr pay_amount pay_player map x y force_find force_add
2608	insert remove	2737	insert remove name archname title slaying race decrease_ob_nr
2609		2738
2610	cf::object::player	2739	cf::object::player
2611	player	2740	player
2612		2741
2613	cf::player	2742	cf::player
…		…
2618		2747
2619	=cut	2748	=cut
2620		2749
2621	for (	2750	for (
2622	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2751	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2752	insert remove inv name archname title slaying race
2623	insert remove)],	2753	decrease_ob_nr)],
2624	["cf::object::player" => qw(player)],	2754	["cf::object::player" => qw(player)],
2625	["cf::player" => qw(peaceful)],	2755	["cf::player" => qw(peaceful)],
2626	["cf::map" => qw(trigger)],	2756	["cf::map" => qw(trigger)],
2627	) {	2757	) {
2628	no strict 'refs';	2758	no strict 'refs';
…		…
2704	# the server's init and main functions	2834	# the server's init and main functions
2705		2835
2706	sub load_facedata($) {	2836	sub load_facedata($) {
2707	my ($path) = @_;	2837	my ($path) = @_;
2708		2838
		2839	my $enc = JSON::XS->new->utf8->canonical;
		2840
2709	warn "loading facedata from $path\n";	2841	warn "loading facedata from $path\n";
2710		2842
2711	my $facedata;	2843	my $facedata;
2712	0 < aio_load $path, $facedata	2844	0 < aio_load $path, $facedata
2713	or die "$path: $!";	2845	or die "$path: $!";
2714		2846
2715	$facedata = Coro::Storable::thaw $facedata;	2847	$facedata = Coro::Storable::thaw $facedata;
2716		2848
2717	$facedata->{version} == 2	2849	$facedata->{version} == 2
2718	or cf::cleanup "$path: version mismatch, cannot proceed.";	2850	or cf::cleanup "$path: version mismatch, cannot proceed.";
		2851
		2852	# patch in the exptable
		2853	$facedata->{resource}{"res/exp_table"} = {
		2854	type => FT_RSRC,
		2855	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
		2856	};
		2857	cf::cede_to_tick;
2719		2858
2720	{	2859	{
2721	my $faces = $facedata->{faceinfo};	2860	my $faces = $facedata->{faceinfo};
2722		2861
2723	while (my ($face, $info) = each %$faces) {	2862	while (my ($face, $info) = each %$faces) {
2724	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2863	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2725	cf::face::set_visibility $idx, $info->{visibility};	2864	cf::face::set_visibility $idx, $info->{visibility};
2726	cf::face::set_magicmap $idx, $info->{magicmap};	2865	cf::face::set_magicmap $idx, $info->{magicmap};
2727	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2866	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2728	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2867	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2729		2868
2730	cf::cede_to_tick;	2869	cf::cede_to_tick;
2731	}	2870	}
2732		2871
2733	while (my ($face, $info) = each %$faces) {	2872	while (my ($face, $info) = each %$faces) {
…		…
2758		2897
2759	{	2898	{
2760	# TODO: for gcfclient pleasure, we should give resources	2899	# TODO: for gcfclient pleasure, we should give resources
2761	# that gcfclient doesn't grok a >10000 face index.	2900	# that gcfclient doesn't grok a >10000 face index.
2762	my $res = $facedata->{resource};	2901	my $res = $facedata->{resource};
2763	my $enc = JSON::XS->new->utf8->canonical;	2902
		2903	my $soundconf = delete $res->{"res/sound.conf"};
2764		2904
2765	while (my ($name, $info) = each %$res) {	2905	while (my ($name, $info) = each %$res) {
2766	my $meta = $enc->encode ({
2767	name => $name,
2768	type => $info->{type},
2769	copyright => $info->{copyright}, #TODO#
2770	});
2771	my $data = pack "(w/a)", $meta, $info->{data};
2772	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2773
2774	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	2906	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		2907	my $data;
		2908
		2909	if ($info->{type} & 1) {
		2910	# prepend meta info
		2911
		2912	my $meta = $enc->encode ({
		2913	name => $name,
		2914	%{ $info->{meta} \|\| {} },
		2915	});
		2916
		2917	$data = pack "(w/a)", $meta, $info->{data};
		2918	} else {
		2919	$data = $info->{data};
		2920	}
		2921
		2922	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2775	cf::face::set_type $idx, 1;	2923	cf::face::set_type $idx, $info->{type};
2776	cf::face::set_data $idx, 0, $data, $chk;
2777		2924
2778	cf::cede_to_tick;	2925	cf::cede_to_tick;
2779	}	2926	}
		2927
		2928	if ($soundconf) {
		2929	$soundconf = $enc->decode (delete $soundconf->{data});
		2930
		2931	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		2932	my $sound = $soundconf->{compat}[$_]
		2933	or next;
		2934
		2935	my $face = cf::face::find "sound/$sound->[1]";
		2936	cf::sound::set $sound->[0] => $face;
		2937	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		2938	}
		2939
		2940	while (my ($k, $v) = each %{$soundconf->{event}}) {
		2941	my $face = cf::face::find "sound/$v";
		2942	cf::sound::set $k => $face;
		2943	}
		2944	}
2780	}	2945	}
2781		2946
2782	1	2947	1
2783	}	2948	}
		2949
		2950	register_exticmd fx_want => sub {
		2951	my ($ns, $want) = @_;
		2952
		2953	while (my ($k, $v) = each %$want) {
		2954	$ns->fx_want ($k, $v);
		2955	}
		2956	};
2784		2957
2785	sub reload_regions {	2958	sub reload_regions {
2786	load_resource_file "$MAPDIR/regions"	2959	load_resource_file "$MAPDIR/regions"
2787	or die "unable to load regions file\n";	2960	or die "unable to load regions file\n";
		2961
		2962	for (cf::region::list) {
		2963	$_->{match} = qr/$_->{match}/
		2964	if exists $_->{match};
		2965	}
2788	}	2966	}
2789		2967
2790	sub reload_facedata {	2968	sub reload_facedata {
2791	load_facedata "$DATADIR/facedata"	2969	load_facedata "$DATADIR/facedata"
2792	or die "unable to load facedata\n";	2970	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.303 by root, Wed Jul 11 15:57:31 2007 UTC vs. Revision 1.341 by elmex, Sat Aug 25 16:51:38 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.303 by root, Wed Jul 11 15:57:31 2007 UTC vs.
Revision 1.341 by elmex, Sat Aug 25 16:51:38 2007 UTC