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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.314 by root, Mon Jul 23 16:53:15 2007 UTC vs.
Revision 1.326 by root, Tue Jul 31 17:33:15 2007 UTC

…		…
322	};	322	};
323	$TICK_WATCHER->stop;	323	$TICK_WATCHER->stop;
324	$guard	324	$guard
325	}	325	}
326		326
327	=item cf::get_slot $time[, $priority]	327	=item cf::get_slot $time[, $priority[, $name]]
328		328
329	Allocate $time seconds of blocking CPU time at priority C<$priority>:	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	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.	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.
332		335
333	Useful for short background jobs.	336	Useful for short background jobs.
334		337
335	=cut	338	=cut
336		339
…		…
363	Coro::schedule;	366	Coro::schedule;
364	}	367	}
365	}	368	}
366	};	369	};
367		370
368	sub get_slot($;$) {	371	sub get_slot($;$$) {
369	my ($time, $pri) = @_;	372	my ($time, $pri, $name) = @_;
370		373
		374	$time = $TICK * .6 if $time > $TICK * .6;
		375	my $sig = new Coro::Signal;
		376
371	push @SLOT_QUEUE, [$time, $pri, my $sig = new Coro::Signal];	377	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
372	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;	378	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
373	$SLOT_QUEUE->ready;	379	$SLOT_QUEUE->ready;
374	$sig->wait;	380	$sig->wait;
375	}	381	}
376		382
…		…
1175	my ($pl, $buf) = @_;	1181	my ($pl, $buf) = @_;
1176		1182
1177	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1183	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1178		1184
1179	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
1180	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1191	if (my $cb = $EXTCMD{$type}) {
1181	if (my %reply = $cb->($pl, $msg)) {	1192	my @reply = $cb->($pl, @payload);
		1193
1182	$pl->ext_reply ($msg->{msgid}, %reply);	1194	$pl->ext_reply ($reply, @reply)
1183	}	1195	if $reply;
1184	}	1196	}
1185	} else {	1197	} else {
1186	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1198	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1187	}	1199	}
1188		1200
…		…
1511	sub hintmode {	1523	sub hintmode {
1512	$_[0]{hintmode} = $_[1] if @_ > 1;	1524	$_[0]{hintmode} = $_[1] if @_ > 1;
1513	$_[0]{hintmode}	1525	$_[0]{hintmode}
1514	}	1526	}
1515		1527
1516	=item $player->ext_reply ($msgid, %msg)	1528	=item $player->ext_reply ($msgid, @msg)
1517		1529
1518	Sends an ext reply to the player.	1530	Sends an ext reply to the player.
1519		1531
1520	=cut	1532	=cut
1521		1533
1522	sub ext_reply($$%) {	1534	sub ext_reply($$@) {
1523	my ($self, $id, %msg) = @_;	1535	my ($self, $id, @msg) = @_;
1524		1536
1525	$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;
1526	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));	1542	$self->send ("ext " . $self->ns->{json_coder}->encode ({@msg}));
		1543	}
1527	}	1544	}
1528		1545
1529	=item $player->ext_event ($type, %msg)	1546	=item $player->ext_msg ($type, @msg)
1530		1547
1531	Sends an ext event to the client.	1548	Sends an ext event to the client.
1532		1549
1533	=cut	1550	=cut
1534		1551
1535	sub ext_event($$%) {	1552	sub ext_msg($$@) {
1536	my ($self, $type, %msg) = @_;	1553	my ($self, $type, @msg) = @_;
1537		1554
1538	$self->ns->ext_event ($type, %msg);	1555	$self->ns->ext_msg ($type, @msg);
1539	}	1556	}
1540		1557
1541	=head3 cf::region	1558	=head3 cf::region
1542		1559
1543	=over 4	1560	=over 4
…		…
1904	$self->set_darkness_map;	1921	$self->set_darkness_map;
1905	Coro::cede;	1922	Coro::cede;
1906	$self->activate;	1923	$self->activate;
1907	}	1924	}
1908		1925
		1926	$self->{last_save} = $cf::RUNTIME;
		1927	$self->last_access ($cf::RUNTIME);
		1928
1909	$self->in_memory (cf::MAP_IN_MEMORY);	1929	$self->in_memory (cf::MAP_IN_MEMORY);
1910	}	1930	}
1911		1931
1912	$self->post_load;	1932	$self->post_load;
1913	}	1933	}
…		…
2213		2233
2214	} else {	2234	} else {
2215	my $pl = $self->contr;	2235	my $pl = $self->contr;
2216		2236
2217	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2237	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2218	my $diag = $pl->{npc_dialog};	2238	my $dialog = $pl->{npc_dialog};
2219	$diag->{pl}->ext_reply (	2239	$dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2220	$diag->{id},
2221	msgtype => "reply",
2222	msg => $diag->{pl}->expand_cfpod ($msg),
2223	add_topics => []
2224	);
2225		2240
2226	} else {	2241	} else {
2227	$msg = $npc->name . " says: $msg" if $npc;	2242	$msg = $npc->name . " says: $msg" if $npc;
2228	$self->message ($msg, $flags);	2243	$self->message ($msg, $flags);
2229	}	2244	}
…		…
2500	sub cf::client::send_msg {	2515	sub cf::client::send_msg {
2501	my ($self, $channel, $msg, $color, @extra) = @_;	2516	my ($self, $channel, $msg, $color, @extra) = @_;
2502		2517
2503	$msg = $self->pl->expand_cfpod ($msg);	2518	$msg = $self->pl->expand_cfpod ($msg);
2504		2519
2505	$color &= ~cf::NDI_UNIQUE; # just in case...	2520	$color &= cf::NDI_CLIENT_MASK; # just in case...
2506		2521
2507	if (ref $channel) {	2522	if (ref $channel) {
2508	# send meta info to client, if not yet sent	2523	# send meta info to client, if not yet sent
2509	unless (exists $self->{channel}{$channel->{id}}) {	2524	unless (exists $self->{channel}{$channel->{id}}) {
2510	$self->{channel}{$channel->{id}} = $channel;	2525	$self->{channel}{$channel->{id}} = $channel;
2511	$self->ext_event (channel_info => %$channel);	2526	$self->ext_msg (channel_info => $channel);
2512	}	2527	}
2513		2528
2514	$channel = $channel->{id};	2529	$channel = $channel->{id};
2515	}	2530	}
2516		2531
2517	return unless @extra \|\| length $msg;	2532	return unless @extra \|\| length $msg;
2518		2533
2519	if ($self->can_msg) {	2534	if ($self->can_msg) {
		2535	# default colour, mask it out
		2536	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2537	if $color & cf::NDI_DEF;
		2538
2520	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra]));	2539	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2540	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2521	} else {	2541	} else {
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	if ($color >= 0) {	2542	if ($color >= 0) {
		2543	# replace some tags by gcfclient-compatible ones
		2544	for ($msg) {
		2545	1 while
		2546	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2547	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2548	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2549	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2550	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2551	}
		2552
		2553	$color &= cf::NDI_COLOR_MASK;
		2554
2533	if (0 && $msg =~ /\[/) {	2555	if (0 && $msg =~ /\[/) {
2534	$self->send_packet ("drawextinfo $color 4 0 $msg")	2556	$self->send_packet ("drawextinfo $color 4 0 $msg")
2535	} else {	2557	} else {
2536	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2558	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2537	$self->send_packet ("drawinfo $color $msg")	2559	$self->send_packet ("drawinfo $color $msg")
2538	}	2560	}
2539	}	2561	}
2540	}	2562	}
2541	}	2563	}
2542		2564
2543	=item $client->ext_event ($type, %msg)	2565	=item $client->ext_msg ($type, @msg)
2544		2566
2545	Sends an ext event to the client.	2567	Sends an ext event to the client.
2546		2568
2547	=cut	2569	=cut
2548		2570
2549	sub cf::client::ext_event($$%) {	2571	sub cf::client::ext_msg($$@) {
2550	my ($self, $type, %msg) = @_;	2572	my ($self, $type, @msg) = @_;
2551		2573
2552	return unless $self->extcmd;	2574	my $extcmd = $self->extcmd;
2553		2575
		2576	if ($extcmd == 2) {
		2577	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2578	} elsif ($extcmd == 1) { # TODO: remove
2554	$msg{msgtype} = "event_$type";	2579	push @msg, msgtype => "event_$type";
2555	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2580	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2581	}
2556	}	2582	}
2557		2583
2558	=item $success = $client->query ($flags, "text", \&cb)	2584	=item $success = $client->query ($flags, "text", \&cb)
2559		2585
2560	Queues a query to the client, calling the given callback with	2586	Queues a query to the client, calling the given callback with
…		…
2615	my ($ns, $buf) = @_;	2641	my ($ns, $buf) = @_;
2616		2642
2617	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2643	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2618		2644
2619	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
2620	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2651	if (my $cb = $EXTICMD{$type}) {
2621	if (my %reply = $cb->($ns, $msg)) {	2652	my @reply = $cb->($ns, @payload);
2622	$reply{msgid} = $msg->{msgid};	2653
2623	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));	2654	$ns->ext_reply ($reply, @reply)
2624	}	2655	if $reply;
2625	}	2656	}
2626	} else {	2657	} else {
2627	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";
2628	}	2659	}
2629		2660
…		…
2844	# TODO: for gcfclient pleasure, we should give resources	2875	# TODO: for gcfclient pleasure, we should give resources
2845	# that gcfclient doesn't grok a >10000 face index.	2876	# that gcfclient doesn't grok a >10000 face index.
2846	my $res = $facedata->{resource};	2877	my $res = $facedata->{resource};
2847	my $enc = JSON::XS->new->utf8->canonical;	2878	my $enc = JSON::XS->new->utf8->canonical;
2848		2879
		2880	my $soundconf = delete $res->{"res/sound.conf"};
		2881
2849	while (my ($name, $info) = each %$res) {	2882	while (my ($name, $info) = each %$res) {
2850	my $meta = $enc->encode ({	2883	my $meta = $enc->encode ({
2851	name => $name,	2884	name => $name,
2852	type => $info->{type},	2885	%{ $info->{meta} \|\| {} },
2853	copyright => $info->{copyright}, #TODO#
2854	});	2886	});
2855		2887
2856	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	2888	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
2857		2889
2858	if ($name =~ /\.jpg$/) {	2890	if ($info->{type} & 1) {
2859	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack	2891	# prepend meta info
2860	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack	2892
2861	} else {
2862	my $data = pack "(w/a)", $meta, $info->{data};	2893	my $data = pack "(w/a)", $meta, $info->{data};
2863	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata	2894	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2864		2895
2865	cf::face::set_type $idx, 1;
2866	cf::face::set_data $idx, 0, $data, $chk;	2896	cf::face::set_data $idx, 0, $data, $chk;
		2897	} else {
		2898	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};
2867	}	2899	}
2868		2900
		2901	cf::face::set_type $idx, $info->{type};
		2902
2869	cf::cede_to_tick;	2903	cf::cede_to_tick;
2870	}	2904	}
		2905
		2906	if ($soundconf) {
		2907	$soundconf = $enc->decode (delete $soundconf->{data});
		2908
		2909	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		2910	my $sound = $soundconf->{compat}[$_]
		2911	or next;
		2912
		2913	my $face = cf::face::find "sound/$sound->[1]";
		2914	cf::sound::set $sound->[0] => $face;
		2915	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		2916	}
		2917
		2918	while (my ($k, $v) = each %{$soundconf->{event}}) {
		2919	my $face = cf::face::find "sound/$v";
		2920	cf::sound::set $k => $face;
		2921	}
		2922	}
2871	}	2923	}
2872		2924
2873	1	2925	1
2874	}	2926	}
		2927
		2928	register_exticmd fx_want => sub {
		2929	my ($ns, $want) = @_;
		2930
		2931	while (my ($k, $v) = each %$want) {
		2932	$ns->fx_want ($k, $v);
		2933	}
		2934	};
2875		2935
2876	sub reload_regions {	2936	sub reload_regions {
2877	load_resource_file "$MAPDIR/regions"	2937	load_resource_file "$MAPDIR/regions"
2878	or die "unable to load regions file\n";	2938	or die "unable to load regions file\n";
2879		2939

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.314 by root, Mon Jul 23 16:53:15 2007 UTC vs. Revision 1.326 by root, Tue Jul 31 17:33:15 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.314 by root, Mon Jul 23 16:53:15 2007 UTC vs.
Revision 1.326 by root, Tue Jul 31 17:33:15 2007 UTC