[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.336 by root, Tue Aug 21 00:31:18 2007 UTC

…		…
10	use Event;	10	use Event;
11	use Opcode;	11	use Opcode;
12	use Safe;	12	use Safe;
13	use Safe::Hole;	13	use Safe::Hole;
14		14
15	use Coro 3.61 ();	15	use Coro 3.64 ();
16	use Coro::State;	16	use Coro::State;
17	use Coro::Handle;	17	use Coro::Handle;
18	use Coro::Event;	18	use Coro::Event;
19	use Coro::Timer;	19	use Coro::Timer;
20	use Coro::Signal;	20	use Coro::Signal;
21	use Coro::Semaphore;	21	use Coro::Semaphore;
22	use Coro::AIO;	22	use Coro::AIO;
23	use Coro::Storable;	23	use Coro::Storable;
		24	use Coro::Util ();
24		25
25	use JSON::XS 1.4 ();	26	use JSON::XS 1.4 ();
26	use BDB ();	27	use BDB ();
27	use Data::Dumper;	28	use Data::Dumper;
28	use Digest::MD5;	29	use Digest::MD5;
…		…
166	=item cf::wait_for_tick, cf::wait_for_tick_begin	167	=item cf::wait_for_tick, cf::wait_for_tick_begin
167		168
168	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	169	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
169	returns directly I<after> the tick processing (and consequently, can only wake one process	170	returns directly I<after> the tick processing (and consequently, can only wake one process
170	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	171	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
		172
		173	=item @cf::INVOKE_RESULTS
		174
		175	This array contains the results of the last C<invoke ()> call. When
		176	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
		177	that call.
171		178
172	=back	179	=back
173		180
174	=cut	181	=cut
175		182
…		…
316	};	323	};
317	$TICK_WATCHER->stop;	324	$TICK_WATCHER->stop;
318	$guard	325	$guard
319	}	326	}
320		327
		328	=item cf::get_slot $time[, $priority[, $name]]
		329
		330	Allocate $time seconds of blocking CPU time at priority C<$priority>:
		331	This call blocks and returns only when you have at least C<$time> seconds
		332	of cpu time till the next tick. The slot is only valid till the next cede.
		333
		334	The optional C<$name> can be used to identify the job to run. It might be
		335	used for statistical purposes and should identify the same time-class.
		336
		337	Useful for short background jobs.
		338
		339	=cut
		340
		341	our @SLOT_QUEUE;
		342	our $SLOT_QUEUE;
		343
		344	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
		345	$SLOT_QUEUE = Coro::async {
		346	my $signal = new Coro::Signal;
		347
		348	while () {
		349	next_job:
		350	my $avail = cf::till_tick;
		351	if ($avail > 0.01) {
		352	for (0 .. $#SLOT_QUEUE) {
		353	if ($SLOT_QUEUE[$_][0] < $avail) {
		354	my $job = splice @SLOT_QUEUE, $_, 1, ();
		355	$job->[2]->send;
		356	Coro::cede;
		357	goto next_job;
		358	}
		359	}
		360	}
		361
		362	if (@SLOT_QUEUE) {
		363	# we do not use wait_For_tick() as it returns immediately when tick is inactive
		364	push @cf::WAIT_FOR_TICK, $signal;
		365	$signal->wait;
		366	} else {
		367	Coro::schedule;
		368	}
		369	}
		370	};
		371
		372	sub get_slot($;$$) {
		373	my ($time, $pri, $name) = @_;
		374
		375	$time = $TICK * .6 if $time > $TICK * .6;
		376	my $sig = new Coro::Signal;
		377
		378	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
		379	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
		380	$SLOT_QUEUE->ready;
		381	$sig->wait;
		382	}
		383
321	=item cf::async { BLOCK }	384	=item cf::async { BLOCK }
322		385
323	Currently the same as Coro::async_pool, meaning you cannot use	386	Currently the same as Coro::async_pool, meaning you cannot use
324	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only	387	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
325	thing you are allowed to do is call C<prio> on it.	388	thing you are allowed to do is call C<prio> on it.
…		…
410	Coro::Storable. May, of course, block. Note that the executed sub may	473	Coro::Storable. May, of course, block. Note that the executed sub may
411	never block itself or use any form of Event handling.	474	never block itself or use any form of Event handling.
412		475
413	=cut	476	=cut
414		477
415	sub _store_scalar {
416	open my $fh, ">", \my $buf
417	or die "fork_call: cannot open fh-to-buf in child : $!";
418	Storable::store_fd $_[0], $fh;
419	close $fh;
420
421	$buf
422	}
423
424	sub fork_call(&@) {	478	sub fork_call(&@) {
425	my ($cb, @args) = @_;	479	my ($cb, @args) = @_;
426		480
427	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC	481	# we seemingly have to make a local copy of the whole thing,
428	# or die "socketpair: $!";	482	# otherwise perl prematurely frees the stuff :/
429	pipe my $fh1, my $fh2	483	# TODO: investigate and fix (liekly this will be rather laborious)
430	or die "pipe: $!";
431		484
432	if (my $pid = fork) {	485	my @res = Coro::Util::fork_eval {
433	close $fh2;
434
435	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
436	warn "pst<$res>" unless $res =~ /^pst/;
437	$res = Coro::Storable::thaw $res;
438
439	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
440
441	Carp::confess $$res unless "ARRAY" eq ref $res;
442
443	return wantarray ? @$res : $res->[-1];
444	} else {
445	reset_signals;	486	reset_signals;
446	local $SIG{__WARN__};	487	&$cb
447	local $SIG{__DIE__};	488	}, @args;
448	# just in case, this hack effectively disables event
449	# in the child. cleaner and slower would be canceling all watchers,
450	# but this works for the time being.
451	local $Coro::idle;
452	$Coro::current->prio (Coro::PRIO_MAX);
453		489
454	eval {	490	wantarray ? @res : $res[-1]
455	close $fh1;
456
457	my @res = eval { $cb->(@args) };
458
459	syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
460	close $fh2;
461	};
462
463	warn $@ if $@;
464	_exit 0;
465	}
466	}	491	}
467		492
468	=item $value = cf::db_get $family => $key	493	=item $value = cf::db_get $family => $key
469		494
470	Returns a single value from the environment database.	495	Returns a single value from the environment database.
…		…
866	";	891	";
867	die if $@;	892	die if $@;
868	}	893	}
869		894
870	our $override;	895	our $override;
871	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	896	our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
872		897
873	sub override {	898	sub override {
874	$override = 1;	899	$override = 1;
875	@invoke_results = ();	900	@INVOKE_RESULTS = (@_);
876	}	901	}
877		902
878	sub do_invoke {	903	sub do_invoke {
879	my $event = shift;	904	my $event = shift;
880	my $callbacks = shift;	905	my $callbacks = shift;
881		906
882	@invoke_results = ();	907	@INVOKE_RESULTS = ();
883		908
884	local $override;	909	local $override;
885		910
886	for (@$callbacks) {	911	for (@$callbacks) {
887	eval { &{$_->[1]} };	912	eval { &{$_->[1]} };
…		…
904		929
905	Generate an object-specific event with the given arguments.	930	Generate an object-specific event with the given arguments.
906		931
907	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be	932	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
908	removed in future versions), and there is no public API to access override	933	removed in future versions), and there is no public API to access override
909	results (if you must, access C<@cf::invoke_results> directly).	934	results (if you must, access C<@cf::INVOKE_RESULTS> directly).
910		935
911	=back	936	=back
912		937
913	=cut	938	=cut
914		939
915	#############################################################################	940	#############################################################################
916	# object support	941	# object support
		942	#
		943
		944	sub _can_merge {
		945	my ($ob1, $ob2) = @_;
		946
		947	local $Storable::canonical = 1;
		948	my $fob1 = Storable::freeze $ob1;
		949	my $fob2 = Storable::freeze $ob2;
		950
		951	$fob1 eq $fob2
		952	}
917		953
918	sub reattach {	954	sub reattach {
919	# basically do the same as instantiate, without calling instantiate	955	# basically do the same as instantiate, without calling instantiate
920	my ($obj) = @_;	956	my ($obj) = @_;
921		957
…		…
1108	my ($pl, $buf) = @_;	1144	my ($pl, $buf) = @_;
1109		1145
1110	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1146	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1111		1147
1112	if (ref $msg) {	1148	if (ref $msg) {
		1149	my ($type, $reply, @payload) =
		1150	"ARRAY" eq ref $msg
		1151	? @$msg
		1152	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		1153
1113	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1154	if (my $cb = $EXTCMD{$type}) {
1114	if (my %reply = $cb->($pl, $msg)) {	1155	my @reply = $cb->($pl, @payload);
		1156
1115	$pl->ext_reply ($msg->{msgid}, %reply);	1157	$pl->ext_reply ($reply, @reply)
1116	}	1158	if $reply;
1117	}	1159	}
1118	} else {	1160	} else {
1119	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1161	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1120	}	1162	}
1121		1163
…		…
1291	$self->{deny_save} = 1;	1333	$self->{deny_save} = 1;
1292		1334
1293	$cf::PLAYER{$login} = $self;	1335	$cf::PLAYER{$login} = $self;
1294		1336
1295	$self	1337	$self
		1338	}
		1339
		1340	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1341
		1342	=cut
		1343
		1344	sub send_msg {
		1345	my $ns = shift->ns
		1346	or return;
		1347	$ns->send_msg (@_);
1296	}	1348	}
1297		1349
1298	=item $pl->quit_character	1350	=item $pl->quit_character
1299		1351
1300	Nukes the player without looking back. If logged in, the connection will	1352	Nukes the player without looking back. If logged in, the connection will
…		…
1444	sub hintmode {	1496	sub hintmode {
1445	$_[0]{hintmode} = $_[1] if @_ > 1;	1497	$_[0]{hintmode} = $_[1] if @_ > 1;
1446	$_[0]{hintmode}	1498	$_[0]{hintmode}
1447	}	1499	}
1448		1500
1449	=item $player->ext_reply ($msgid, %msg)	1501	=item $player->ext_reply ($msgid, @msg)
1450		1502
1451	Sends an ext reply to the player.	1503	Sends an ext reply to the player.
1452		1504
1453	=cut	1505	=cut
1454		1506
1455	sub ext_reply($$%) {	1507	sub ext_reply($$@) {
1456	my ($self, $id, %msg) = @_;	1508	my ($self, $id, @msg) = @_;
1457		1509
1458	$msg{msgid} = $id;	1510	$self->ns->ext_reply ($id, @msg)
1459	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1460	}	1511	}
1461		1512
1462	=item $player->ext_event ($type, %msg)	1513	=item $player->ext_msg ($type, @msg)
1463		1514
1464	Sends an ext event to the client.	1515	Sends an ext event to the client.
1465		1516
1466	=cut	1517	=cut
1467		1518
1468	sub ext_event($$%) {	1519	sub ext_msg($$@) {
1469	my ($self, $type, %msg) = @_;	1520	my ($self, $type, @msg) = @_;
1470		1521
1471	$self->ns->ext_event ($type, %msg);	1522	$self->ns->ext_msg ($type, @msg);
1472	}	1523	}
1473		1524
1474	=head3 cf::region	1525	=head3 cf::region
1475		1526
1476	=over 4	1527	=over 4
…		…
1489	my ($path) = @_;	1540	my ($path) = @_;
1490		1541
1491	my ($match, $specificity);	1542	my ($match, $specificity);
1492		1543
1493	for my $region (list) {	1544	for my $region (list) {
1494	if ($region->match && $path =~ $region->match) {	1545	if ($region->{match} && $path =~ $region->{match}) {
1495	($match, $specificity) = ($region, $region->specificity)	1546	($match, $specificity) = ($region, $region->specificity)
1496	if $region->specificity > $specificity;	1547	if $region->specificity > $specificity;
1497	}	1548	}
1498	}	1549	}
1499		1550
…		…
1619	$self->init; # pass $1 etc.	1670	$self->init; # pass $1 etc.
1620	return $self;	1671	return $self;
1621	}	1672	}
1622	}	1673	}
1623		1674
1624	Carp::carp "unable to resolve path '$path' (base '$base').";	1675	Carp::cluck "unable to resolve path '$path' (base '$base').";
1625	()	1676	()
1626	}	1677	}
1627		1678
1628	sub init {	1679	sub init {
1629	my ($self) = @_;	1680	my ($self) = @_;
…		…
1837	$self->set_darkness_map;	1888	$self->set_darkness_map;
1838	Coro::cede;	1889	Coro::cede;
1839	$self->activate;	1890	$self->activate;
1840	}	1891	}
1841		1892
		1893	$self->{last_save} = $cf::RUNTIME;
		1894	$self->last_access ($cf::RUNTIME);
		1895
1842	$self->in_memory (cf::MAP_IN_MEMORY);	1896	$self->in_memory (cf::MAP_IN_MEMORY);
1843	}	1897	}
1844		1898
1845	$self->post_load;	1899	$self->post_load;
1846	}	1900	}
…		…
1856		1910
1857	$self	1911	$self
1858	}	1912	}
1859		1913
1860	# find and load all maps in the 3x3 area around a map	1914	# find and load all maps in the 3x3 area around a map
1861	sub load_diag {	1915	sub load_neighbours {
1862	my ($map) = @_;	1916	my ($map) = @_;
1863		1917
1864	my @diag; # diagonal neighbours	1918	my @neigh; # diagonal neighbours
1865		1919
1866	for (0 .. 3) {	1920	for (0 .. 3) {
1867	my $neigh = $map->tile_path ($_)	1921	my $neigh = $map->tile_path ($_)
1868	or next;	1922	or next;
1869	$neigh = find $neigh, $map	1923	$neigh = find $neigh, $map
1870	or next;	1924	or next;
1871	$neigh->load;	1925	$neigh->load;
1872		1926
		1927	push @neigh,
1873	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],	1928	[$neigh->tile_path (($_ + 3) % 4), $neigh],
1874	[$neigh->tile_path (($_ + 1) % 4), $neigh];	1929	[$neigh->tile_path (($_ + 1) % 4), $neigh];
1875	}	1930	}
1876		1931
1877	for (@diag) {	1932	for (grep defined $_->[0], @neigh) {
		1933	my ($path, $origin) = @$_;
1878	my $neigh = find @$_	1934	my $neigh = find $path, $origin
1879	or next;	1935	or next;
1880	$neigh->load;	1936	$neigh->load;
1881	}	1937	}
1882	}	1938	}
1883		1939
…		…
1907		1963
1908	undef $MAP_PREFETCH{$path};	1964	undef $MAP_PREFETCH{$path};
1909	$MAP_PREFETCHER \|\|= cf::async {	1965	$MAP_PREFETCHER \|\|= cf::async {
1910	while (%MAP_PREFETCH) {	1966	while (%MAP_PREFETCH) {
1911	for my $path (keys %MAP_PREFETCH) {	1967	for my $path (keys %MAP_PREFETCH) {
1912	my $map = find $path	1968	if (my $map = find $path) {
1913	or next;
1914	$map->load;	1969	$map->load;
		1970	}
1915		1971
1916	delete $MAP_PREFETCH{$path};	1972	delete $MAP_PREFETCH{$path};
1917	}	1973	}
1918	}	1974	}
1919	undef $MAP_PREFETCHER;	1975	undef $MAP_PREFETCHER;
…		…
2146		2202
2147	} else {	2203	} else {
2148	my $pl = $self->contr;	2204	my $pl = $self->contr;
2149		2205
2150	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2206	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2151	my $diag = $pl->{npc_dialog};	2207	my $dialog = $pl->{npc_dialog};
2152	$diag->{pl}->ext_reply (	2208	$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		2209
2159	} else {	2210	} else {
2160	$msg = $npc->name . " says: $msg" if $npc;	2211	$msg = $npc->name . " says: $msg" if $npc;
2161	$self->message ($msg, $flags);	2212	$self->message ($msg, $flags);
2162	}	2213	}
2163	}	2214	}
		2215	}
		2216
		2217	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2218
		2219	=cut
		2220
		2221	sub cf::object::send_msg {
		2222	my $pl = shift->contr
		2223	or return;
		2224	$pl->send_msg (@_);
2164	}	2225	}
2165		2226
2166	=item $player_object->may ("access")	2227	=item $player_object->may ("access")
2167		2228
2168	Returns wether the given player is authorized to access resource "access"	2229	Returns wether the given player is authorized to access resource "access"
…		…
2247	# use -1 or undef as default coordinates, not 0, 0	2308	# use -1 or undef as default coordinates, not 0, 0
2248	($x, $y) = ($map->enter_x, $map->enter_y)	2309	($x, $y) = ($map->enter_x, $map->enter_y)
2249	if $x <=0 && $y <= 0;	2310	if $x <=0 && $y <= 0;
2250		2311
2251	$map->load;	2312	$map->load;
2252	$map->load_diag;	2313	$map->load_neighbours;
2253		2314
2254	return unless $self->contr->active;	2315	return unless $self->contr->active;
2255	$self->activate_recursive;	2316	$self->activate_recursive;
2256		2317
2257	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2318	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2258	$self->enter_map ($map, $x, $y);	2319	$self->enter_map ($map, $x, $y);
2259	}	2320	}
2260		2321
2261	=item $player_object->goto ($path, $x, $y[, $check->($map)])	2322	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2262		2323
2263	Moves the player to the given map-path and coordinates by first freezing	2324	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	2325	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	2326	that has to return the map if sucecssful, and then unfreezes the player on
2266	the new (success) or old (failed) map position.	2327	the new (success) or old (failed) map position. In either case, $done will
		2328	be called at the end of this process.
2267		2329
2268	=cut	2330	=cut
2269		2331
2270	our $GOTOGEN;	2332	our $GOTOGEN;
2271		2333
2272	sub cf::object::player::goto {	2334	sub cf::object::player::goto {
2273	my ($self, $path, $x, $y, $check) = @_;	2335	my ($self, $path, $x, $y, $check, $done) = @_;
2274		2336
2275	# do generation counting so two concurrent goto's will be executed in-order	2337	# do generation counting so two concurrent goto's will be executed in-order
2276	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2338	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2277		2339
2278	$self->enter_link;	2340	$self->enter_link;
…		…
2298		2360
2299	if ($gen == $self->{_goto_generation}) {	2361	if ($gen == $self->{_goto_generation}) {
2300	delete $self->{_goto_generation};	2362	delete $self->{_goto_generation};
2301	$self->leave_link ($map, $x, $y);	2363	$self->leave_link ($map, $x, $y);
2302	}	2364	}
		2365
		2366	$done->() if $done;
2303	})->prio (1);	2367	})->prio (1);
2304	}	2368	}
2305		2369
2306	=item $player_object->enter_exit ($exit_object)	2370	=item $player_object->enter_exit ($exit_object)
2307		2371
…		…
2416		2480
2417	utf8::encode $text;	2481	utf8::encode $text;
2418	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2482	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2419	}	2483	}
2420		2484
2421	=item $client->send_msg ($color, $type, $msg, [extra...])	2485	=item $client->send_msg ($channel, $msg, $color, [extra...])
2422		2486
2423	Send a drawinfo or msg packet to the client, formatting the msg for the	2487	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	2488	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	2489	the message, with C<log> being the default. If C<$color> is negative, suppress
2426	the message unless the client supports the msg packet.	2490	the message unless the client supports the msg packet.
2427		2491
2428	=cut	2492	=cut
2429		2493
2430	sub cf::client::send_msg {	2494	sub cf::client::send_msg {
2431	my ($self, $color, $type, $msg, @extra) = @_;	2495	my ($self, $channel, $msg, $color, @extra) = @_;
2432		2496
2433	$msg = $self->pl->expand_cfpod ($msg);	2497	$msg = $self->pl->expand_cfpod ($msg);
2434		2498
		2499	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2500
		2501	if (ref $channel) {
		2502	# send meta info to client, if not yet sent
		2503	unless (exists $self->{channel}{$channel->{id}}) {
		2504	$self->{channel}{$channel->{id}} = $channel;
		2505	$self->ext_msg (channel_info => $channel);
		2506	}
		2507
		2508	$channel = $channel->{id};
		2509	}
		2510
2435	return unless @extra \|\| length $msg;	2511	return unless @extra \|\| length $msg;
2436		2512
2437	if ($self->can_msg) {	2513	if ($self->can_msg) {
		2514	# default colour, mask it out
		2515	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2516	if $color & cf::NDI_DEF;
		2517
2438	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));	2518	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2519	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2439	} else {	2520	} 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) {	2521	if ($color >= 0) {
		2522	# replace some tags by gcfclient-compatible ones
		2523	for ($msg) {
		2524	1 while
		2525	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2526	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2527	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2528	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2529	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2530	}
		2531
		2532	$color &= cf::NDI_COLOR_MASK;
		2533
		2534	utf8::encode $msg;
		2535
2451	if (0 && $msg =~ /\[/) {	2536	if (0 && $msg =~ /\[/) {
		2537	# COMMAND/INFO
2452	$self->send_packet ("drawextinfo $color 4 0 $msg")	2538	$self->send_packet ("drawextinfo $color 10 8 $msg")
2453	} else {	2539	} else {
2454	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2540	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2455	$self->send_packet ("drawinfo $color $msg")	2541	$self->send_packet ("drawinfo $color $msg")
2456	}	2542	}
2457	}	2543	}
2458	}	2544	}
2459	}	2545	}
2460		2546
2461	=item $client->ext_event ($type, %msg)	2547	=item $client->ext_msg ($type, @msg)
2462		2548
2463	Sends an ext event to the client.	2549	Sends an ext event to the client.
2464		2550
2465	=cut	2551	=cut
2466		2552
2467	sub cf::client::ext_event($$%) {	2553	sub cf::client::ext_msg($$@) {
2468	my ($self, $type, %msg) = @_;	2554	my ($self, $type, @msg) = @_;
2469		2555
		2556	my $extcmd = $self->extcmd;
		2557
		2558	if ($extcmd == 2) {
		2559	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2560	} elsif ($extcmd == 1) { # TODO: remove
2470	$msg{msgtype} = "event_$type";	2561	push @msg, msgtype => "event_$type";
2471	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2562	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2563	}
		2564	}
		2565
		2566	=item $client->ext_reply ($msgid, @msg)
		2567
		2568	Sends an ext reply to the client.
		2569
		2570	=cut
		2571
		2572	sub cf::client::ext_reply($$@) {
		2573	my ($self, $id, @msg) = @_;
		2574
		2575	if ($self->extcmd == 2) {
		2576	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
		2577	} elsif ($self->ns->extcmd == 1) {
		2578	#TODO: version 1, remove
		2579	unshift @msg, msgtype => "reply", msgid => $id;
		2580	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2581	}
2472	}	2582	}
2473		2583
2474	=item $success = $client->query ($flags, "text", \&cb)	2584	=item $success = $client->query ($flags, "text", \&cb)
2475		2585
2476	Queues a query to the client, calling the given callback with	2586	Queues a query to the client, calling the given callback with
…		…
2531	my ($ns, $buf) = @_;	2641	my ($ns, $buf) = @_;
2532		2642
2533	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2643	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2534		2644
2535	if (ref $msg) {	2645	if (ref $msg) {
		2646	my ($type, $reply, @payload) =
		2647	"ARRAY" eq ref $msg
		2648	? @$msg
		2649	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2650
2536	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2651	if (my $cb = $EXTICMD{$type}) {
2537	if (my %reply = $cb->($ns, $msg)) {	2652	my @reply = $cb->($ns, @payload);
2538	$reply{msgid} = $msg->{msgid};	2653
2539	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));	2654	$ns->ext_reply ($reply, @reply)
2540	}	2655	if $reply;
2541	}	2656	}
2542	} else {	2657	} else {
2543	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2658	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2544	}	2659	}
2545		2660
…		…
2593	our $safe = new Safe "safe";	2708	our $safe = new Safe "safe";
2594	our $safe_hole = new Safe::Hole;	2709	our $safe_hole = new Safe::Hole;
2595		2710
2596	$SIG{FPE} = 'IGNORE';	2711	$SIG{FPE} = 'IGNORE';
2597		2712
2598	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2713	$safe->permit_only (Opcode::opset qw(
		2714	:base_core :base_mem :base_orig :base_math
		2715	grepstart grepwhile mapstart mapwhile
		2716	sort time
		2717	));
2599		2718
2600	# here we export the classes and methods available to script code	2719	# here we export the classes and methods available to script code
2601		2720
2602	=pod	2721	=pod
2603		2722
2604	The following functions and methods are available within a safe environment:	2723	The following functions and methods are available within a safe environment:
2605		2724
2606	cf::object	2725	cf::object
2607	contr pay_amount pay_player map x y force_find force_add	2726	contr pay_amount pay_player map x y force_find force_add
2608	insert remove	2727	insert remove name archname title slaying race
2609		2728
2610	cf::object::player	2729	cf::object::player
2611	player	2730	player
2612		2731
2613	cf::player	2732	cf::player
…		…
2618		2737
2619	=cut	2738	=cut
2620		2739
2621	for (	2740	for (
2622	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2741	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2623	insert remove)],	2742	insert remove inv name archname title slaying race)],
2624	["cf::object::player" => qw(player)],	2743	["cf::object::player" => qw(player)],
2625	["cf::player" => qw(peaceful)],	2744	["cf::player" => qw(peaceful)],
2626	["cf::map" => qw(trigger)],	2745	["cf::map" => qw(trigger)],
2627	) {	2746	) {
2628	no strict 'refs';	2747	no strict 'refs';
…		…
2704	# the server's init and main functions	2823	# the server's init and main functions
2705		2824
2706	sub load_facedata($) {	2825	sub load_facedata($) {
2707	my ($path) = @_;	2826	my ($path) = @_;
2708		2827
		2828	my $enc = JSON::XS->new->utf8->canonical;
		2829
2709	warn "loading facedata from $path\n";	2830	warn "loading facedata from $path\n";
2710		2831
2711	my $facedata;	2832	my $facedata;
2712	0 < aio_load $path, $facedata	2833	0 < aio_load $path, $facedata
2713	or die "$path: $!";	2834	or die "$path: $!";
2714		2835
2715	$facedata = Coro::Storable::thaw $facedata;	2836	$facedata = Coro::Storable::thaw $facedata;
2716		2837
2717	$facedata->{version} == 2	2838	$facedata->{version} == 2
2718	or cf::cleanup "$path: version mismatch, cannot proceed.";	2839	or cf::cleanup "$path: version mismatch, cannot proceed.";
		2840
		2841	# patch in the exptable
		2842	$facedata->{resource}{"res/exp_table"} = {
		2843	type => FT_RSRC,
		2844	data => $enc->encode ([map cf::level_to_min_exp $_, 0 .. cf::settings->max_level]),
		2845	};
		2846	cf::cede_to_tick;
2719		2847
2720	{	2848	{
2721	my $faces = $facedata->{faceinfo};	2849	my $faces = $facedata->{faceinfo};
2722		2850
2723	while (my ($face, $info) = each %$faces) {	2851	while (my ($face, $info) = each %$faces) {
2724	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2852	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2725	cf::face::set_visibility $idx, $info->{visibility};	2853	cf::face::set_visibility $idx, $info->{visibility};
2726	cf::face::set_magicmap $idx, $info->{magicmap};	2854	cf::face::set_magicmap $idx, $info->{magicmap};
2727	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2855	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2728	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2856	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2729		2857
2730	cf::cede_to_tick;	2858	cf::cede_to_tick;
2731	}	2859	}
2732		2860
2733	while (my ($face, $info) = each %$faces) {	2861	while (my ($face, $info) = each %$faces) {
…		…
2758		2886
2759	{	2887	{
2760	# TODO: for gcfclient pleasure, we should give resources	2888	# TODO: for gcfclient pleasure, we should give resources
2761	# that gcfclient doesn't grok a >10000 face index.	2889	# that gcfclient doesn't grok a >10000 face index.
2762	my $res = $facedata->{resource};	2890	my $res = $facedata->{resource};
2763	my $enc = JSON::XS->new->utf8->canonical;	2891
		2892	my $soundconf = delete $res->{"res/sound.conf"};
2764		2893
2765	while (my ($name, $info) = each %$res) {	2894	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;	2895	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		2896	my $data;
		2897
		2898	if ($info->{type} & 1) {
		2899	# prepend meta info
		2900
		2901	my $meta = $enc->encode ({
		2902	name => $name,
		2903	%{ $info->{meta} \|\| {} },
		2904	});
		2905
		2906	$data = pack "(w/a)", $meta, $info->{data};
		2907	}
		2908
		2909	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2775	cf::face::set_type $idx, 1;	2910	cf::face::set_type $idx, $info->{type};
2776	cf::face::set_data $idx, 0, $data, $chk;
2777		2911
2778	cf::cede_to_tick;	2912	cf::cede_to_tick;
2779	}	2913	}
		2914
		2915	if ($soundconf) {
		2916	$soundconf = $enc->decode (delete $soundconf->{data});
		2917
		2918	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		2919	my $sound = $soundconf->{compat}[$_]
		2920	or next;
		2921
		2922	my $face = cf::face::find "sound/$sound->[1]";
		2923	cf::sound::set $sound->[0] => $face;
		2924	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		2925	}
		2926
		2927	while (my ($k, $v) = each %{$soundconf->{event}}) {
		2928	my $face = cf::face::find "sound/$v";
		2929	cf::sound::set $k => $face;
		2930	}
		2931	}
2780	}	2932	}
2781		2933
2782	1	2934	1
2783	}	2935	}
		2936
		2937	register_exticmd fx_want => sub {
		2938	my ($ns, $want) = @_;
		2939
		2940	while (my ($k, $v) = each %$want) {
		2941	$ns->fx_want ($k, $v);
		2942	}
		2943	};
2784		2944
2785	sub reload_regions {	2945	sub reload_regions {
2786	load_resource_file "$MAPDIR/regions"	2946	load_resource_file "$MAPDIR/regions"
2787	or die "unable to load regions file\n";	2947	or die "unable to load regions file\n";
		2948
		2949	for (cf::region::list) {
		2950	$_->{match} = qr/$_->{match}/
		2951	if exists $_->{match};
		2952	}
2788	}	2953	}
2789		2954
2790	sub reload_facedata {	2955	sub reload_facedata {
2791	load_facedata "$DATADIR/facedata"	2956	load_facedata "$DATADIR/facedata"
2792	or die "unable to load facedata\n";	2957	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.336 by root, Tue Aug 21 00:31:18 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.336 by root, Tue Aug 21 00:31:18 2007 UTC