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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.283 by root, Sun Jun 24 04:09:29 2007 UTC vs.
Revision 1.296 by root, Wed Jul 4 07:09:06 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 ();
…		…
49	our %COMMAND = ();	50	our %COMMAND = ();
50	our %COMMAND_TIME = ();	51	our %COMMAND_TIME = ();
51		52
52	our @EXTS = (); # list of extension package names	53	our @EXTS = (); # list of extension package names
53	our %EXTCMD = ();	54	our %EXTCMD = ();
		55	our %EXTICMD = ();
54	our %EXT_CORO = (); # coroutines bound to extensions	56	our %EXT_CORO = (); # coroutines bound to extensions
55	our %EXT_MAP = (); # pluggable maps	57	our %EXT_MAP = (); # pluggable maps
56		58
57	our $RELOAD; # number of reloads so far	59	our $RELOAD; # number of reloads so far
58	our @EVENT;	60	our @EVENT;
…		…
236	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;	238	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
237	$d	239	$d
238	} \|\| "[unable to dump $_[0]: '$@']";	240	} \|\| "[unable to dump $_[0]: '$@']";
239	}	241	}
240		242
241	use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
242
243	=item $ref = cf::from_json $json	243	=item $ref = cf::from_json $json
244		244
245	Converts a JSON string into the corresponding perl data structure.	245	Converts a JSON string into the corresponding perl data structure.
246		246
247	=item $json = cf::to_json $ref	247	=item $json = cf::to_json $ref
248		248
249	Converts a perl data structure into its JSON representation.	249	Converts a perl data structure into its JSON representation.
		250
		251	=cut
		252
		253	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
		254
		255	sub to_json ($) { $json_coder->encode ($_[0]) }
		256	sub from_json ($) { $json_coder->decode ($_[0]) }
250		257
251	=item cf::lock_wait $string	258	=item cf::lock_wait $string
252		259
253	Wait until the given lock is available. See cf::lock_acquire.	260	Wait until the given lock is available. See cf::lock_acquire.
254		261
…		…
1029	push @{ $COMMAND{$name} }, [$caller, $cb];	1036	push @{ $COMMAND{$name} }, [$caller, $cb];
1030	}	1037	}
1031		1038
1032	=item cf::register_extcmd $name => \&callback($pl,$packet);	1039	=item cf::register_extcmd $name => \&callback($pl,$packet);
1033		1040
1034	Register a callback fro execution when the client sends an extcmd packet.	1041	Register a callback for execution when the client sends an (synchronous)
		1042	extcmd packet. Ext commands will be processed in the order they are
		1043	received by the server, like other user commands. The first argument is
		1044	the logged-in player. Ext commands can only be processed after a player
		1045	has logged in successfully.
1035		1046
1036	If the callback returns something, it is sent back as if reply was being	1047	If the callback returns something, it is sent back as if reply was being
1037	called.	1048	called.
1038		1049
		1050	=item cf::register_exticmd $name => \&callback($ns,$packet);
		1051
		1052	Register a callback for execution when the client sends an (asynchronous)
		1053	exticmd packet. Exti commands are processed by the server as soon as they
		1054	are received, i.e. out of order w.r.t. other commands. The first argument
		1055	is a client socket. Exti commands can be received anytime, even before
		1056	log-in.
		1057
		1058	If the callback returns something, it is sent back as if reply was being
		1059	called.
		1060
1039	=cut	1061	=cut
1040		1062
1041	sub register_extcmd {	1063	sub register_extcmd {
1042	my ($name, $cb) = @_;	1064	my ($name, $cb) = @_;
1043		1065
1044	$EXTCMD{$name} = $cb;	1066	$EXTCMD{$name} = $cb;
		1067	}
		1068
		1069	sub register_exticmd {
		1070	my ($name, $cb) = @_;
		1071
		1072	$EXTICMD{$name} = $cb;
1045	}	1073	}
1046		1074
1047	cf::player->attach (	1075	cf::player->attach (
1048	on_command => sub {	1076	on_command => sub {
1049	my ($pl, $name, $params) = @_;	1077	my ($pl, $name, $params) = @_;
…		…
1058	cf::override;	1086	cf::override;
1059	},	1087	},
1060	on_extcmd => sub {	1088	on_extcmd => sub {
1061	my ($pl, $buf) = @_;	1089	my ($pl, $buf) = @_;
1062		1090
1063	my $msg = eval { from_json $buf };	1091	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1064		1092
1065	if (ref $msg) {	1093	if (ref $msg) {
1066	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1094	if (my $cb = $EXTCMD{$msg->{msgtype}}) {
1067	if (my %reply = $cb->($pl, $msg)) {	1095	if (my %reply = $cb->($pl, $msg)) {
1068	$pl->ext_reply ($msg->{msgid}, %reply);	1096	$pl->ext_reply ($msg->{msgid}, %reply);
…		…
1372	# replace G<male\|female> tags	1400	# replace G<male\|female> tags
1373	\|\| s{G<([^>\|])\\|([^>])>}{	1401	\|\| s{G<([^>\|])\\|([^>])>}{
1374	$self->gender ? $2 : $1	1402	$self->gender ? $2 : $1
1375	}ge	1403	}ge
1376	# replace H<hint text>	1404	# replace H<hint text>
1377	\|\| s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g;	1405	\|\| s{H<([^\>]*)>}
		1406	{
		1407	("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
		1408	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
		1409	"")
		1410	[$self->{hintmode}]
		1411	}ge;
1378		1412
1379	# create single paragraphs (very hackish)	1413	# create single paragraphs (very hackish)
1380	s/(?<=\S)\n(?=\w)/ /g;	1414	s/(?<=\S)\n(?=\w)/ /g;
1381		1415
		1416	# compress some whitespace
		1417	s/\s+\n/\n/g; # ws line-ends
		1418	s/\n\n+/\n/g; # double lines
		1419	s/^\n+//; # beginning lines
		1420	s/\n+$//; # ending lines
		1421
1382	$_	1422	$_
		1423	}
		1424
		1425	sub hintmode {
		1426	$_[0]{hintmode} = $_[1] if @_ > 1;
		1427	$_[0]{hintmode}
1383	}	1428	}
1384		1429
1385	=item $player->ext_reply ($msgid, %msg)	1430	=item $player->ext_reply ($msgid, %msg)
1386		1431
1387	Sends an ext reply to the player.	1432	Sends an ext reply to the player.
…		…
1390		1435
1391	sub ext_reply($$%) {	1436	sub ext_reply($$%) {
1392	my ($self, $id, %msg) = @_;	1437	my ($self, $id, %msg) = @_;
1393		1438
1394	$msg{msgid} = $id;	1439	$msg{msgid} = $id;
1395		1440	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1396	$self->send ("ext " . cf::to_json \%msg);
1397	}	1441	}
1398		1442
1399	=item $player->ext_event ($type, %msg)	1443	=item $player->ext_event ($type, %msg)
1400		1444
1401	Sends an ext event to the client.	1445	Sends an ext event to the client.
…		…
2313	my $hp = $exit->stats->hp;	2357	my $hp = $exit->stats->hp;
2314	my $sp = $exit->stats->sp;	2358	my $sp = $exit->stats->sp;
2315		2359
2316	$self->enter_link;	2360	$self->enter_link;
2317		2361
		2362	# if exit is damned, update players death & WoR home-position
		2363	$self->contr->savebed ($slaying, $hp, $sp)
		2364	if $exit->flag (FLAG_DAMNED);
		2365
2318	(async {	2366	(async {
2319	$self->deactivate_recursive; # just to be sure	2367	$self->deactivate_recursive; # just to be sure
2320	unless (eval {	2368	unless (eval {
2321	$self->goto ($slaying, $hp, $sp);	2369	$self->goto ($slaying, $hp, $sp);
2322		2370
…		…
2363	sub cf::client::send_msg {	2411	sub cf::client::send_msg {
2364	my ($self, $color, $type, $msg, @extra) = @_;	2412	my ($self, $color, $type, $msg, @extra) = @_;
2365		2413
2366	$msg = $self->pl->expand_cfpod ($msg);	2414	$msg = $self->pl->expand_cfpod ($msg);
2367		2415
		2416	return unless @extra \|\| length $msg;
		2417
2368	if ($self->can_msg) {	2418	if ($self->can_msg) {
2369	$self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]);	2419	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));
2370	} else {	2420	} else {
2371	# replace some tags by gcfclient-compatible ones	2421	# replace some tags by gcfclient-compatible ones
2372	for ($msg) {	2422	for ($msg) {
2373	1 while	2423	1 while
2374	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/	2424	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2375	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/	2425	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2376	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/	2426	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2377	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/	2427	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2378	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${1}[\/color]/;	2428	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2379	}	2429	}
2380		2430
2381	if ($color >= 0) {	2431	if ($color >= 0) {
2382	if ($msg =~ /\[/) {	2432	if (0 && $msg =~ /\[/) {
2383	$self->send_packet ("drawextinfo $color 4 0 $msg")	2433	$self->send_packet ("drawextinfo $color 4 0 $msg")
2384	} else {	2434	} else {
		2435	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2385	$self->send_packet ("drawinfo $color $msg")	2436	$self->send_packet ("drawinfo $color $msg")
2386	}	2437	}
2387	}	2438	}
2388	}	2439	}
2389	}	2440	}
2390		2441
2391	=item $client->ext_event ($type, %msg)	2442	=item $client->ext_event ($type, %msg)
2392		2443
2393	Sends an exti event to the client.	2444	Sends an ext event to the client.
2394		2445
2395	=cut	2446	=cut
2396		2447
2397	sub cf::client::ext_event($$%) {	2448	sub cf::client::ext_event($$%) {
2398	my ($self, $type, %msg) = @_;	2449	my ($self, $type, %msg) = @_;
2399		2450
2400	$msg{msgtype} = "event_$type";	2451	$msg{msgtype} = "event_$type";
2401	$self->send_packet ("ext " . cf::to_json \%msg);	2452	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2402	}	2453	}
2403		2454
2404	=item $success = $client->query ($flags, "text", \&cb)	2455	=item $success = $client->query ($flags, "text", \&cb)
2405		2456
2406	Queues a query to the client, calling the given callback with	2457	Queues a query to the client, calling the given callback with
2407	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,	2458	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2408	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.	2459	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2409		2460
2410	Queries can fail, so check the return code. Or don't, as queries will become	2461	Queries can fail, so check the return code. Or don't, as queries will
2411	reliable at some point in the future.	2462	become reliable at some point in the future.
2412		2463
2413	=cut	2464	=cut
2414		2465
2415	sub cf::client::query {	2466	sub cf::client::query {
2416	my ($self, $flags, $text, $cb) = @_;	2467	my ($self, $flags, $text, $cb) = @_;
…		…
2424	utf8::encode $text;	2475	utf8::encode $text;
2425	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];	2476	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2426		2477
2427	$self->send_packet ($self->{query_queue}[0][0])	2478	$self->send_packet ($self->{query_queue}[0][0])
2428	if @{ $self->{query_queue} } == 1;	2479	if @{ $self->{query_queue} } == 1;
		2480
		2481	1
2429	}	2482	}
2430		2483
2431	cf::client->attach (	2484	cf::client->attach (
		2485	on_connect => sub {
		2486	my ($ns) = @_;
		2487
		2488	$ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
		2489	},
2432	on_reply => sub {	2490	on_reply => sub {
2433	my ($ns, $msg) = @_;	2491	my ($ns, $msg) = @_;
2434		2492
2435	# this weird shuffling is so that direct followup queries	2493	# this weird shuffling is so that direct followup queries
2436	# get handled first	2494	# get handled first
…		…
2447	$ns->send_packet ($ns->{query_queue}[0][0]);	2505	$ns->send_packet ($ns->{query_queue}[0][0]);
2448	} else {	2506	} else {
2449	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;	2507	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2450	}	2508	}
2451	}	2509	}
		2510	},
		2511	on_exticmd => sub {
		2512	my ($ns, $buf) = @_;
		2513
		2514	my $msg = eval { $ns->{json_coder}->decode ($buf) };
		2515
		2516	if (ref $msg) {
		2517	if (my $cb = $EXTICMD{$msg->{msgtype}}) {
		2518	if (my %reply = $cb->($ns, $msg)) {
		2519	$reply{msgid} = $msg->{msgid};
		2520	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
		2521	}
		2522	}
		2523	} else {
		2524	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
		2525	}
		2526
		2527	cf::override;
2452	},	2528	},
2453	);	2529	);
2454		2530
2455	=item $client->async (\&cb)	2531	=item $client->async (\&cb)
2456		2532
…		…
2660	load_facedata "$DATADIR/facedata"	2736	load_facedata "$DATADIR/facedata"
2661	or die "unable to load facedata\n";	2737	or die "unable to load facedata\n";
2662	}	2738	}
2663		2739
2664	sub reload_archetypes {	2740	sub reload_archetypes {
		2741	load_resource_file "$DATADIR/archetypes"
		2742	or die "unable to load archetypes\n";
		2743	#d# NEED to laod twice to resolve forward references
		2744	# this really needs to be done in an extra post-pass
		2745	# (which needs to be synchronous, so solve it differently)
2665	load_resource_file "$DATADIR/archetypes"	2746	load_resource_file "$DATADIR/archetypes"
2666	or die "unable to load archetypes\n";	2747	or die "unable to load archetypes\n";
2667	}	2748	}
2668		2749
2669	sub reload_treasures {	2750	sub reload_treasures {
…		…
2863	%EXT_CORO = ();	2944	%EXT_CORO = ();
2864		2945
2865	warn "removing commands";	2946	warn "removing commands";
2866	%COMMAND = ();	2947	%COMMAND = ();
2867		2948
2868	warn "removing ext commands";	2949	warn "removing ext/exti commands";
2869	%EXTCMD = ();	2950	%EXTCMD = ();
		2951	%EXTICMD = ();
2870		2952
2871	warn "unloading/nuking all extensions";	2953	warn "unloading/nuking all extensions";
2872	for my $pkg (@EXTS) {	2954	for my $pkg (@EXTS) {
2873	warn "... unloading $pkg";	2955	warn "... unloading $pkg";
2874		2956

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.283 by root, Sun Jun 24 04:09:29 2007 UTC vs. Revision 1.296 by root, Wed Jul 4 07:09:06 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.283 by root, Sun Jun 24 04:09:29 2007 UTC vs.
Revision 1.296 by root, Wed Jul 4 07:09:06 2007 UTC