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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.282 by elmex, Tue Jun 19 18:15:34 2007 UTC vs.
Revision 1.312 by root, Sat Jul 21 18:01:26 2007 UTC

…		…
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		24
		25	use JSON::XS 1.4 ();
25	use BDB ();	26	use BDB ();
26	use Data::Dumper;	27	use Data::Dumper;
27	use Digest::MD5;	28	use Digest::MD5;
28	use Fcntl;	29	use Fcntl;
29	use YAML::Syck ();	30	use YAML::Syck ();
30	use IO::AIO 2.32 ();	31	use IO::AIO 2.32 ();
31	use Time::HiRes;	32	use Time::HiRes;
32	use Compress::LZF;	33	use Compress::LZF;
		34	use Digest::MD5 ();
33		35
34	# configure various modules to our taste	36	# configure various modules to our taste
35	#	37	#
36	$Storable::canonical = 1; # reduce rsync transfers	38	$Storable::canonical = 1; # reduce rsync transfers
37	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator	39	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
…		…
49	our %COMMAND = ();	51	our %COMMAND = ();
50	our %COMMAND_TIME = ();	52	our %COMMAND_TIME = ();
51		53
52	our @EXTS = (); # list of extension package names	54	our @EXTS = (); # list of extension package names
53	our %EXTCMD = ();	55	our %EXTCMD = ();
		56	our %EXTICMD = ();
54	our %EXT_CORO = (); # coroutines bound to extensions	57	our %EXT_CORO = (); # coroutines bound to extensions
55	our %EXT_MAP = (); # pluggable maps	58	our %EXT_MAP = (); # pluggable maps
56		59
57	our $RELOAD; # number of reloads so far	60	our $RELOAD; # number of reloads so far
58	our @EVENT;	61	our @EVENT;
…		…
163	=item cf::wait_for_tick, cf::wait_for_tick_begin	166	=item cf::wait_for_tick, cf::wait_for_tick_begin
164		167
165	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	168	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
166	returns directly I<after> the tick processing (and consequently, can only wake one process	169	returns directly I<after> the tick processing (and consequently, can only wake one process
167	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	170	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
		171
		172	=item @cf::INVOKE_RESULTS
		173
		174	This array contains the results of the last C<invoke ()> call. When
		175	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
		176	that call.
168		177
169	=back	178	=back
170		179
171	=cut	180	=cut
172		181
…		…
236	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;	245	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
237	$d	246	$d
238	} \|\| "[unable to dump $_[0]: '$@']";	247	} \|\| "[unable to dump $_[0]: '$@']";
239	}	248	}
240		249
241	use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
242
243	=item $ref = cf::from_json $json	250	=item $ref = cf::from_json $json
244		251
245	Converts a JSON string into the corresponding perl data structure.	252	Converts a JSON string into the corresponding perl data structure.
246		253
247	=item $json = cf::to_json $ref	254	=item $json = cf::to_json $ref
248		255
249	Converts a perl data structure into its JSON representation.	256	Converts a perl data structure into its JSON representation.
		257
		258	=cut
		259
		260	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
		261
		262	sub to_json ($) { $json_coder->encode ($_[0]) }
		263	sub from_json ($) { $json_coder->decode ($_[0]) }
250		264
251	=item cf::lock_wait $string	265	=item cf::lock_wait $string
252		266
253	Wait until the given lock is available. See cf::lock_acquire.	267	Wait until the given lock is available. See cf::lock_acquire.
254		268
…		…
402	Coro::Storable. May, of course, block. Note that the executed sub may	416	Coro::Storable. May, of course, block. Note that the executed sub may
403	never block itself or use any form of Event handling.	417	never block itself or use any form of Event handling.
404		418
405	=cut	419	=cut
406		420
		421	sub _store_scalar {
		422	open my $fh, ">", \my $buf
		423	or die "fork_call: cannot open fh-to-buf in child : $!";
		424	Storable::store_fd $_[0], $fh;
		425	close $fh;
		426
		427	$buf
		428	}
		429
407	sub fork_call(&@) {	430	sub fork_call(&@) {
408	my ($cb, @args) = @_;	431	my ($cb, @args) = @_;
409		432
410	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC	433	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
411	# or die "socketpair: $!";	434	# or die "socketpair: $!";
…		…
414		437
415	if (my $pid = fork) {	438	if (my $pid = fork) {
416	close $fh2;	439	close $fh2;
417		440
418	my $res = (Coro::Handle::unblock $fh1)->readline (undef);	441	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
		442	warn "pst<$res>" unless $res =~ /^pst/;
419	$res = Coro::Storable::thaw $res;	443	$res = Coro::Storable::thaw $res;
420		444
421	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave	445	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
422		446
423	die $$res unless "ARRAY" eq ref $res;	447	Carp::confess $$res unless "ARRAY" eq ref $res;
424		448
425	return wantarray ? @$res : $res->[-1];	449	return wantarray ? @$res : $res->[-1];
426	} else {	450	} else {
427	reset_signals;	451	reset_signals;
428	local $SIG{__WARN__};	452	local $SIG{__WARN__};
429	local $SIG{__DIE__};	453	local $SIG{__DIE__};
		454	# just in case, this hack effectively disables event
		455	# in the child. cleaner and slower would be canceling all watchers,
		456	# but this works for the time being.
		457	local $Coro::idle;
		458	$Coro::current->prio (Coro::PRIO_MAX);
		459
430	eval {	460	eval {
431	close $fh1;	461	close $fh1;
432		462
433	my @res = eval { $cb->(@args) };	463	my @res = eval { $cb->(@args) };
		464
434	syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);	465	syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
		466	close $fh2;
435	};	467	};
436		468
437	warn $@ if $@;	469	warn $@ if $@;
438	_exit 0;	470	_exit 0;
439	}	471	}
…		…
840	";	872	";
841	die if $@;	873	die if $@;
842	}	874	}
843		875
844	our $override;	876	our $override;
845	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	877	our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
846		878
847	sub override {	879	sub override {
848	$override = 1;	880	$override = 1;
849	@invoke_results = ();	881	@INVOKE_RESULTS = (@_);
850	}	882	}
851		883
852	sub do_invoke {	884	sub do_invoke {
853	my $event = shift;	885	my $event = shift;
854	my $callbacks = shift;	886	my $callbacks = shift;
855		887
856	@invoke_results = ();	888	@INVOKE_RESULTS = ();
857		889
858	local $override;	890	local $override;
859		891
860	for (@$callbacks) {	892	for (@$callbacks) {
861	eval { &{$_->[1]} };	893	eval { &{$_->[1]} };
…		…
878		910
879	Generate an object-specific event with the given arguments.	911	Generate an object-specific event with the given arguments.
880		912
881	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be	913	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
882	removed in future versions), and there is no public API to access override	914	removed in future versions), and there is no public API to access override
883	results (if you must, access C<@cf::invoke_results> directly).	915	results (if you must, access C<@cf::INVOKE_RESULTS> directly).
884		916
885	=back	917	=back
886		918
887	=cut	919	=cut
888		920
889	#############################################################################	921	#############################################################################
890	# object support	922	# object support
		923	#
		924
		925	sub _can_merge {
		926	my ($ob1, $ob2) = @_;
		927
		928	local $Storable::canonical = 1;
		929	my $fob1 = Storable::freeze $ob1;
		930	my $fob2 = Storable::freeze $ob2;
		931
		932	$fob1 eq $fob2
		933	}
891		934
892	sub reattach {	935	sub reattach {
893	# basically do the same as instantiate, without calling instantiate	936	# basically do the same as instantiate, without calling instantiate
894	my ($obj) = @_;	937	my ($obj) = @_;
895		938
…		…
1029	push @{ $COMMAND{$name} }, [$caller, $cb];	1072	push @{ $COMMAND{$name} }, [$caller, $cb];
1030	}	1073	}
1031		1074
1032	=item cf::register_extcmd $name => \&callback($pl,$packet);	1075	=item cf::register_extcmd $name => \&callback($pl,$packet);
1033		1076
1034	Register a callback fro execution when the client sends an extcmd packet.	1077	Register a callback for execution when the client sends an (synchronous)
		1078	extcmd packet. Ext commands will be processed in the order they are
		1079	received by the server, like other user commands. The first argument is
		1080	the logged-in player. Ext commands can only be processed after a player
		1081	has logged in successfully.
1035		1082
1036	If the callback returns something, it is sent back as if reply was being	1083	If the callback returns something, it is sent back as if reply was being
1037	called.	1084	called.
1038		1085
		1086	=item cf::register_exticmd $name => \&callback($ns,$packet);
		1087
		1088	Register a callback for execution when the client sends an (asynchronous)
		1089	exticmd packet. Exti commands are processed by the server as soon as they
		1090	are received, i.e. out of order w.r.t. other commands. The first argument
		1091	is a client socket. Exti commands can be received anytime, even before
		1092	log-in.
		1093
		1094	If the callback returns something, it is sent back as if reply was being
		1095	called.
		1096
1039	=cut	1097	=cut
1040		1098
1041	sub register_extcmd {	1099	sub register_extcmd {
1042	my ($name, $cb) = @_;	1100	my ($name, $cb) = @_;
1043		1101
1044	$EXTCMD{$name} = $cb;	1102	$EXTCMD{$name} = $cb;
		1103	}
		1104
		1105	sub register_exticmd {
		1106	my ($name, $cb) = @_;
		1107
		1108	$EXTICMD{$name} = $cb;
1045	}	1109	}
1046		1110
1047	cf::player->attach (	1111	cf::player->attach (
1048	on_command => sub {	1112	on_command => sub {
1049	my ($pl, $name, $params) = @_;	1113	my ($pl, $name, $params) = @_;
…		…
1058	cf::override;	1122	cf::override;
1059	},	1123	},
1060	on_extcmd => sub {	1124	on_extcmd => sub {
1061	my ($pl, $buf) = @_;	1125	my ($pl, $buf) = @_;
1062		1126
1063	my $msg = eval { from_json $buf };	1127	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1064		1128
1065	if (ref $msg) {	1129	if (ref $msg) {
1066	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1130	if (my $cb = $EXTCMD{$msg->{msgtype}}) {
1067	if (my %reply = $cb->($pl, $msg)) {	1131	if (my %reply = $cb->($pl, $msg)) {
1068	$pl->ext_reply ($msg->{msgid}, %reply);	1132	$pl->ext_reply ($msg->{msgid}, %reply);
…		…
1347	}	1411	}
1348		1412
1349	\@paths	1413	\@paths
1350	}	1414	}
1351		1415
		1416	=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
		1417
		1418	Expand crossfire pod fragments into protocol xml.
		1419
		1420	=cut
		1421
		1422	sub expand_cfpod {
		1423	((my $self), (local $_)) = @_;
		1424
		1425	# escape & and <
		1426	s/&/&/g;
		1427	s/(?<![BIUGH])</</g;
		1428
		1429	# this is buggy, it needs to properly take care of nested <'s
		1430
		1431	1 while
		1432	# replace B<>, I<>, U<> etc.
		1433	s/B<([^\>]*)>/<b>$1<\/b>/
		1434	\|\| s/I<([^\>]*)>/<i>$1<\/i>/
		1435	\|\| s/U<([^\>]*)>/<u>$1<\/u>/
		1436	# replace G<male\|female> tags
		1437	\|\| s{G<([^>\|])\\|([^>])>}{
		1438	$self->gender ? $2 : $1
		1439	}ge
		1440	# replace H<hint text>
		1441	\|\| s{H<([^\>]*)>}
		1442	{
		1443	("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
		1444	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
		1445	"")
		1446	[$self->{hintmode}]
		1447	}ge;
		1448
		1449	# create single paragraphs (very hackish)
		1450	s/(?<=\S)\n(?=\w)/ /g;
		1451
		1452	# compress some whitespace
		1453	s/\s+\n/\n/g; # ws line-ends
		1454	s/\n\n+/\n/g; # double lines
		1455	s/^\n+//; # beginning lines
		1456	s/\n+$//; # ending lines
		1457
		1458	$_
		1459	}
		1460
		1461	sub hintmode {
		1462	$_[0]{hintmode} = $_[1] if @_ > 1;
		1463	$_[0]{hintmode}
		1464	}
		1465
1352	=item $player->ext_reply ($msgid, %msg)	1466	=item $player->ext_reply ($msgid, %msg)
1353		1467
1354	Sends an ext reply to the player.	1468	Sends an ext reply to the player.
1355		1469
1356	=cut	1470	=cut
1357		1471
1358	sub ext_reply($$%) {	1472	sub ext_reply($$%) {
1359	my ($self, $id, %msg) = @_;	1473	my ($self, $id, %msg) = @_;
1360		1474
1361	$msg{msgid} = $id;	1475	$msg{msgid} = $id;
1362		1476	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1363	$self->send ("ext " . cf::to_json \%msg);
1364	}	1477	}
1365		1478
1366	=item $player->ext_event ($type, %msg)	1479	=item $player->ext_event ($type, %msg)
1367		1480
1368	Sends an ext event to the client.	1481	Sends an ext event to the client.
…		…
1393	my ($path) = @_;	1506	my ($path) = @_;
1394		1507
1395	my ($match, $specificity);	1508	my ($match, $specificity);
1396		1509
1397	for my $region (list) {	1510	for my $region (list) {
1398	if ($region->match && $path =~ $region->match) {	1511	if ($region->{match} && $path =~ $region->{match}) {
1399	($match, $specificity) = ($region, $region->specificity)	1512	($match, $specificity) = ($region, $region->specificity)
1400	if $region->specificity > $specificity;	1513	if $region->specificity > $specificity;
1401	}	1514	}
1402	}	1515	}
1403		1516
…		…
1523	$self->init; # pass $1 etc.	1636	$self->init; # pass $1 etc.
1524	return $self;	1637	return $self;
1525	}	1638	}
1526	}	1639	}
1527		1640
1528	Carp::carp "unable to resolve path '$path' (base '$base').";	1641	Carp::cluck "unable to resolve path '$path' (base '$base').";
1529	()	1642	()
1530	}	1643	}
1531		1644
1532	sub init {	1645	sub init {
1533	my ($self) = @_;	1646	my ($self) = @_;
…		…
1811		1924
1812	undef $MAP_PREFETCH{$path};	1925	undef $MAP_PREFETCH{$path};
1813	$MAP_PREFETCHER \|\|= cf::async {	1926	$MAP_PREFETCHER \|\|= cf::async {
1814	while (%MAP_PREFETCH) {	1927	while (%MAP_PREFETCH) {
1815	for my $path (keys %MAP_PREFETCH) {	1928	for my $path (keys %MAP_PREFETCH) {
1816	my $map = find $path	1929	if (my $map = find $path) {
1817	or next;
1818	$map->load;	1930	$map->load;
		1931	}
1819		1932
1820	delete $MAP_PREFETCH{$path};	1933	delete $MAP_PREFETCH{$path};
1821	}	1934	}
1822	}	1935	}
1823	undef $MAP_PREFETCHER;	1936	undef $MAP_PREFETCHER;
…		…
2052	my $pl = $self->contr;	2165	my $pl = $self->contr;
2053		2166
2054	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2167	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2055	my $diag = $pl->{npc_dialog};	2168	my $diag = $pl->{npc_dialog};
2056	$diag->{pl}->ext_reply (	2169	$diag->{pl}->ext_reply (
2057	$diag->{id}, msgtype => "reply", msg => $msg, add_topics => []	2170	$diag->{id},
		2171	msgtype => "reply",
		2172	msg => $diag->{pl}->expand_cfpod ($msg),
		2173	add_topics => []
2058	);	2174	);
2059		2175
2060	} else {	2176	} else {
2061	$msg = $npc->name . " says: $msg" if $npc;	2177	$msg = $npc->name . " says: $msg" if $npc;
2062	$self->message ($msg, $flags);	2178	$self->message ($msg, $flags);
…		…
2157		2273
2158	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2274	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2159	$self->enter_map ($map, $x, $y);	2275	$self->enter_map ($map, $x, $y);
2160	}	2276	}
2161		2277
2162	=item $player_object->goto ($path, $x, $y[, $check->($map)])	2278	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2163		2279
2164	Moves the player to the given map-path and coordinates by first freezing	2280	Moves the player to the given map-path and coordinates by first freezing
2165	her, loading and preparing them map, calling the provided $check callback	2281	her, loading and preparing them map, calling the provided $check callback
2166	that has to return the map if sucecssful, and then unfreezes the player on	2282	that has to return the map if sucecssful, and then unfreezes the player on
2167	the new (success) or old (failed) map position.	2283	the new (success) or old (failed) map position. In either case, $done will
		2284	be called at the end of this process.
2168		2285
2169	=cut	2286	=cut
2170		2287
2171	our $GOTOGEN;	2288	our $GOTOGEN;
2172		2289
2173	sub cf::object::player::goto {	2290	sub cf::object::player::goto {
2174	my ($self, $path, $x, $y, $check) = @_;	2291	my ($self, $path, $x, $y, $check, $done) = @_;
2175		2292
2176	# do generation counting so two concurrent goto's will be executed in-order	2293	# do generation counting so two concurrent goto's will be executed in-order
2177	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2294	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2178		2295
2179	$self->enter_link;	2296	$self->enter_link;
…		…
2199		2316
2200	if ($gen == $self->{_goto_generation}) {	2317	if ($gen == $self->{_goto_generation}) {
2201	delete $self->{_goto_generation};	2318	delete $self->{_goto_generation};
2202	$self->leave_link ($map, $x, $y);	2319	$self->leave_link ($map, $x, $y);
2203	}	2320	}
		2321
		2322	$done->() if $done;
2204	})->prio (1);	2323	})->prio (1);
2205	}	2324	}
2206		2325
2207	=item $player_object->enter_exit ($exit_object)	2326	=item $player_object->enter_exit ($exit_object)
2208		2327
…		…
2277	my $hp = $exit->stats->hp;	2396	my $hp = $exit->stats->hp;
2278	my $sp = $exit->stats->sp;	2397	my $sp = $exit->stats->sp;
2279		2398
2280	$self->enter_link;	2399	$self->enter_link;
2281		2400
		2401	# if exit is damned, update players death & WoR home-position
		2402	$self->contr->savebed ($slaying, $hp, $sp)
		2403	if $exit->flag (FLAG_DAMNED);
		2404
2282	(async {	2405	(async {
2283	$self->deactivate_recursive; # just to be sure	2406	$self->deactivate_recursive; # just to be sure
2284	unless (eval {	2407	unless (eval {
2285	$self->goto ($slaying, $hp, $sp);	2408	$self->goto ($slaying, $hp, $sp);
2286		2409
…		…
2313		2436
2314	utf8::encode $text;	2437	utf8::encode $text;
2315	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2438	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2316	}	2439	}
2317		2440
		2441	=item $client->send_msg ($channel, $msg, $color, [extra...])
		2442
		2443	Send a drawinfo or msg packet to the client, formatting the msg for the
		2444	client if neccessary. C<$type> should be a string identifying the type of
		2445	the message, with C<log> being the default. If C<$color> is negative, suppress
		2446	the message unless the client supports the msg packet.
		2447
		2448	=cut
		2449
		2450	sub cf::client::send_msg {
		2451	my ($self, $channel, $msg, $color, @extra) = @_;
		2452
		2453	$msg = $self->pl->expand_cfpod ($msg);
		2454
		2455	return unless @extra \|\| length $msg;
		2456
		2457	$color &= ~cf::NDI_UNIQUE; # just in case...
		2458
		2459	if (ref $channel) {
		2460	# send meta info to client, if not yet sent
		2461	unless (exists $self->{channel}{$channel->{id}}) {
		2462	$self->{channel}{$channel->{id}} = $channel;
		2463	$self->ext_event (channel_info => %$channel);
		2464	}
		2465
		2466	$channel = $channel->{id};
		2467	}
		2468
		2469	if ($self->can_msg) {
		2470	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra]));
		2471	} else {
		2472	# replace some tags by gcfclient-compatible ones
		2473	for ($msg) {
		2474	1 while
		2475	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2476	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2477	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2478	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2479	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2480	}
		2481
		2482	if ($color >= 0) {
		2483	if (0 && $msg =~ /\[/) {
		2484	$self->send_packet ("drawextinfo $color 4 0 $msg")
		2485	} else {
		2486	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
		2487	$self->send_packet ("drawinfo $color $msg")
		2488	}
		2489	}
		2490	}
		2491	}
		2492
2318	=item $client->ext_event ($type, %msg)	2493	=item $client->ext_event ($type, %msg)
2319		2494
2320	Sends an exti event to the client.	2495	Sends an ext event to the client.
2321		2496
2322	=cut	2497	=cut
2323		2498
2324	sub cf::client::ext_event($$%) {	2499	sub cf::client::ext_event($$%) {
2325	my ($self, $type, %msg) = @_;	2500	my ($self, $type, %msg) = @_;
2326		2501
		2502	return unless $self->extcmd;
		2503
2327	$msg{msgtype} = "event_$type";	2504	$msg{msgtype} = "event_$type";
2328	$self->send_packet ("ext " . cf::to_json \%msg);	2505	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2329	}	2506	}
2330		2507
2331	=item $success = $client->query ($flags, "text", \&cb)	2508	=item $success = $client->query ($flags, "text", \&cb)
2332		2509
2333	Queues a query to the client, calling the given callback with	2510	Queues a query to the client, calling the given callback with
2334	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,	2511	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2335	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.	2512	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2336		2513
2337	Queries can fail, so check the return code. Or don't, as queries will become	2514	Queries can fail, so check the return code. Or don't, as queries will
2338	reliable at some point in the future.	2515	become reliable at some point in the future.
2339		2516
2340	=cut	2517	=cut
2341		2518
2342	sub cf::client::query {	2519	sub cf::client::query {
2343	my ($self, $flags, $text, $cb) = @_;	2520	my ($self, $flags, $text, $cb) = @_;
…		…
2351	utf8::encode $text;	2528	utf8::encode $text;
2352	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];	2529	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2353		2530
2354	$self->send_packet ($self->{query_queue}[0][0])	2531	$self->send_packet ($self->{query_queue}[0][0])
2355	if @{ $self->{query_queue} } == 1;	2532	if @{ $self->{query_queue} } == 1;
		2533
		2534	1
2356	}	2535	}
2357		2536
2358	cf::client->attach (	2537	cf::client->attach (
		2538	on_connect => sub {
		2539	my ($ns) = @_;
		2540
		2541	$ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
		2542	},
2359	on_reply => sub {	2543	on_reply => sub {
2360	my ($ns, $msg) = @_;	2544	my ($ns, $msg) = @_;
2361		2545
2362	# this weird shuffling is so that direct followup queries	2546	# this weird shuffling is so that direct followup queries
2363	# get handled first	2547	# get handled first
…		…
2375	} else {	2559	} else {
2376	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;	2560	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2377	}	2561	}
2378	}	2562	}
2379	},	2563	},
		2564	on_exticmd => sub {
		2565	my ($ns, $buf) = @_;
		2566
		2567	my $msg = eval { $ns->{json_coder}->decode ($buf) };
		2568
		2569	if (ref $msg) {
		2570	if (my $cb = $EXTICMD{$msg->{msgtype}}) {
		2571	if (my %reply = $cb->($ns, $msg)) {
		2572	$reply{msgid} = $msg->{msgid};
		2573	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
		2574	}
		2575	}
		2576	} else {
		2577	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
		2578	}
		2579
		2580	cf::override;
		2581	},
2380	);	2582	);
2381		2583
2382	=item $client->async (\&cb)	2584	=item $client->async (\&cb)
2383		2585
2384	Create a new coroutine, running the specified callback. The coroutine will	2586	Create a new coroutine, running the specified callback. The coroutine will
…		…
2433		2635
2434	=pod	2636	=pod
2435		2637
2436	The following functions and methods are available within a safe environment:	2638	The following functions and methods are available within a safe environment:
2437		2639
2438	cf::object contr pay_amount pay_player map	2640	cf::object
		2641	contr pay_amount pay_player map x y force_find force_add
		2642	insert remove
		2643
2439	cf::object::player player	2644	cf::object::player
2440	cf::player peaceful	2645	player
2441	cf::map trigger	2646
		2647	cf::player
		2648	peaceful
		2649
		2650	cf::map
		2651	trigger
2442		2652
2443	=cut	2653	=cut
2444		2654
2445	for (	2655	for (
2446	["cf::object" => qw(contr pay_amount pay_player map)],	2656	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2657	insert remove)],
2447	["cf::object::player" => qw(player)],	2658	["cf::object::player" => qw(player)],
2448	["cf::player" => qw(peaceful)],	2659	["cf::player" => qw(peaceful)],
2449	["cf::map" => qw(trigger)],	2660	["cf::map" => qw(trigger)],
2450	) {	2661	) {
2451	no strict 'refs';	2662	no strict 'refs';
…		…
2543	{	2754	{
2544	my $faces = $facedata->{faceinfo};	2755	my $faces = $facedata->{faceinfo};
2545		2756
2546	while (my ($face, $info) = each %$faces) {	2757	while (my ($face, $info) = each %$faces) {
2547	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2758	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2548	cf::face::set $idx, $info->{visibility}, $info->{magicmap};	2759	cf::face::set_visibility $idx, $info->{visibility};
		2760	cf::face::set_magicmap $idx, $info->{magicmap};
2549	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2761	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2550	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2762	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2551	Coro::cede;	2763
		2764	cf::cede_to_tick;
2552	}	2765	}
2553		2766
2554	while (my ($face, $info) = each %$faces) {	2767	while (my ($face, $info) = each %$faces) {
2555	next unless $info->{smooth};	2768	next unless $info->{smooth};
2556	my $idx = cf::face::find $face	2769	my $idx = cf::face::find $face
2557	or next;	2770	or next;
2558	if (my $smooth = cf::face::find $info->{smooth}) {	2771	if (my $smooth = cf::face::find $info->{smooth}) {
		2772	cf::face::set_smooth $idx, $smooth;
2559	cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};	2773	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2560	} else {	2774	} else {
2561	warn "smooth face '$info->{smooth}' not found for face '$face'";	2775	warn "smooth face '$info->{smooth}' not found for face '$face'";
2562	}	2776	}
2563	Coro::cede;	2777
		2778	cf::cede_to_tick;
2564	}	2779	}
2565	}	2780	}
2566		2781
2567	{	2782	{
2568	my $anims = $facedata->{animinfo};	2783	my $anims = $facedata->{animinfo};
2569		2784
2570	while (my ($anim, $info) = each %$anims) {	2785	while (my ($anim, $info) = each %$anims) {
2571	cf::anim::set $anim, $info->{frames}, $info->{facings};	2786	cf::anim::set $anim, $info->{frames}, $info->{facings};
2572	Coro::cede;	2787	cf::cede_to_tick;
2573	}	2788	}
2574		2789
2575	cf::anim::invalidate_all; # d'oh	2790	cf::anim::invalidate_all; # d'oh
		2791	}
		2792
		2793	{
		2794	# TODO: for gcfclient pleasure, we should give resources
		2795	# that gcfclient doesn't grok a >10000 face index.
		2796	my $res = $facedata->{resource};
		2797	my $enc = JSON::XS->new->utf8->canonical;
		2798
		2799	while (my ($name, $info) = each %$res) {
		2800	my $meta = $enc->encode ({
		2801	name => $name,
		2802	type => $info->{type},
		2803	copyright => $info->{copyright}, #TODO#
		2804	});
		2805
		2806	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		2807
		2808	if ($name =~ /\.jpg$/) {
		2809	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack
		2810	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack
		2811	} else {
		2812	my $data = pack "(w/a)", $meta, $info->{data};
		2813	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
		2814
		2815	cf::face::set_type $idx, 1;
		2816	cf::face::set_data $idx, 0, $data, $chk;
		2817	}
		2818
		2819	cf::cede_to_tick;
		2820	}
2576	}	2821	}
2577		2822
2578	1	2823	1
2579	}	2824	}
2580		2825
2581	sub reload_regions {	2826	sub reload_regions {
2582	load_resource_file "$MAPDIR/regions"	2827	load_resource_file "$MAPDIR/regions"
2583	or die "unable to load regions file\n";	2828	or die "unable to load regions file\n";
		2829
		2830	for (cf::region::list) {
		2831	$_->{match} = qr/$_->{match}/
		2832	if exists $_->{match};
		2833	}
2584	}	2834	}
2585		2835
2586	sub reload_facedata {	2836	sub reload_facedata {
2587	load_facedata "$DATADIR/facedata"	2837	load_facedata "$DATADIR/facedata"
2588	or die "unable to load facedata\n";	2838	or die "unable to load facedata\n";
2589	}	2839	}
2590		2840
2591	sub reload_archetypes {	2841	sub reload_archetypes {
		2842	load_resource_file "$DATADIR/archetypes"
		2843	or die "unable to load archetypes\n";
		2844	#d# NEED to laod twice to resolve forward references
		2845	# this really needs to be done in an extra post-pass
		2846	# (which needs to be synchronous, so solve it differently)
2592	load_resource_file "$DATADIR/archetypes"	2847	load_resource_file "$DATADIR/archetypes"
2593	or die "unable to load archetypes\n";	2848	or die "unable to load archetypes\n";
2594	}	2849	}
2595		2850
2596	sub reload_treasures {	2851	sub reload_treasures {
…		…
2790	%EXT_CORO = ();	3045	%EXT_CORO = ();
2791		3046
2792	warn "removing commands";	3047	warn "removing commands";
2793	%COMMAND = ();	3048	%COMMAND = ();
2794		3049
2795	warn "removing ext commands";	3050	warn "removing ext/exti commands";
2796	%EXTCMD = ();	3051	%EXTCMD = ();
		3052	%EXTICMD = ();
2797		3053
2798	warn "unloading/nuking all extensions";	3054	warn "unloading/nuking all extensions";
2799	for my $pkg (@EXTS) {	3055	for my $pkg (@EXTS) {
2800	warn "... unloading $pkg";	3056	warn "... unloading $pkg";
2801		3057

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.282 by elmex, Tue Jun 19 18:15:34 2007 UTC vs. Revision 1.312 by root, Sat Jul 21 18:01:26 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.282 by elmex, Tue Jun 19 18:15:34 2007 UTC vs.
Revision 1.312 by root, Sat Jul 21 18:01:26 2007 UTC