[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.329 by root, Fri Aug 10 05:38:16 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
…		…
1358	$self->{deny_save} = 1;	1370	$self->{deny_save} = 1;
1359		1371
1360	$cf::PLAYER{$login} = $self;	1372	$cf::PLAYER{$login} = $self;
1361		1373
1362	$self	1374	$self
		1375	}
		1376
		1377	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1378
		1379	=cut
		1380
		1381	sub send_msg {
		1382	my $ns = shift->ns
		1383	or return;
		1384	$ns->send_msg (@_);
1363	}	1385	}
1364		1386
1365	=item $pl->quit_character	1387	=item $pl->quit_character
1366		1388
1367	Nukes the player without looking back. If logged in, the connection will	1389	Nukes the player without looking back. If logged in, the connection will
…		…
1511	sub hintmode {	1533	sub hintmode {
1512	$_[0]{hintmode} = $_[1] if @_ > 1;	1534	$_[0]{hintmode} = $_[1] if @_ > 1;
1513	$_[0]{hintmode}	1535	$_[0]{hintmode}
1514	}	1536	}
1515		1537
1516	=item $player->ext_reply ($msgid, %msg)	1538	=item $player->ext_reply ($msgid, @msg)
1517		1539
1518	Sends an ext reply to the player.	1540	Sends an ext reply to the player.
1519		1541
1520	=cut	1542	=cut
1521		1543
1522	sub ext_reply($$%) {	1544	sub ext_reply($$@) {
1523	my ($self, $id, %msg) = @_;	1545	my ($self, $id, @msg) = @_;
1524		1546
1525	$msg{msgid} = $id;	1547	if ($self->ns->extcmd == 2) {
		1548	$self->send ("ext " . $self->ns->{json_coder}->encode (["reply-$id", @msg]));
		1549	} elsif ($self->ns->extcmd == 1) {
		1550	#TODO: version 1, remove
		1551	unshift @msg, msgtype => "reply", msgid => $id;
1526	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));	1552	$self->send ("ext " . $self->ns->{json_coder}->encode ({@msg}));
		1553	}
1527	}	1554	}
1528		1555
1529	=item $player->ext_event ($type, %msg)	1556	=item $player->ext_msg ($type, @msg)
1530		1557
1531	Sends an ext event to the client.	1558	Sends an ext event to the client.
1532		1559
1533	=cut	1560	=cut
1534		1561
1535	sub ext_event($$%) {	1562	sub ext_msg($$@) {
1536	my ($self, $type, %msg) = @_;	1563	my ($self, $type, @msg) = @_;
1537		1564
1538	$self->ns->ext_event ($type, %msg);	1565	$self->ns->ext_msg ($type, @msg);
1539	}	1566	}
1540		1567
1541	=head3 cf::region	1568	=head3 cf::region
1542		1569
1543	=over 4	1570	=over 4
…		…
1904	$self->set_darkness_map;	1931	$self->set_darkness_map;
1905	Coro::cede;	1932	Coro::cede;
1906	$self->activate;	1933	$self->activate;
1907	}	1934	}
1908		1935
		1936	$self->{last_save} = $cf::RUNTIME;
		1937	$self->last_access ($cf::RUNTIME);
		1938
1909	$self->in_memory (cf::MAP_IN_MEMORY);	1939	$self->in_memory (cf::MAP_IN_MEMORY);
1910	}	1940	}
1911		1941
1912	$self->post_load;	1942	$self->post_load;
1913	}	1943	}
…		…
2213		2243
2214	} else {	2244	} else {
2215	my $pl = $self->contr;	2245	my $pl = $self->contr;
2216		2246
2217	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2247	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2218	my $diag = $pl->{npc_dialog};	2248	my $dialog = $pl->{npc_dialog};
2219	$diag->{pl}->ext_reply (	2249	$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		2250
2226	} else {	2251	} else {
2227	$msg = $npc->name . " says: $msg" if $npc;	2252	$msg = $npc->name . " says: $msg" if $npc;
2228	$self->message ($msg, $flags);	2253	$self->message ($msg, $flags);
2229	}	2254	}
2230	}	2255	}
		2256	}
		2257
		2258	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2259
		2260	=cut
		2261
		2262	sub cf::object::send_msg {
		2263	my $pl = shift->contr
		2264	or return;
		2265	$pl->send_msg (@_);
2231	}	2266	}
2232		2267
2233	=item $player_object->may ("access")	2268	=item $player_object->may ("access")
2234		2269
2235	Returns wether the given player is authorized to access resource "access"	2270	Returns wether the given player is authorized to access resource "access"
…		…
2500	sub cf::client::send_msg {	2535	sub cf::client::send_msg {
2501	my ($self, $channel, $msg, $color, @extra) = @_;	2536	my ($self, $channel, $msg, $color, @extra) = @_;
2502		2537
2503	$msg = $self->pl->expand_cfpod ($msg);	2538	$msg = $self->pl->expand_cfpod ($msg);
2504		2539
2505	$color &= ~cf::NDI_UNIQUE; # just in case...	2540	$color &= cf::NDI_CLIENT_MASK; # just in case...
2506		2541
2507	if (ref $channel) {	2542	if (ref $channel) {
2508	# send meta info to client, if not yet sent	2543	# send meta info to client, if not yet sent
2509	unless (exists $self->{channel}{$channel->{id}}) {	2544	unless (exists $self->{channel}{$channel->{id}}) {
2510	$self->{channel}{$channel->{id}} = $channel;	2545	$self->{channel}{$channel->{id}} = $channel;
2511	$self->ext_event (channel_info => %$channel);	2546	$self->ext_msg (channel_info => $channel);
2512	}	2547	}
2513		2548
2514	$channel = $channel->{id};	2549	$channel = $channel->{id};
2515	}	2550	}
2516		2551
2517	return unless @extra \|\| length $msg;	2552	return unless @extra \|\| length $msg;
2518		2553
2519	if ($self->can_msg) {	2554	if ($self->can_msg) {
		2555	# default colour, mask it out
		2556	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2557	if $color & cf::NDI_DEF;
		2558
2520	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra]));	2559	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2560	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2521	} else {	2561	} 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) {	2562	if ($color >= 0) {
		2563	# replace some tags by gcfclient-compatible ones
		2564	for ($msg) {
		2565	1 while
		2566	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2567	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2568	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2569	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2570	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2571	}
		2572
		2573	$color &= cf::NDI_COLOR_MASK;
		2574
		2575	utf8::encode $msg;
		2576
2533	if (0 && $msg =~ /\[/) {	2577	if (0 && $msg =~ /\[/) {
2534	$self->send_packet ("drawextinfo $color 4 0 $msg")	2578	$self->send_packet ("drawextinfo $color 4 0 $msg")
2535	} else {	2579	} else {
2536	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2580	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2537	$self->send_packet ("drawinfo $color $msg")	2581	$self->send_packet ("drawinfo $color $msg")
2538	}	2582	}
2539	}	2583	}
2540	}	2584	}
2541	}	2585	}
2542		2586
2543	=item $client->ext_event ($type, %msg)	2587	=item $client->ext_msg ($type, @msg)
2544		2588
2545	Sends an ext event to the client.	2589	Sends an ext event to the client.
2546		2590
2547	=cut	2591	=cut
2548		2592
2549	sub cf::client::ext_event($$%) {	2593	sub cf::client::ext_msg($$@) {
2550	my ($self, $type, %msg) = @_;	2594	my ($self, $type, @msg) = @_;
2551		2595
2552	return unless $self->extcmd;	2596	my $extcmd = $self->extcmd;
2553		2597
		2598	if ($extcmd == 2) {
		2599	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2600	} elsif ($extcmd == 1) { # TODO: remove
2554	$msg{msgtype} = "event_$type";	2601	push @msg, msgtype => "event_$type";
2555	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2602	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2603	}
2556	}	2604	}
2557		2605
2558	=item $success = $client->query ($flags, "text", \&cb)	2606	=item $success = $client->query ($flags, "text", \&cb)
2559		2607
2560	Queues a query to the client, calling the given callback with	2608	Queues a query to the client, calling the given callback with
…		…
2615	my ($ns, $buf) = @_;	2663	my ($ns, $buf) = @_;
2616		2664
2617	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2665	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2618		2666
2619	if (ref $msg) {	2667	if (ref $msg) {
		2668	my ($type, $reply, @payload) =
		2669	"ARRAY" eq ref $msg
		2670	? @$msg
		2671	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2672
2620	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2673	if (my $cb = $EXTICMD{$type}) {
2621	if (my %reply = $cb->($ns, $msg)) {	2674	my @reply = $cb->($ns, @payload);
2622	$reply{msgid} = $msg->{msgid};	2675
2623	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));	2676	$ns->ext_reply ($reply, @reply)
2624	}	2677	if $reply;
2625	}	2678	}
2626	} else {	2679	} else {
2627	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2680	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2628	}	2681	}
2629		2682
…		…
2677	our $safe = new Safe "safe";	2730	our $safe = new Safe "safe";
2678	our $safe_hole = new Safe::Hole;	2731	our $safe_hole = new Safe::Hole;
2679		2732
2680	$SIG{FPE} = 'IGNORE';	2733	$SIG{FPE} = 'IGNORE';
2681		2734
2682	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2735	$safe->permit_only (Opcode::opset qw(
		2736	:base_core :base_mem :base_orig :base_math
		2737	grepstart grepwhile mapstart mapwhile
		2738	sort time
		2739	));
2683		2740
2684	# here we export the classes and methods available to script code	2741	# here we export the classes and methods available to script code
2685		2742
2686	=pod	2743	=pod
2687		2744
…		…
2702		2759
2703	=cut	2760	=cut
2704		2761
2705	for (	2762	for (
2706	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2763	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2707	insert remove)],	2764	insert remove inv)],
2708	["cf::object::player" => qw(player)],	2765	["cf::object::player" => qw(player)],
2709	["cf::player" => qw(peaceful)],	2766	["cf::player" => qw(peaceful)],
2710	["cf::map" => qw(trigger)],	2767	["cf::map" => qw(trigger)],
2711	) {	2768	) {
2712	no strict 'refs';	2769	no strict 'refs';
…		…
2844	# TODO: for gcfclient pleasure, we should give resources	2901	# TODO: for gcfclient pleasure, we should give resources
2845	# that gcfclient doesn't grok a >10000 face index.	2902	# that gcfclient doesn't grok a >10000 face index.
2846	my $res = $facedata->{resource};	2903	my $res = $facedata->{resource};
2847	my $enc = JSON::XS->new->utf8->canonical;	2904	my $enc = JSON::XS->new->utf8->canonical;
2848		2905
		2906	my $soundconf = delete $res->{"res/sound.conf"};
		2907
2849	while (my ($name, $info) = each %$res) {	2908	while (my ($name, $info) = each %$res) {
2850	my $meta = $enc->encode ({	2909	my $meta = $enc->encode ({
2851	name => $name,	2910	name => $name,
2852	type => $info->{type},	2911	%{ $info->{meta} \|\| {} },
2853	copyright => $info->{copyright}, #TODO#
2854	});	2912	});
2855		2913
2856	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	2914	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
2857		2915
2858	if ($name =~ /\.jpg$/) {	2916	if ($info->{type} & 1) {
2859	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack	2917	# prepend meta info
2860	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack	2918
2861	} else {
2862	my $data = pack "(w/a)", $meta, $info->{data};	2919	my $data = pack "(w/a)", $meta, $info->{data};
2863	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata	2920	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2864		2921
2865	cf::face::set_type $idx, 1;
2866	cf::face::set_data $idx, 0, $data, $chk;	2922	cf::face::set_data $idx, 0, $data, $chk;
		2923	} else {
		2924	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};
2867	}	2925	}
2868		2926
		2927	cf::face::set_type $idx, $info->{type};
		2928
2869	cf::cede_to_tick;	2929	cf::cede_to_tick;
2870	}	2930	}
		2931
		2932	if ($soundconf) {
		2933	$soundconf = $enc->decode (delete $soundconf->{data});
		2934
		2935	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		2936	my $sound = $soundconf->{compat}[$_]
		2937	or next;
		2938
		2939	my $face = cf::face::find "sound/$sound->[1]";
		2940	cf::sound::set $sound->[0] => $face;
		2941	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		2942	}
		2943
		2944	while (my ($k, $v) = each %{$soundconf->{event}}) {
		2945	my $face = cf::face::find "sound/$v";
		2946	cf::sound::set $k => $face;
		2947	}
		2948	}
2871	}	2949	}
2872		2950
2873	1	2951	1
2874	}	2952	}
		2953
		2954	register_exticmd fx_want => sub {
		2955	my ($ns, $want) = @_;
		2956
		2957	while (my ($k, $v) = each %$want) {
		2958	$ns->fx_want ($k, $v);
		2959	}
		2960	};
2875		2961
2876	sub reload_regions {	2962	sub reload_regions {
2877	load_resource_file "$MAPDIR/regions"	2963	load_resource_file "$MAPDIR/regions"
2878	or die "unable to load regions file\n";	2964	or die "unable to load regions file\n";
2879		2965

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.329 by root, Fri Aug 10 05:38:16 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.329 by root, Fri Aug 10 05:38:16 2007 UTC