[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.331 by root, Mon Aug 13 13:10:01 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 =~ /\[/) {
		2578	# COMMAND/INFO
2534	$self->send_packet ("drawextinfo $color 4 0 $msg")	2579	$self->send_packet ("drawextinfo $color 10 8 $msg")
2535	} else {	2580	} else {
2536	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2581	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2537	$self->send_packet ("drawinfo $color $msg")	2582	$self->send_packet ("drawinfo $color $msg")
2538	}	2583	}
2539	}	2584	}
2540	}	2585	}
2541	}	2586	}
2542		2587
2543	=item $client->ext_event ($type, %msg)	2588	=item $client->ext_msg ($type, @msg)
2544		2589
2545	Sends an ext event to the client.	2590	Sends an ext event to the client.
2546		2591
2547	=cut	2592	=cut
2548		2593
2549	sub cf::client::ext_event($$%) {	2594	sub cf::client::ext_msg($$@) {
2550	my ($self, $type, %msg) = @_;	2595	my ($self, $type, @msg) = @_;
2551		2596
2552	return unless $self->extcmd;	2597	my $extcmd = $self->extcmd;
2553		2598
		2599	if ($extcmd == 2) {
		2600	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2601	} elsif ($extcmd == 1) { # TODO: remove
2554	$msg{msgtype} = "event_$type";	2602	push @msg, msgtype => "event_$type";
2555	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2603	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2604	}
2556	}	2605	}
2557		2606
2558	=item $success = $client->query ($flags, "text", \&cb)	2607	=item $success = $client->query ($flags, "text", \&cb)
2559		2608
2560	Queues a query to the client, calling the given callback with	2609	Queues a query to the client, calling the given callback with
…		…
2615	my ($ns, $buf) = @_;	2664	my ($ns, $buf) = @_;
2616		2665
2617	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2666	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2618		2667
2619	if (ref $msg) {	2668	if (ref $msg) {
		2669	my ($type, $reply, @payload) =
		2670	"ARRAY" eq ref $msg
		2671	? @$msg
		2672	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2673
2620	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2674	if (my $cb = $EXTICMD{$type}) {
2621	if (my %reply = $cb->($ns, $msg)) {	2675	my @reply = $cb->($ns, @payload);
2622	$reply{msgid} = $msg->{msgid};	2676
2623	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));	2677	$ns->ext_reply ($reply, @reply)
2624	}	2678	if $reply;
2625	}	2679	}
2626	} else {	2680	} else {
2627	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2681	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2628	}	2682	}
2629		2683
…		…
2677	our $safe = new Safe "safe";	2731	our $safe = new Safe "safe";
2678	our $safe_hole = new Safe::Hole;	2732	our $safe_hole = new Safe::Hole;
2679		2733
2680	$SIG{FPE} = 'IGNORE';	2734	$SIG{FPE} = 'IGNORE';
2681		2735
2682	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2736	$safe->permit_only (Opcode::opset qw(
		2737	:base_core :base_mem :base_orig :base_math
		2738	grepstart grepwhile mapstart mapwhile
		2739	sort time
		2740	));
2683		2741
2684	# here we export the classes and methods available to script code	2742	# here we export the classes and methods available to script code
2685		2743
2686	=pod	2744	=pod
2687		2745
2688	The following functions and methods are available within a safe environment:	2746	The following functions and methods are available within a safe environment:
2689		2747
2690	cf::object	2748	cf::object
2691	contr pay_amount pay_player map x y force_find force_add	2749	contr pay_amount pay_player map x y force_find force_add
2692	insert remove	2750	insert remove name archname title slaying race
2693		2751
2694	cf::object::player	2752	cf::object::player
2695	player	2753	player
2696		2754
2697	cf::player	2755	cf::player
…		…
2702		2760
2703	=cut	2761	=cut
2704		2762
2705	for (	2763	for (
2706	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2764	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2707	insert remove)],	2765	insert remove inv name archname title slaying race)],
2708	["cf::object::player" => qw(player)],	2766	["cf::object::player" => qw(player)],
2709	["cf::player" => qw(peaceful)],	2767	["cf::player" => qw(peaceful)],
2710	["cf::map" => qw(trigger)],	2768	["cf::map" => qw(trigger)],
2711	) {	2769	) {
2712	no strict 'refs';	2770	no strict 'refs';
…		…
2844	# TODO: for gcfclient pleasure, we should give resources	2902	# TODO: for gcfclient pleasure, we should give resources
2845	# that gcfclient doesn't grok a >10000 face index.	2903	# that gcfclient doesn't grok a >10000 face index.
2846	my $res = $facedata->{resource};	2904	my $res = $facedata->{resource};
2847	my $enc = JSON::XS->new->utf8->canonical;	2905	my $enc = JSON::XS->new->utf8->canonical;
2848		2906
		2907	my $soundconf = delete $res->{"res/sound.conf"};
		2908
2849	while (my ($name, $info) = each %$res) {	2909	while (my ($name, $info) = each %$res) {
2850	my $meta = $enc->encode ({	2910	my $meta = $enc->encode ({
2851	name => $name,	2911	name => $name,
2852	type => $info->{type},	2912	%{ $info->{meta} \|\| {} },
2853	copyright => $info->{copyright}, #TODO#
2854	});	2913	});
2855		2914
2856	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	2915	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
2857		2916
2858	if ($name =~ /\.jpg$/) {	2917	if ($info->{type} & 1) {
2859	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack	2918	# prepend meta info
2860	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack	2919
2861	} else {
2862	my $data = pack "(w/a)", $meta, $info->{data};	2920	my $data = pack "(w/a)", $meta, $info->{data};
2863	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata	2921	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2864		2922
2865	cf::face::set_type $idx, 1;
2866	cf::face::set_data $idx, 0, $data, $chk;	2923	cf::face::set_data $idx, 0, $data, $chk;
		2924	} else {
		2925	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};
2867	}	2926	}
2868		2927
		2928	cf::face::set_type $idx, $info->{type};
		2929
2869	cf::cede_to_tick;	2930	cf::cede_to_tick;
2870	}	2931	}
		2932
		2933	if ($soundconf) {
		2934	$soundconf = $enc->decode (delete $soundconf->{data});
		2935
		2936	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		2937	my $sound = $soundconf->{compat}[$_]
		2938	or next;
		2939
		2940	my $face = cf::face::find "sound/$sound->[1]";
		2941	cf::sound::set $sound->[0] => $face;
		2942	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		2943	}
		2944
		2945	while (my ($k, $v) = each %{$soundconf->{event}}) {
		2946	my $face = cf::face::find "sound/$v";
		2947	cf::sound::set $k => $face;
		2948	}
		2949	}
2871	}	2950	}
2872		2951
2873	1	2952	1
2874	}	2953	}
		2954
		2955	register_exticmd fx_want => sub {
		2956	my ($ns, $want) = @_;
		2957
		2958	while (my ($k, $v) = each %$want) {
		2959	$ns->fx_want ($k, $v);
		2960	}
		2961	};
2875		2962
2876	sub reload_regions {	2963	sub reload_regions {
2877	load_resource_file "$MAPDIR/regions"	2964	load_resource_file "$MAPDIR/regions"
2878	or die "unable to load regions file\n";	2965	or die "unable to load regions file\n";
2879		2966

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.331 by root, Mon Aug 13 13:10:01 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.331 by root, Mon Aug 13 13:10:01 2007 UTC