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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.302 by root, Tue Jul 10 16:23:59 2007 UTC vs.
Revision 1.338 by root, Tue Aug 21 01:07:47 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
…		…
1907		1966
1908	undef $MAP_PREFETCH{$path};	1967	undef $MAP_PREFETCH{$path};
1909	$MAP_PREFETCHER \|\|= cf::async {	1968	$MAP_PREFETCHER \|\|= cf::async {
1910	while (%MAP_PREFETCH) {	1969	while (%MAP_PREFETCH) {
1911	for my $path (keys %MAP_PREFETCH) {	1970	for my $path (keys %MAP_PREFETCH) {
1912	my $map = find $path	1971	if (my $map = find $path) {
1913	or next;
1914	$map->load;	1972	$map->load;
		1973	}
1915		1974
1916	delete $MAP_PREFETCH{$path};	1975	delete $MAP_PREFETCH{$path};
1917	}	1976	}
1918	}	1977	}
1919	undef $MAP_PREFETCHER;	1978	undef $MAP_PREFETCHER;
…		…
2146		2205
2147	} else {	2206	} else {
2148	my $pl = $self->contr;	2207	my $pl = $self->contr;
2149		2208
2150	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2209	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2151	my $diag = $pl->{npc_dialog};	2210	my $dialog = $pl->{npc_dialog};
2152	$diag->{pl}->ext_reply (	2211	$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		2212
2159	} else {	2213	} else {
2160	$msg = $npc->name . " says: $msg" if $npc;	2214	$msg = $npc->name . " says: $msg" if $npc;
2161	$self->message ($msg, $flags);	2215	$self->message ($msg, $flags);
2162	}	2216	}
2163	}	2217	}
		2218	}
		2219
		2220	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2221
		2222	=cut
		2223
		2224	sub cf::object::send_msg {
		2225	my $pl = shift->contr
		2226	or return;
		2227	$pl->send_msg (@_);
2164	}	2228	}
2165		2229
2166	=item $player_object->may ("access")	2230	=item $player_object->may ("access")
2167		2231
2168	Returns wether the given player is authorized to access resource "access"	2232	Returns wether the given player is authorized to access resource "access"
…		…
2247	# use -1 or undef as default coordinates, not 0, 0	2311	# use -1 or undef as default coordinates, not 0, 0
2248	($x, $y) = ($map->enter_x, $map->enter_y)	2312	($x, $y) = ($map->enter_x, $map->enter_y)
2249	if $x <=0 && $y <= 0;	2313	if $x <=0 && $y <= 0;
2250		2314
2251	$map->load;	2315	$map->load;
2252	$map->load_diag;	2316	$map->load_neighbours;
2253		2317
2254	return unless $self->contr->active;	2318	return unless $self->contr->active;
2255	$self->activate_recursive;	2319	$self->activate_recursive;
2256		2320
2257	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2321	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2258	$self->enter_map ($map, $x, $y);	2322	$self->enter_map ($map, $x, $y);
2259	}	2323	}
2260		2324
2261	=item $player_object->goto ($path, $x, $y[, $check->($map)])	2325	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2262		2326
2263	Moves the player to the given map-path and coordinates by first freezing	2327	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	2328	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	2329	that has to return the map if sucecssful, and then unfreezes the player on
2266	the new (success) or old (failed) map position.	2330	the new (success) or old (failed) map position. In either case, $done will
		2331	be called at the end of this process.
2267		2332
2268	=cut	2333	=cut
2269		2334
2270	our $GOTOGEN;	2335	our $GOTOGEN;
2271		2336
2272	sub cf::object::player::goto {	2337	sub cf::object::player::goto {
2273	my ($self, $path, $x, $y, $check) = @_;	2338	my ($self, $path, $x, $y, $check, $done) = @_;
2274		2339
2275	# do generation counting so two concurrent goto's will be executed in-order	2340	# do generation counting so two concurrent goto's will be executed in-order
2276	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2341	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2277		2342
2278	$self->enter_link;	2343	$self->enter_link;
…		…
2298		2363
2299	if ($gen == $self->{_goto_generation}) {	2364	if ($gen == $self->{_goto_generation}) {
2300	delete $self->{_goto_generation};	2365	delete $self->{_goto_generation};
2301	$self->leave_link ($map, $x, $y);	2366	$self->leave_link ($map, $x, $y);
2302	}	2367	}
		2368
		2369	$done->() if $done;
2303	})->prio (1);	2370	})->prio (1);
2304	}	2371	}
2305		2372
2306	=item $player_object->enter_exit ($exit_object)	2373	=item $player_object->enter_exit ($exit_object)
2307		2374
…		…
2416		2483
2417	utf8::encode $text;	2484	utf8::encode $text;
2418	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2485	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2419	}	2486	}
2420		2487
2421	=item $client->send_msg ($color, $type, $msg, [extra...])	2488	=item $client->send_msg ($channel, $msg, $color, [extra...])
2422		2489
2423	Send a drawinfo or msg packet to the client, formatting the msg for the	2490	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	2491	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	2492	the message, with C<log> being the default. If C<$color> is negative, suppress
2426	the message unless the client supports the msg packet.	2493	the message unless the client supports the msg packet.
2427		2494
2428	=cut	2495	=cut
2429		2496
2430	sub cf::client::send_msg {	2497	sub cf::client::send_msg {
2431	my ($self, $color, $type, $msg, @extra) = @_;	2498	my ($self, $channel, $msg, $color, @extra) = @_;
2432		2499
2433	$msg = $self->pl->expand_cfpod ($msg);	2500	$msg = $self->pl->expand_cfpod ($msg);
2434		2501
		2502	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2503
		2504	if (ref $channel) {
		2505	# send meta info to client, if not yet sent
		2506	unless (exists $self->{channel}{$channel->{id}}) {
		2507	$self->{channel}{$channel->{id}} = $channel;
		2508	$self->ext_msg (channel_info => $channel);
		2509	}
		2510
		2511	$channel = $channel->{id};
		2512	}
		2513
2435	return unless @extra \|\| length $msg;	2514	return unless @extra \|\| length $msg;
2436		2515
2437	if ($self->can_msg) {	2516	if ($self->can_msg) {
		2517	# default colour, mask it out
		2518	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2519	if $color & cf::NDI_DEF;
		2520
2438	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));	2521	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2522	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2439	} else {	2523	} 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) {	2524	if ($color >= 0) {
		2525	# replace some tags by gcfclient-compatible ones
		2526	for ($msg) {
		2527	1 while
		2528	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2529	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2530	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2531	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2532	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2533	}
		2534
		2535	$color &= cf::NDI_COLOR_MASK;
		2536
		2537	utf8::encode $msg;
		2538
2451	if (0 && $msg =~ /\[/) {	2539	if (0 && $msg =~ /\[/) {
		2540	# COMMAND/INFO
2452	$self->send_packet ("drawextinfo $color 4 0 $msg")	2541	$self->send_packet ("drawextinfo $color 10 8 $msg")
2453	} else {	2542	} else {
2454	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2543	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2455	$self->send_packet ("drawinfo $color $msg")	2544	$self->send_packet ("drawinfo $color $msg")
2456	}	2545	}
2457	}	2546	}
2458	}	2547	}
2459	}	2548	}
2460		2549
2461	=item $client->ext_event ($type, %msg)	2550	=item $client->ext_msg ($type, @msg)
2462		2551
2463	Sends an ext event to the client.	2552	Sends an ext event to the client.
2464		2553
2465	=cut	2554	=cut
2466		2555
2467	sub cf::client::ext_event($$%) {	2556	sub cf::client::ext_msg($$@) {
2468	my ($self, $type, %msg) = @_;	2557	my ($self, $type, @msg) = @_;
2469		2558
		2559	my $extcmd = $self->extcmd;
		2560
		2561	if ($extcmd == 2) {
		2562	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2563	} elsif ($extcmd == 1) { # TODO: remove
2470	$msg{msgtype} = "event_$type";	2564	push @msg, msgtype => "event_$type";
2471	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2565	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2566	}
		2567	}
		2568
		2569	=item $client->ext_reply ($msgid, @msg)
		2570
		2571	Sends an ext reply to the client.
		2572
		2573	=cut
		2574
		2575	sub cf::client::ext_reply($$@) {
		2576	my ($self, $id, @msg) = @_;
		2577
		2578	if ($self->extcmd == 2) {
		2579	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
		2580	} elsif ($self->ns->extcmd == 1) {
		2581	#TODO: version 1, remove
		2582	unshift @msg, msgtype => "reply", msgid => $id;
		2583	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2584	}
2472	}	2585	}
2473		2586
2474	=item $success = $client->query ($flags, "text", \&cb)	2587	=item $success = $client->query ($flags, "text", \&cb)
2475		2588
2476	Queues a query to the client, calling the given callback with	2589	Queues a query to the client, calling the given callback with
…		…
2531	my ($ns, $buf) = @_;	2644	my ($ns, $buf) = @_;
2532		2645
2533	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2646	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2534		2647
2535	if (ref $msg) {	2648	if (ref $msg) {
		2649	my ($type, $reply, @payload) =
		2650	"ARRAY" eq ref $msg
		2651	? @$msg
		2652	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2653
		2654	my @reply;
		2655
2536	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2656	if (my $cb = $EXTICMD{$type}) {
2537	if (my %reply = $cb->($ns, $msg)) {	2657	@reply = $cb->($ns, @payload);
2538	$reply{msgid} = $msg->{msgid};
2539	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2540	}
2541	}	2658	}
		2659
		2660	$ns->ext_reply ($reply, @reply)
		2661	if $reply;
		2662
2542	} else {	2663	} else {
2543	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2664	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2544	}	2665	}
2545		2666
2546	cf::override;	2667	cf::override;
…		…
2593	our $safe = new Safe "safe";	2714	our $safe = new Safe "safe";
2594	our $safe_hole = new Safe::Hole;	2715	our $safe_hole = new Safe::Hole;
2595		2716
2596	$SIG{FPE} = 'IGNORE';	2717	$SIG{FPE} = 'IGNORE';
2597		2718
2598	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2719	$safe->permit_only (Opcode::opset qw(
		2720	:base_core :base_mem :base_orig :base_math
		2721	grepstart grepwhile mapstart mapwhile
		2722	sort time
		2723	));
2599		2724
2600	# here we export the classes and methods available to script code	2725	# here we export the classes and methods available to script code
2601		2726
2602	=pod	2727	=pod
2603		2728
2604	The following functions and methods are available within a safe environment:	2729	The following functions and methods are available within a safe environment:
2605		2730
2606	cf::object	2731	cf::object
2607	contr pay_amount pay_player map x y force_find force_add	2732	contr pay_amount pay_player map x y force_find force_add
2608	insert remove	2733	insert remove name archname title slaying race
2609		2734
2610	cf::object::player	2735	cf::object::player
2611	player	2736	player
2612		2737
2613	cf::player	2738	cf::player
…		…
2618		2743
2619	=cut	2744	=cut
2620		2745
2621	for (	2746	for (
2622	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2747	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2623	insert remove)],	2748	insert remove inv name archname title slaying race)],
2624	["cf::object::player" => qw(player)],	2749	["cf::object::player" => qw(player)],
2625	["cf::player" => qw(peaceful)],	2750	["cf::player" => qw(peaceful)],
2626	["cf::map" => qw(trigger)],	2751	["cf::map" => qw(trigger)],
2627	) {	2752	) {
2628	no strict 'refs';	2753	no strict 'refs';
…		…
2704	# the server's init and main functions	2829	# the server's init and main functions
2705		2830
2706	sub load_facedata($) {	2831	sub load_facedata($) {
2707	my ($path) = @_;	2832	my ($path) = @_;
2708		2833
		2834	my $enc = JSON::XS->new->utf8->canonical;
		2835
2709	warn "loading facedata from $path\n";	2836	warn "loading facedata from $path\n";
2710		2837
2711	my $facedata;	2838	my $facedata;
2712	0 < aio_load $path, $facedata	2839	0 < aio_load $path, $facedata
2713	or die "$path: $!";	2840	or die "$path: $!";
2714		2841
2715	$facedata = Coro::Storable::thaw $facedata;	2842	$facedata = Coro::Storable::thaw $facedata;
2716		2843
2717	$facedata->{version} == 2	2844	$facedata->{version} == 2
2718	or cf::cleanup "$path: version mismatch, cannot proceed.";	2845	or cf::cleanup "$path: version mismatch, cannot proceed.";
		2846
		2847	# patch in the exptable
		2848	$facedata->{resource}{"res/exp_table"} = {
		2849	type => FT_RSRC,
		2850	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
		2851	};
		2852	cf::cede_to_tick;
2719		2853
2720	{	2854	{
2721	my $faces = $facedata->{faceinfo};	2855	my $faces = $facedata->{faceinfo};
2722		2856
2723	while (my ($face, $info) = each %$faces) {	2857	while (my ($face, $info) = each %$faces) {
2724	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2858	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2725	cf::face::set_visibility $idx, $info->{visibility};	2859	cf::face::set_visibility $idx, $info->{visibility};
2726	cf::face::set_magicmap $idx, $info->{magicmap};	2860	cf::face::set_magicmap $idx, $info->{magicmap};
2727	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2861	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2728	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2862	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2729		2863
2730	cf::cede_to_tick;	2864	cf::cede_to_tick;
2731	}	2865	}
2732		2866
2733	while (my ($face, $info) = each %$faces) {	2867	while (my ($face, $info) = each %$faces) {
…		…
2758		2892
2759	{	2893	{
2760	# TODO: for gcfclient pleasure, we should give resources	2894	# TODO: for gcfclient pleasure, we should give resources
2761	# that gcfclient doesn't grok a >10000 face index.	2895	# that gcfclient doesn't grok a >10000 face index.
2762	my $res = $facedata->{resource};	2896	my $res = $facedata->{resource};
2763	my $enc = JSON::XS->new->utf8->canonical;	2897
		2898	my $soundconf = delete $res->{"res/sound.conf"};
2764		2899
2765	while (my ($name, $info) = each %$res) {	2900	while (my ($name, $info) = each %$res) {
2766	my $meta = $enc->encode ({
2767	name => $name,
2768	type => $info->{type},
2769	copyright => $info->{copyright},
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	use Data::Dumper; warn Dumper substr $data, 0, 100;#d#
2775
2776	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	2901	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		2902	my $data;
		2903
		2904	if ($info->{type} & 1) {
		2905	# prepend meta info
		2906
		2907	my $meta = $enc->encode ({
		2908	name => $name,
		2909	%{ $info->{meta} \|\| {} },
		2910	});
		2911
		2912	$data = pack "(w/a)", $meta, $info->{data};
		2913	} else {
		2914	$data = $info->{data};
		2915	}
		2916
		2917	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2777	cf::face::set_type $idx, 1;	2918	cf::face::set_type $idx, $info->{type};
2778	cf::face::set_data $idx, 0, $data, $chk;
2779		2919
2780	# TODO
2781	cf::cede_to_tick;	2920	cf::cede_to_tick;
2782	}	2921	}
		2922
		2923	if ($soundconf) {
		2924	$soundconf = $enc->decode (delete $soundconf->{data});
		2925
		2926	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		2927	my $sound = $soundconf->{compat}[$_]
		2928	or next;
		2929
		2930	my $face = cf::face::find "sound/$sound->[1]";
		2931	cf::sound::set $sound->[0] => $face;
		2932	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		2933	}
		2934
		2935	while (my ($k, $v) = each %{$soundconf->{event}}) {
		2936	my $face = cf::face::find "sound/$v";
		2937	cf::sound::set $k => $face;
		2938	}
		2939	}
2783	}	2940	}
2784		2941
2785	1	2942	1
2786	}	2943	}
		2944
		2945	register_exticmd fx_want => sub {
		2946	my ($ns, $want) = @_;
		2947
		2948	while (my ($k, $v) = each %$want) {
		2949	$ns->fx_want ($k, $v);
		2950	}
		2951	};
2787		2952
2788	sub reload_regions {	2953	sub reload_regions {
2789	load_resource_file "$MAPDIR/regions"	2954	load_resource_file "$MAPDIR/regions"
2790	or die "unable to load regions file\n";	2955	or die "unable to load regions file\n";
		2956
		2957	for (cf::region::list) {
		2958	$_->{match} = qr/$_->{match}/
		2959	if exists $_->{match};
		2960	}
2791	}	2961	}
2792		2962
2793	sub reload_facedata {	2963	sub reload_facedata {
2794	load_facedata "$DATADIR/facedata"	2964	load_facedata "$DATADIR/facedata"
2795	or die "unable to load facedata\n";	2965	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.302 by root, Tue Jul 10 16:23:59 2007 UTC vs. Revision 1.338 by root, Tue Aug 21 01:07:47 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.302 by root, Tue Jul 10 16:23:59 2007 UTC vs.
Revision 1.338 by root, Tue Aug 21 01:07:47 2007 UTC