[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.328 by root, Wed Aug 8 06:24:30 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
		2555	utf8::encode $msg;
		2556
2533	if (0 && $msg =~ /\[/) {	2557	if (0 && $msg =~ /\[/) {
2534	$self->send_packet ("drawextinfo $color 4 0 $msg")	2558	$self->send_packet ("drawextinfo $color 4 0 $msg")
2535	} else {	2559	} else {
2536	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2560	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2537	$self->send_packet ("drawinfo $color $msg")	2561	$self->send_packet ("drawinfo $color $msg")
2538	}	2562	}
2539	}	2563	}
2540	}	2564	}
2541	}	2565	}
2542		2566
2543	=item $client->ext_event ($type, %msg)	2567	=item $client->ext_msg ($type, @msg)
2544		2568
2545	Sends an ext event to the client.	2569	Sends an ext event to the client.
2546		2570
2547	=cut	2571	=cut
2548		2572
2549	sub cf::client::ext_event($$%) {	2573	sub cf::client::ext_msg($$@) {
2550	my ($self, $type, %msg) = @_;	2574	my ($self, $type, @msg) = @_;
2551		2575
2552	return unless $self->extcmd;	2576	my $extcmd = $self->extcmd;
2553		2577
		2578	if ($extcmd == 2) {
		2579	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2580	} elsif ($extcmd == 1) { # TODO: remove
2554	$msg{msgtype} = "event_$type";	2581	push @msg, msgtype => "event_$type";
2555	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2582	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2583	}
2556	}	2584	}
2557		2585
2558	=item $success = $client->query ($flags, "text", \&cb)	2586	=item $success = $client->query ($flags, "text", \&cb)
2559		2587
2560	Queues a query to the client, calling the given callback with	2588	Queues a query to the client, calling the given callback with
…		…
2615	my ($ns, $buf) = @_;	2643	my ($ns, $buf) = @_;
2616		2644
2617	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2645	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2618		2646
2619	if (ref $msg) {	2647	if (ref $msg) {
		2648	my ($type, $reply, @payload) =
		2649	"ARRAY" eq ref $msg
		2650	? @$msg
		2651	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2652
2620	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2653	if (my $cb = $EXTICMD{$type}) {
2621	if (my %reply = $cb->($ns, $msg)) {	2654	my @reply = $cb->($ns, @payload);
2622	$reply{msgid} = $msg->{msgid};	2655
2623	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));	2656	$ns->ext_reply ($reply, @reply)
2624	}	2657	if $reply;
2625	}	2658	}
2626	} else {	2659	} else {
2627	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2660	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2628	}	2661	}
2629		2662
…		…
2677	our $safe = new Safe "safe";	2710	our $safe = new Safe "safe";
2678	our $safe_hole = new Safe::Hole;	2711	our $safe_hole = new Safe::Hole;
2679		2712
2680	$SIG{FPE} = 'IGNORE';	2713	$SIG{FPE} = 'IGNORE';
2681		2714
2682	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2715	$safe->permit_only (Opcode::opset qw(
		2716	:base_core :base_mem :base_orig :base_math
		2717	grepstart grepwhile mapstart mapwhile
		2718	sort time
		2719	));
2683		2720
2684	# here we export the classes and methods available to script code	2721	# here we export the classes and methods available to script code
2685		2722
2686	=pod	2723	=pod
2687		2724
…		…
2702		2739
2703	=cut	2740	=cut
2704		2741
2705	for (	2742	for (
2706	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2743	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2707	insert remove)],	2744	insert remove inv)],
2708	["cf::object::player" => qw(player)],	2745	["cf::object::player" => qw(player)],
2709	["cf::player" => qw(peaceful)],	2746	["cf::player" => qw(peaceful)],
2710	["cf::map" => qw(trigger)],	2747	["cf::map" => qw(trigger)],
2711	) {	2748	) {
2712	no strict 'refs';	2749	no strict 'refs';
…		…
2844	# TODO: for gcfclient pleasure, we should give resources	2881	# TODO: for gcfclient pleasure, we should give resources
2845	# that gcfclient doesn't grok a >10000 face index.	2882	# that gcfclient doesn't grok a >10000 face index.
2846	my $res = $facedata->{resource};	2883	my $res = $facedata->{resource};
2847	my $enc = JSON::XS->new->utf8->canonical;	2884	my $enc = JSON::XS->new->utf8->canonical;
2848		2885
		2886	my $soundconf = delete $res->{"res/sound.conf"};
		2887
2849	while (my ($name, $info) = each %$res) {	2888	while (my ($name, $info) = each %$res) {
2850	my $meta = $enc->encode ({	2889	my $meta = $enc->encode ({
2851	name => $name,	2890	name => $name,
2852	type => $info->{type},	2891	%{ $info->{meta} \|\| {} },
2853	copyright => $info->{copyright}, #TODO#
2854	});	2892	});
2855		2893
2856	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	2894	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
2857		2895
2858	if ($name =~ /\.jpg$/) {	2896	if ($info->{type} & 1) {
2859	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack	2897	# prepend meta info
2860	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack	2898
2861	} else {
2862	my $data = pack "(w/a)", $meta, $info->{data};	2899	my $data = pack "(w/a)", $meta, $info->{data};
2863	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata	2900	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2864		2901
2865	cf::face::set_type $idx, 1;
2866	cf::face::set_data $idx, 0, $data, $chk;	2902	cf::face::set_data $idx, 0, $data, $chk;
		2903	} else {
		2904	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};
2867	}	2905	}
2868		2906
		2907	cf::face::set_type $idx, $info->{type};
		2908
2869	cf::cede_to_tick;	2909	cf::cede_to_tick;
2870	}	2910	}
		2911
		2912	if ($soundconf) {
		2913	$soundconf = $enc->decode (delete $soundconf->{data});
		2914
		2915	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		2916	my $sound = $soundconf->{compat}[$_]
		2917	or next;
		2918
		2919	my $face = cf::face::find "sound/$sound->[1]";
		2920	cf::sound::set $sound->[0] => $face;
		2921	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		2922	}
		2923
		2924	while (my ($k, $v) = each %{$soundconf->{event}}) {
		2925	my $face = cf::face::find "sound/$v";
		2926	cf::sound::set $k => $face;
		2927	}
		2928	}
2871	}	2929	}
2872		2930
2873	1	2931	1
2874	}	2932	}
		2933
		2934	register_exticmd fx_want => sub {
		2935	my ($ns, $want) = @_;
		2936
		2937	while (my ($k, $v) = each %$want) {
		2938	$ns->fx_want ($k, $v);
		2939	}
		2940	};
2875		2941
2876	sub reload_regions {	2942	sub reload_regions {
2877	load_resource_file "$MAPDIR/regions"	2943	load_resource_file "$MAPDIR/regions"
2878	or die "unable to load regions file\n";	2944	or die "unable to load regions file\n";
2879		2945

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.328 by root, Wed Aug 8 06:24:30 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.328 by root, Wed Aug 8 06:24:30 2007 UTC