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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC vs.
Revision 1.323 by root, Sat Jul 28 12:02:58 2007 UTC

…		…
166	=item cf::wait_for_tick, cf::wait_for_tick_begin	166	=item cf::wait_for_tick, cf::wait_for_tick_begin
167		167
168	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
169	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
170	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.
171		177
172	=back	178	=back
173		179
174	=cut	180	=cut
175		181
…		…
316	};	322	};
317	$TICK_WATCHER->stop;	323	$TICK_WATCHER->stop;
318	$guard	324	$guard
319	}	325	}
320		326
		327	=item cf::get_slot $time[, $priority[, $name]]
		328
		329	Allocate $time seconds of blocking CPU time at priority C<$priority>:
		330	This call blocks and returns only when you have at least C<$time> seconds
		331	of cpu time till the next tick. The slot is only valid till the next cede.
		332
		333	The optional C<$name> can be used to identify the job to run. It might be
		334	used for statistical purposes and should identify the same time-class.
		335
		336	Useful for short background jobs.
		337
		338	=cut
		339
		340	our @SLOT_QUEUE;
		341	our $SLOT_QUEUE;
		342
		343	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
		344	$SLOT_QUEUE = Coro::async {
		345	my $signal = new Coro::Signal;
		346
		347	while () {
		348	next_job:
		349	my $avail = cf::till_tick;
		350	if ($avail > 0.01) {
		351	for (0 .. $#SLOT_QUEUE) {
		352	if ($SLOT_QUEUE[$_][0] < $avail) {
		353	my $job = splice @SLOT_QUEUE, $_, 1, ();
		354	$job->[2]->send;
		355	Coro::cede;
		356	goto next_job;
		357	}
		358	}
		359	}
		360
		361	if (@SLOT_QUEUE) {
		362	# we do not use wait_For_tick() as it returns immediately when tick is inactive
		363	push @cf::WAIT_FOR_TICK, $signal;
		364	$signal->wait;
		365	} else {
		366	Coro::schedule;
		367	}
		368	}
		369	};
		370
		371	sub get_slot($;$$) {
		372	my ($time, $pri, $name) = @_;
		373
		374	$time = $TICK * .6 if $time > $TICK * .6;
		375	my $sig = new Coro::Signal;
		376
		377	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
		378	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
		379	$SLOT_QUEUE->ready;
		380	$sig->wait;
		381	}
		382
321	=item cf::async { BLOCK }	383	=item cf::async { BLOCK }
322		384
323	Currently the same as Coro::async_pool, meaning you cannot use	385	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	386	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.	387	thing you are allowed to do is call C<prio> on it.
…		…
866	";	928	";
867	die if $@;	929	die if $@;
868	}	930	}
869		931
870	our $override;	932	our $override;
871	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	933	our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
872		934
873	sub override {	935	sub override {
874	$override = 1;	936	$override = 1;
875	@invoke_results = ();	937	@INVOKE_RESULTS = (@_);
876	}	938	}
877		939
878	sub do_invoke {	940	sub do_invoke {
879	my $event = shift;	941	my $event = shift;
880	my $callbacks = shift;	942	my $callbacks = shift;
881		943
882	@invoke_results = ();	944	@INVOKE_RESULTS = ();
883		945
884	local $override;	946	local $override;
885		947
886	for (@$callbacks) {	948	for (@$callbacks) {
887	eval { &{$_->[1]} };	949	eval { &{$_->[1]} };
…		…
904		966
905	Generate an object-specific event with the given arguments.	967	Generate an object-specific event with the given arguments.
906		968
907	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be	969	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	970	removed in future versions), and there is no public API to access override
909	results (if you must, access C<@cf::invoke_results> directly).	971	results (if you must, access C<@cf::INVOKE_RESULTS> directly).
910		972
911	=back	973	=back
912		974
913	=cut	975	=cut
914		976
915	#############################################################################	977	#############################################################################
916	# object support	978	# object support
		979	#
		980
		981	sub _can_merge {
		982	my ($ob1, $ob2) = @_;
		983
		984	local $Storable::canonical = 1;
		985	my $fob1 = Storable::freeze $ob1;
		986	my $fob2 = Storable::freeze $ob2;
		987
		988	$fob1 eq $fob2
		989	}
917		990
918	sub reattach {	991	sub reattach {
919	# basically do the same as instantiate, without calling instantiate	992	# basically do the same as instantiate, without calling instantiate
920	my ($obj) = @_;	993	my ($obj) = @_;
921		994
…		…
1108	my ($pl, $buf) = @_;	1181	my ($pl, $buf) = @_;
1109		1182
1110	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1183	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1111		1184
1112	if (ref $msg) {	1185	if (ref $msg) {
		1186	my ($type, $reply, @payload) =
		1187	"ARRAY" eq ref $msg
		1188	? @$msg
		1189	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		1190
1113	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1191	if (my $cb = $EXTCMD{$type}) {
1114	if (my %reply = $cb->($pl, $msg)) {	1192	my @reply = $cb->($pl, @payload);
		1193
1115	$pl->ext_reply ($msg->{msgid}, %reply);	1194	$pl->ext_reply ($reply, @reply)
1116	}	1195	if $reply;
1117	}	1196	}
1118	} else {	1197	} else {
1119	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1198	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1120	}	1199	}
1121		1200
…		…
1444	sub hintmode {	1523	sub hintmode {
1445	$_[0]{hintmode} = $_[1] if @_ > 1;	1524	$_[0]{hintmode} = $_[1] if @_ > 1;
1446	$_[0]{hintmode}	1525	$_[0]{hintmode}
1447	}	1526	}
1448		1527
1449	=item $player->ext_reply ($msgid, %msg)	1528	=item $player->ext_reply ($msgid, @msg)
1450		1529
1451	Sends an ext reply to the player.	1530	Sends an ext reply to the player.
1452		1531
1453	=cut	1532	=cut
1454		1533
1455	sub ext_reply($$%) {	1534	sub ext_reply($$@) {
1456	my ($self, $id, %msg) = @_;	1535	my ($self, $id, @msg) = @_;
1457		1536
1458	$msg{msgid} = $id;	1537	if ($self->ns->extcmd == 2) {
		1538	$self->send ("ext " . $self->ns->{json_coder}->encode (["reply-$id", @msg]));
		1539	} elsif ($self->ns->extcmd == 1) {
		1540	#TODO: version 1, remove
		1541	unshift @msg, msgtype => "reply", msgid => $id;
1459	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));	1542	$self->send ("ext " . $self->ns->{json_coder}->encode ({@msg}));
		1543	}
1460	}	1544	}
1461		1545
1462	=item $player->ext_event ($type, %msg)	1546	=item $player->ext_msg ($type, @msg)
1463		1547
1464	Sends an ext event to the client.	1548	Sends an ext event to the client.
1465		1549
1466	=cut	1550	=cut
1467		1551
1468	sub ext_event($$%) {	1552	sub ext_msg($$@) {
1469	my ($self, $type, %msg) = @_;	1553	my ($self, $type, @msg) = @_;
1470		1554
1471	$self->ns->ext_event ($type, %msg);	1555	$self->ns->ext_msg ($type, @msg);
1472	}	1556	}
1473		1557
1474	=head3 cf::region	1558	=head3 cf::region
1475		1559
1476	=over 4	1560	=over 4
…		…
2146		2230
2147	} else {	2231	} else {
2148	my $pl = $self->contr;	2232	my $pl = $self->contr;
2149		2233
2150	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2234	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2151	my $diag = $pl->{npc_dialog};	2235	my $dialog = $pl->{npc_dialog};
2152	$diag->{pl}->ext_reply (	2236	$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		2237
2159	} else {	2238	} else {
2160	$msg = $npc->name . " says: $msg" if $npc;	2239	$msg = $npc->name . " says: $msg" if $npc;
2161	$self->message ($msg, $flags);	2240	$self->message ($msg, $flags);
2162	}	2241	}
…		…
2419		2498
2420	utf8::encode $text;	2499	utf8::encode $text;
2421	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2500	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2422	}	2501	}
2423		2502
2424	=item $client->send_msg ($color, $type, $msg, [extra...])	2503	=item $client->send_msg ($channel, $msg, $color, [extra...])
2425		2504
2426	Send a drawinfo or msg packet to the client, formatting the msg for the	2505	Send a drawinfo or msg packet to the client, formatting the msg for the
2427	client if neccessary. C<$type> should be a string identifying the type of	2506	client if neccessary. C<$type> should be a string identifying the type of
2428	the message, with C<log> being the default. If C<$color> is negative, suppress	2507	the message, with C<log> being the default. If C<$color> is negative, suppress
2429	the message unless the client supports the msg packet.	2508	the message unless the client supports the msg packet.
2430		2509
2431	=cut	2510	=cut
2432		2511
2433	sub cf::client::send_msg {	2512	sub cf::client::send_msg {
2434	my ($self, $color, $type, $msg, @extra) = @_;	2513	my ($self, $channel, $msg, $color, @extra) = @_;
2435		2514
2436	$msg = $self->pl->expand_cfpod ($msg);	2515	$msg = $self->pl->expand_cfpod ($msg);
2437		2516
		2517	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2518
		2519	if (ref $channel) {
		2520	# send meta info to client, if not yet sent
		2521	unless (exists $self->{channel}{$channel->{id}}) {
		2522	$self->{channel}{$channel->{id}} = $channel;
		2523	$self->ext_msg (channel_info => $channel);
		2524	}
		2525
		2526	$channel = $channel->{id};
		2527	}
		2528
2438	return unless @extra \|\| length $msg;	2529	return unless @extra \|\| length $msg;
2439		2530
2440	if ($self->can_msg) {	2531	if ($self->can_msg) {
		2532	# default colour, mask it out
		2533	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2534	if $color & cf::NDI_DEF;
		2535
2441	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));	2536	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2537	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2442	} else {	2538	} else {
2443	# replace some tags by gcfclient-compatible ones
2444	for ($msg) {
2445	1 while
2446	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2447	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2448	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2449	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2450	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2451	}
2452
2453	if ($color >= 0) {	2539	if ($color >= 0) {
		2540	# replace some tags by gcfclient-compatible ones
		2541	for ($msg) {
		2542	1 while
		2543	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2544	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2545	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2546	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2547	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2548	}
		2549
		2550	$color &= cf::NDI_COLOR_MASK;
		2551
2454	if (0 && $msg =~ /\[/) {	2552	if (0 && $msg =~ /\[/) {
2455	$self->send_packet ("drawextinfo $color 4 0 $msg")	2553	$self->send_packet ("drawextinfo $color 4 0 $msg")
2456	} else {	2554	} else {
2457	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2555	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2458	$self->send_packet ("drawinfo $color $msg")	2556	$self->send_packet ("drawinfo $color $msg")
2459	}	2557	}
2460	}	2558	}
2461	}	2559	}
2462	}	2560	}
2463		2561
2464	=item $client->ext_event ($type, %msg)	2562	=item $client->ext_msg ($type, @msg)
2465		2563
2466	Sends an ext event to the client.	2564	Sends an ext event to the client.
2467		2565
2468	=cut	2566	=cut
2469		2567
2470	sub cf::client::ext_event($$%) {	2568	sub cf::client::ext_msg($$@) {
2471	my ($self, $type, %msg) = @_;	2569	my ($self, $type, @msg) = @_;
2472		2570
2473	return unless $self->extcmd;	2571	my $extcmd = $self->extcmd;
2474		2572
		2573	if ($extcmd == 2) {
		2574	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2575	} elsif ($extcmd == 1) { # TODO: remove
2475	$msg{msgtype} = "event_$type";	2576	push @msg, msgtype => "event_$type";
2476	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2577	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2578	}
2477	}	2579	}
2478		2580
2479	=item $success = $client->query ($flags, "text", \&cb)	2581	=item $success = $client->query ($flags, "text", \&cb)
2480		2582
2481	Queues a query to the client, calling the given callback with	2583	Queues a query to the client, calling the given callback with
…		…
2536	my ($ns, $buf) = @_;	2638	my ($ns, $buf) = @_;
2537		2639
2538	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2640	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2539		2641
2540	if (ref $msg) {	2642	if (ref $msg) {
		2643	my ($type, $reply, @payload) =
		2644	"ARRAY" eq ref $msg
		2645	? @$msg
		2646	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2647
2541	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2648	if (my $cb = $EXTICMD{$type}) {
2542	if (my %reply = $cb->($ns, $msg)) {	2649	my @reply = $cb->($ns, @payload);
2543	$reply{msgid} = $msg->{msgid};	2650
2544	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));	2651	$ns->ext_reply ($reply, @reply)
2545	}	2652	if $reply;
2546	}	2653	}
2547	} else {	2654	} else {
2548	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2655	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2549	}	2656	}
2550		2657
…		…
2765	# TODO: for gcfclient pleasure, we should give resources	2872	# TODO: for gcfclient pleasure, we should give resources
2766	# that gcfclient doesn't grok a >10000 face index.	2873	# that gcfclient doesn't grok a >10000 face index.
2767	my $res = $facedata->{resource};	2874	my $res = $facedata->{resource};
2768	my $enc = JSON::XS->new->utf8->canonical;	2875	my $enc = JSON::XS->new->utf8->canonical;
2769		2876
		2877	my $soundconf = delete $res->{"res/sound.conf"};
		2878
2770	while (my ($name, $info) = each %$res) {	2879	while (my ($name, $info) = each %$res) {
2771	my $meta = $enc->encode ({	2880	my $meta = $enc->encode ({
2772	name => $name,	2881	name => $name,
2773	type => $info->{type},	2882	%{ $info->{meta} \|\| {} },
2774	copyright => $info->{copyright}, #TODO#
2775	});	2883	});
2776		2884
2777	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	2885	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
2778		2886
2779	if ($name =~ /\.jpg$/) {	2887	if ($info->{type} & 1) {
2780	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack	2888	# prepend meta info
2781	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack	2889
2782	} else {
2783	my $data = pack "(w/a)", $meta, $info->{data};	2890	my $data = pack "(w/a)", $meta, $info->{data};
2784	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata	2891	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2785		2892
2786	cf::face::set_type $idx, 1;
2787	cf::face::set_data $idx, 0, $data, $chk;	2893	cf::face::set_data $idx, 0, $data, $chk;
		2894	} else {
		2895	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};
2788	}	2896	}
2789		2897
		2898	cf::face::set_type $idx, $info->{type};
		2899
2790	cf::cede_to_tick;	2900	cf::cede_to_tick;
2791	}	2901	}
		2902
		2903	if ($soundconf) {
		2904	$soundconf = $enc->decode (delete $soundconf->{data});
		2905
		2906	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		2907	my $sound = $soundconf->{compat}[$_]
		2908	or next;
		2909
		2910	my $face = cf::face::find "sound/$sound->[1]";
		2911
		2912	cf::sound::set $sound->[0] => $face;
		2913	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		2914	}
		2915
		2916	#TODO
		2917	}
2792	}	2918	}
2793		2919
2794	1	2920	1
2795	}	2921	}
		2922
		2923	register_exticmd fx_want => sub {
		2924	my ($ns, $want) = @_;
		2925
		2926	while (my ($k, $v) = each %$want) {
		2927	$ns->fx_want ($k, $v);
		2928	}
		2929	};
2796		2930
2797	sub reload_regions {	2931	sub reload_regions {
2798	load_resource_file "$MAPDIR/regions"	2932	load_resource_file "$MAPDIR/regions"
2799	or die "unable to load regions file\n";	2933	or die "unable to load regions file\n";
2800		2934

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC vs. Revision 1.323 by root, Sat Jul 28 12:02:58 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC vs.
Revision 1.323 by root, Sat Jul 28 12:02:58 2007 UTC