[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.311 by root, Fri Jul 20 16:11:10 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
…		…
1029	push @{ $COMMAND{$name} }, [$caller, $cb];	1061	push @{ $COMMAND{$name} }, [$caller, $cb];
1030	}	1062	}
1031		1063
1032	=item cf::register_extcmd $name => \&callback($pl,$packet);	1064	=item cf::register_extcmd $name => \&callback($pl,$packet);
1033		1065
1034	Register a callback fro execution when the client sends an extcmd packet.	1066	Register a callback for execution when the client sends an (synchronous)
		1067	extcmd packet. Ext commands will be processed in the order they are
		1068	received by the server, like other user commands. The first argument is
		1069	the logged-in player. Ext commands can only be processed after a player
		1070	has logged in successfully.
1035		1071
1036	If the callback returns something, it is sent back as if reply was being	1072	If the callback returns something, it is sent back as if reply was being
1037	called.	1073	called.
1038		1074
		1075	=item cf::register_exticmd $name => \&callback($ns,$packet);
		1076
		1077	Register a callback for execution when the client sends an (asynchronous)
		1078	exticmd packet. Exti commands are processed by the server as soon as they
		1079	are received, i.e. out of order w.r.t. other commands. The first argument
		1080	is a client socket. Exti commands can be received anytime, even before
		1081	log-in.
		1082
		1083	If the callback returns something, it is sent back as if reply was being
		1084	called.
		1085
1039	=cut	1086	=cut
1040		1087
1041	sub register_extcmd {	1088	sub register_extcmd {
1042	my ($name, $cb) = @_;	1089	my ($name, $cb) = @_;
1043		1090
1044	$EXTCMD{$name} = $cb;	1091	$EXTCMD{$name} = $cb;
		1092	}
		1093
		1094	sub register_exticmd {
		1095	my ($name, $cb) = @_;
		1096
		1097	$EXTICMD{$name} = $cb;
1045	}	1098	}
1046		1099
1047	cf::player->attach (	1100	cf::player->attach (
1048	on_command => sub {	1101	on_command => sub {
1049	my ($pl, $name, $params) = @_;	1102	my ($pl, $name, $params) = @_;
…		…
1058	cf::override;	1111	cf::override;
1059	},	1112	},
1060	on_extcmd => sub {	1113	on_extcmd => sub {
1061	my ($pl, $buf) = @_;	1114	my ($pl, $buf) = @_;
1062		1115
1063	my $msg = eval { from_json $buf };	1116	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1064		1117
1065	if (ref $msg) {	1118	if (ref $msg) {
1066	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1119	if (my $cb = $EXTCMD{$msg->{msgtype}}) {
1067	if (my %reply = $cb->($pl, $msg)) {	1120	if (my %reply = $cb->($pl, $msg)) {
1068	$pl->ext_reply ($msg->{msgid}, %reply);	1121	$pl->ext_reply ($msg->{msgid}, %reply);
…		…
1347	}	1400	}
1348		1401
1349	\@paths	1402	\@paths
1350	}	1403	}
1351		1404
		1405	=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
		1406
		1407	Expand crossfire pod fragments into protocol xml.
		1408
		1409	=cut
		1410
		1411	sub expand_cfpod {
		1412	((my $self), (local $_)) = @_;
		1413
		1414	# escape & and <
		1415	s/&/&/g;
		1416	s/(?<![BIUGH])</</g;
		1417
		1418	# this is buggy, it needs to properly take care of nested <'s
		1419
		1420	1 while
		1421	# replace B<>, I<>, U<> etc.
		1422	s/B<([^\>]*)>/<b>$1<\/b>/
		1423	\|\| s/I<([^\>]*)>/<i>$1<\/i>/
		1424	\|\| s/U<([^\>]*)>/<u>$1<\/u>/
		1425	# replace G<male\|female> tags
		1426	\|\| s{G<([^>\|])\\|([^>])>}{
		1427	$self->gender ? $2 : $1
		1428	}ge
		1429	# replace H<hint text>
		1430	\|\| s{H<([^\>]*)>}
		1431	{
		1432	("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
		1433	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
		1434	"")
		1435	[$self->{hintmode}]
		1436	}ge;
		1437
		1438	# create single paragraphs (very hackish)
		1439	s/(?<=\S)\n(?=\w)/ /g;
		1440
		1441	# compress some whitespace
		1442	s/\s+\n/\n/g; # ws line-ends
		1443	s/\n\n+/\n/g; # double lines
		1444	s/^\n+//; # beginning lines
		1445	s/\n+$//; # ending lines
		1446
		1447	$_
		1448	}
		1449
		1450	sub hintmode {
		1451	$_[0]{hintmode} = $_[1] if @_ > 1;
		1452	$_[0]{hintmode}
		1453	}
		1454
1352	=item $player->ext_reply ($msgid, %msg)	1455	=item $player->ext_reply ($msgid, %msg)
1353		1456
1354	Sends an ext reply to the player.	1457	Sends an ext reply to the player.
1355		1458
1356	=cut	1459	=cut
1357		1460
1358	sub ext_reply($$%) {	1461	sub ext_reply($$%) {
1359	my ($self, $id, %msg) = @_;	1462	my ($self, $id, %msg) = @_;
1360		1463
1361	$msg{msgid} = $id;	1464	$msg{msgid} = $id;
1362		1465	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1363	$self->send ("ext " . cf::to_json \%msg);
1364	}	1466	}
1365		1467
1366	=item $player->ext_event ($type, %msg)	1468	=item $player->ext_event ($type, %msg)
1367		1469
1368	Sends an ext event to the client.	1470	Sends an ext event to the client.
…		…
1393	my ($path) = @_;	1495	my ($path) = @_;
1394		1496
1395	my ($match, $specificity);	1497	my ($match, $specificity);
1396		1498
1397	for my $region (list) {	1499	for my $region (list) {
1398	if ($region->match && $path =~ $region->match) {	1500	if ($region->{match} && $path =~ $region->{match}) {
1399	($match, $specificity) = ($region, $region->specificity)	1501	($match, $specificity) = ($region, $region->specificity)
1400	if $region->specificity > $specificity;	1502	if $region->specificity > $specificity;
1401	}	1503	}
1402	}	1504	}
1403		1505
…		…
1523	$self->init; # pass $1 etc.	1625	$self->init; # pass $1 etc.
1524	return $self;	1626	return $self;
1525	}	1627	}
1526	}	1628	}
1527		1629
1528	Carp::carp "unable to resolve path '$path' (base '$base').";	1630	Carp::cluck "unable to resolve path '$path' (base '$base').";
1529	()	1631	()
1530	}	1632	}
1531		1633
1532	sub init {	1634	sub init {
1533	my ($self) = @_;	1635	my ($self) = @_;
…		…
1811		1913
1812	undef $MAP_PREFETCH{$path};	1914	undef $MAP_PREFETCH{$path};
1813	$MAP_PREFETCHER \|\|= cf::async {	1915	$MAP_PREFETCHER \|\|= cf::async {
1814	while (%MAP_PREFETCH) {	1916	while (%MAP_PREFETCH) {
1815	for my $path (keys %MAP_PREFETCH) {	1917	for my $path (keys %MAP_PREFETCH) {
1816	my $map = find $path	1918	if (my $map = find $path) {
1817	or next;
1818	$map->load;	1919	$map->load;
		1920	}
1819		1921
1820	delete $MAP_PREFETCH{$path};	1922	delete $MAP_PREFETCH{$path};
1821	}	1923	}
1822	}	1924	}
1823	undef $MAP_PREFETCHER;	1925	undef $MAP_PREFETCHER;
…		…
2052	my $pl = $self->contr;	2154	my $pl = $self->contr;
2053		2155
2054	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2156	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2055	my $diag = $pl->{npc_dialog};	2157	my $diag = $pl->{npc_dialog};
2056	$diag->{pl}->ext_reply (	2158	$diag->{pl}->ext_reply (
2057	$diag->{id}, msgtype => "reply", msg => $msg, add_topics => []	2159	$diag->{id},
		2160	msgtype => "reply",
		2161	msg => $diag->{pl}->expand_cfpod ($msg),
		2162	add_topics => []
2058	);	2163	);
2059		2164
2060	} else {	2165	} else {
2061	$msg = $npc->name . " says: $msg" if $npc;	2166	$msg = $npc->name . " says: $msg" if $npc;
2062	$self->message ($msg, $flags);	2167	$self->message ($msg, $flags);
…		…
2157		2262
2158	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2263	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2159	$self->enter_map ($map, $x, $y);	2264	$self->enter_map ($map, $x, $y);
2160	}	2265	}
2161		2266
2162	=item $player_object->goto ($path, $x, $y[, $check->($map)])	2267	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2163		2268
2164	Moves the player to the given map-path and coordinates by first freezing	2269	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	2270	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	2271	that has to return the map if sucecssful, and then unfreezes the player on
2167	the new (success) or old (failed) map position.	2272	the new (success) or old (failed) map position. In either case, $done will
		2273	be called at the end of this process.
2168		2274
2169	=cut	2275	=cut
2170		2276
2171	our $GOTOGEN;	2277	our $GOTOGEN;
2172		2278
2173	sub cf::object::player::goto {	2279	sub cf::object::player::goto {
2174	my ($self, $path, $x, $y, $check) = @_;	2280	my ($self, $path, $x, $y, $check, $done) = @_;
2175		2281
2176	# do generation counting so two concurrent goto's will be executed in-order	2282	# do generation counting so two concurrent goto's will be executed in-order
2177	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2283	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2178		2284
2179	$self->enter_link;	2285	$self->enter_link;
…		…
2199		2305
2200	if ($gen == $self->{_goto_generation}) {	2306	if ($gen == $self->{_goto_generation}) {
2201	delete $self->{_goto_generation};	2307	delete $self->{_goto_generation};
2202	$self->leave_link ($map, $x, $y);	2308	$self->leave_link ($map, $x, $y);
2203	}	2309	}
		2310
		2311	$done->() if $done;
2204	})->prio (1);	2312	})->prio (1);
2205	}	2313	}
2206		2314
2207	=item $player_object->enter_exit ($exit_object)	2315	=item $player_object->enter_exit ($exit_object)
2208		2316
…		…
2277	my $hp = $exit->stats->hp;	2385	my $hp = $exit->stats->hp;
2278	my $sp = $exit->stats->sp;	2386	my $sp = $exit->stats->sp;
2279		2387
2280	$self->enter_link;	2388	$self->enter_link;
2281		2389
		2390	# if exit is damned, update players death & WoR home-position
		2391	$self->contr->savebed ($slaying, $hp, $sp)
		2392	if $exit->flag (FLAG_DAMNED);
		2393
2282	(async {	2394	(async {
2283	$self->deactivate_recursive; # just to be sure	2395	$self->deactivate_recursive; # just to be sure
2284	unless (eval {	2396	unless (eval {
2285	$self->goto ($slaying, $hp, $sp);	2397	$self->goto ($slaying, $hp, $sp);
2286		2398
…		…
2313		2425
2314	utf8::encode $text;	2426	utf8::encode $text;
2315	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2427	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2316	}	2428	}
2317		2429
		2430	=item $client->send_msg ($channel, $msg, $color, [extra...])
		2431
		2432	Send a drawinfo or msg packet to the client, formatting the msg for the
		2433	client if neccessary. C<$type> should be a string identifying the type of
		2434	the message, with C<log> being the default. If C<$color> is negative, suppress
		2435	the message unless the client supports the msg packet.
		2436
		2437	=cut
		2438
		2439	sub cf::client::send_msg {
		2440	my ($self, $channel, $msg, $color, @extra) = @_;
		2441
		2442	$msg = $self->pl->expand_cfpod ($msg);
		2443
		2444	return unless @extra \|\| length $msg;
		2445
		2446	$color &= ~cf::NDI_UNIQUE; # just in case...
		2447
		2448	if (ref $channel) {
		2449	# send meta info to client, if not yet sent
		2450	unless (exists $self->{channel}{$channel->{id}}) {
		2451	$self->{channel}{$channel->{id}} = $channel;
		2452	$self->ext_event (channel_info => %$channel);
		2453	}
		2454
		2455	$channel = $channel->{id};
		2456	}
		2457
		2458	if ($self->can_msg) {
		2459	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra]));
		2460	} else {
		2461	# replace some tags by gcfclient-compatible ones
		2462	for ($msg) {
		2463	1 while
		2464	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2465	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2466	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2467	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2468	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2469	}
		2470
		2471	if ($color >= 0) {
		2472	if (0 && $msg =~ /\[/) {
		2473	$self->send_packet ("drawextinfo $color 4 0 $msg")
		2474	} else {
		2475	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
		2476	$self->send_packet ("drawinfo $color $msg")
		2477	}
		2478	}
		2479	}
		2480	}
		2481
2318	=item $client->ext_event ($type, %msg)	2482	=item $client->ext_event ($type, %msg)
2319		2483
2320	Sends an exti event to the client.	2484	Sends an ext event to the client.
2321		2485
2322	=cut	2486	=cut
2323		2487
2324	sub cf::client::ext_event($$%) {	2488	sub cf::client::ext_event($$%) {
2325	my ($self, $type, %msg) = @_;	2489	my ($self, $type, %msg) = @_;
2326		2490
		2491	return unless $self->extcmd;
		2492
2327	$msg{msgtype} = "event_$type";	2493	$msg{msgtype} = "event_$type";
2328	$self->send_packet ("ext " . cf::to_json \%msg);	2494	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2329	}	2495	}
2330		2496
2331	=item $success = $client->query ($flags, "text", \&cb)	2497	=item $success = $client->query ($flags, "text", \&cb)
2332		2498
2333	Queues a query to the client, calling the given callback with	2499	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>,	2500	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>.	2501	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2336		2502
2337	Queries can fail, so check the return code. Or don't, as queries will become	2503	Queries can fail, so check the return code. Or don't, as queries will
2338	reliable at some point in the future.	2504	become reliable at some point in the future.
2339		2505
2340	=cut	2506	=cut
2341		2507
2342	sub cf::client::query {	2508	sub cf::client::query {
2343	my ($self, $flags, $text, $cb) = @_;	2509	my ($self, $flags, $text, $cb) = @_;
…		…
2351	utf8::encode $text;	2517	utf8::encode $text;
2352	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];	2518	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2353		2519
2354	$self->send_packet ($self->{query_queue}[0][0])	2520	$self->send_packet ($self->{query_queue}[0][0])
2355	if @{ $self->{query_queue} } == 1;	2521	if @{ $self->{query_queue} } == 1;
		2522
		2523	1
2356	}	2524	}
2357		2525
2358	cf::client->attach (	2526	cf::client->attach (
		2527	on_connect => sub {
		2528	my ($ns) = @_;
		2529
		2530	$ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
		2531	},
2359	on_reply => sub {	2532	on_reply => sub {
2360	my ($ns, $msg) = @_;	2533	my ($ns, $msg) = @_;
2361		2534
2362	# this weird shuffling is so that direct followup queries	2535	# this weird shuffling is so that direct followup queries
2363	# get handled first	2536	# get handled first
…		…
2375	} else {	2548	} else {
2376	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;	2549	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2377	}	2550	}
2378	}	2551	}
2379	},	2552	},
		2553	on_exticmd => sub {
		2554	my ($ns, $buf) = @_;
		2555
		2556	my $msg = eval { $ns->{json_coder}->decode ($buf) };
		2557
		2558	if (ref $msg) {
		2559	if (my $cb = $EXTICMD{$msg->{msgtype}}) {
		2560	if (my %reply = $cb->($ns, $msg)) {
		2561	$reply{msgid} = $msg->{msgid};
		2562	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
		2563	}
		2564	}
		2565	} else {
		2566	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
		2567	}
		2568
		2569	cf::override;
		2570	},
2380	);	2571	);
2381		2572
2382	=item $client->async (\&cb)	2573	=item $client->async (\&cb)
2383		2574
2384	Create a new coroutine, running the specified callback. The coroutine will	2575	Create a new coroutine, running the specified callback. The coroutine will
…		…
2433		2624
2434	=pod	2625	=pod
2435		2626
2436	The following functions and methods are available within a safe environment:	2627	The following functions and methods are available within a safe environment:
2437		2628
2438	cf::object contr pay_amount pay_player map	2629	cf::object
		2630	contr pay_amount pay_player map x y force_find force_add
		2631	insert remove
		2632
2439	cf::object::player player	2633	cf::object::player
2440	cf::player peaceful	2634	player
2441	cf::map trigger	2635
		2636	cf::player
		2637	peaceful
		2638
		2639	cf::map
		2640	trigger
2442		2641
2443	=cut	2642	=cut
2444		2643
2445	for (	2644	for (
2446	["cf::object" => qw(contr pay_amount pay_player map)],	2645	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2646	insert remove)],
2447	["cf::object::player" => qw(player)],	2647	["cf::object::player" => qw(player)],
2448	["cf::player" => qw(peaceful)],	2648	["cf::player" => qw(peaceful)],
2449	["cf::map" => qw(trigger)],	2649	["cf::map" => qw(trigger)],
2450	) {	2650	) {
2451	no strict 'refs';	2651	no strict 'refs';
…		…
2543	{	2743	{
2544	my $faces = $facedata->{faceinfo};	2744	my $faces = $facedata->{faceinfo};
2545		2745
2546	while (my ($face, $info) = each %$faces) {	2746	while (my ($face, $info) = each %$faces) {
2547	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2747	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2548	cf::face::set $idx, $info->{visibility}, $info->{magicmap};	2748	cf::face::set_visibility $idx, $info->{visibility};
		2749	cf::face::set_magicmap $idx, $info->{magicmap};
2549	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2750	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2550	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2751	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2551	Coro::cede;	2752
		2753	cf::cede_to_tick;
2552	}	2754	}
2553		2755
2554	while (my ($face, $info) = each %$faces) {	2756	while (my ($face, $info) = each %$faces) {
2555	next unless $info->{smooth};	2757	next unless $info->{smooth};
2556	my $idx = cf::face::find $face	2758	my $idx = cf::face::find $face
2557	or next;	2759	or next;
2558	if (my $smooth = cf::face::find $info->{smooth}) {	2760	if (my $smooth = cf::face::find $info->{smooth}) {
		2761	cf::face::set_smooth $idx, $smooth;
2559	cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};	2762	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2560	} else {	2763	} else {
2561	warn "smooth face '$info->{smooth}' not found for face '$face'";	2764	warn "smooth face '$info->{smooth}' not found for face '$face'";
2562	}	2765	}
2563	Coro::cede;	2766
		2767	cf::cede_to_tick;
2564	}	2768	}
2565	}	2769	}
2566		2770
2567	{	2771	{
2568	my $anims = $facedata->{animinfo};	2772	my $anims = $facedata->{animinfo};
2569		2773
2570	while (my ($anim, $info) = each %$anims) {	2774	while (my ($anim, $info) = each %$anims) {
2571	cf::anim::set $anim, $info->{frames}, $info->{facings};	2775	cf::anim::set $anim, $info->{frames}, $info->{facings};
2572	Coro::cede;	2776	cf::cede_to_tick;
2573	}	2777	}
2574		2778
2575	cf::anim::invalidate_all; # d'oh	2779	cf::anim::invalidate_all; # d'oh
		2780	}
		2781
		2782	{
		2783	# TODO: for gcfclient pleasure, we should give resources
		2784	# that gcfclient doesn't grok a >10000 face index.
		2785	my $res = $facedata->{resource};
		2786	my $enc = JSON::XS->new->utf8->canonical;
		2787
		2788	while (my ($name, $info) = each %$res) {
		2789	my $meta = $enc->encode ({
		2790	name => $name,
		2791	type => $info->{type},
		2792	copyright => $info->{copyright}, #TODO#
		2793	});
		2794
		2795	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		2796
		2797	if ($name =~ /\.jpg$/) {
		2798	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack
		2799	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack
		2800	} else {
		2801	my $data = pack "(w/a)", $meta, $info->{data};
		2802	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
		2803
		2804	cf::face::set_type $idx, 1;
		2805	cf::face::set_data $idx, 0, $data, $chk;
		2806	}
		2807
		2808	cf::cede_to_tick;
		2809	}
2576	}	2810	}
2577		2811
2578	1	2812	1
2579	}	2813	}
2580		2814
2581	sub reload_regions {	2815	sub reload_regions {
2582	load_resource_file "$MAPDIR/regions"	2816	load_resource_file "$MAPDIR/regions"
2583	or die "unable to load regions file\n";	2817	or die "unable to load regions file\n";
		2818
		2819	for (cf::region::list) {
		2820	$_->{match} = qr/$_->{match}/
		2821	if exists $_->{match};
		2822	}
2584	}	2823	}
2585		2824
2586	sub reload_facedata {	2825	sub reload_facedata {
2587	load_facedata "$DATADIR/facedata"	2826	load_facedata "$DATADIR/facedata"
2588	or die "unable to load facedata\n";	2827	or die "unable to load facedata\n";
2589	}	2828	}
2590		2829
2591	sub reload_archetypes {	2830	sub reload_archetypes {
		2831	load_resource_file "$DATADIR/archetypes"
		2832	or die "unable to load archetypes\n";
		2833	#d# NEED to laod twice to resolve forward references
		2834	# this really needs to be done in an extra post-pass
		2835	# (which needs to be synchronous, so solve it differently)
2592	load_resource_file "$DATADIR/archetypes"	2836	load_resource_file "$DATADIR/archetypes"
2593	or die "unable to load archetypes\n";	2837	or die "unable to load archetypes\n";
2594	}	2838	}
2595		2839
2596	sub reload_treasures {	2840	sub reload_treasures {
…		…
2790	%EXT_CORO = ();	3034	%EXT_CORO = ();
2791		3035
2792	warn "removing commands";	3036	warn "removing commands";
2793	%COMMAND = ();	3037	%COMMAND = ();
2794		3038
2795	warn "removing ext commands";	3039	warn "removing ext/exti commands";
2796	%EXTCMD = ();	3040	%EXTCMD = ();
		3041	%EXTICMD = ();
2797		3042
2798	warn "unloading/nuking all extensions";	3043	warn "unloading/nuking all extensions";
2799	for my $pkg (@EXTS) {	3044	for my $pkg (@EXTS) {
2800	warn "... unloading $pkg";	3045	warn "... unloading $pkg";
2801		3046

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.311 by root, Fri Jul 20 16:11:10 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.311 by root, Fri Jul 20 16:11:10 2007 UTC