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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.316 by root, Mon Jul 23 21:02:50 2007 UTC vs.
Revision 1.334 by root, Mon Aug 20 22:09:04 2007 UTC

…		…
10	use Event;	10	use Event;
11	use Opcode;	11	use Opcode;
12	use Safe;	12	use Safe;
13	use Safe::Hole;	13	use Safe::Hole;
14		14
15	use Coro 3.61 ();	15	use Coro 3.64 ();
16	use Coro::State;	16	use Coro::State;
17	use Coro::Handle;	17	use Coro::Handle;
18	use Coro::Event;	18	use Coro::Event;
19	use Coro::Timer;	19	use Coro::Timer;
20	use Coro::Signal;	20	use Coro::Signal;
21	use Coro::Semaphore;	21	use Coro::Semaphore;
22	use Coro::AIO;	22	use Coro::AIO;
23	use Coro::Storable;	23	use Coro::Storable;
		24	use Coro::Util ();
24		25
25	use JSON::XS 1.4 ();	26	use JSON::XS 1.4 ();
26	use BDB ();	27	use BDB ();
27	use Data::Dumper;	28	use Data::Dumper;
28	use Digest::MD5;	29	use Digest::MD5;
…		…
472	Coro::Storable. May, of course, block. Note that the executed sub may	473	Coro::Storable. May, of course, block. Note that the executed sub may
473	never block itself or use any form of Event handling.	474	never block itself or use any form of Event handling.
474		475
475	=cut	476	=cut
476		477
477	sub _store_scalar {
478	open my $fh, ">", \my $buf
479	or die "fork_call: cannot open fh-to-buf in child : $!";
480	Storable::store_fd $_[0], $fh;
481	close $fh;
482
483	$buf
484	}
485
486	sub fork_call(&@) {	478	sub fork_call(&@) {
487	my ($cb, @args) = @_;	479	my ($cb, @args) = @_;
488		480
489	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC	481	# we seemingly have to make a local copy of the whole thing,
490	# or die "socketpair: $!";	482	# otherwise perl prematurely frees the stuff :/
491	pipe my $fh1, my $fh2	483	# TODO: investigate and fix (liekly this will be rather laborious)
492	or die "pipe: $!";
493		484
494	if (my $pid = fork) {	485	my @res = Coro::Util::fork_eval {
495	close $fh2;
496
497	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
498	warn "pst<$res>" unless $res =~ /^pst/;
499	$res = Coro::Storable::thaw $res;
500
501	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
502
503	Carp::confess $$res unless "ARRAY" eq ref $res;
504
505	return wantarray ? @$res : $res->[-1];
506	} else {
507	reset_signals;	486	reset_signals;
508	local $SIG{__WARN__};	487	&$cb
509	local $SIG{__DIE__};	488	}, @args;
510	# just in case, this hack effectively disables event
511	# in the child. cleaner and slower would be canceling all watchers,
512	# but this works for the time being.
513	local $Coro::idle;
514	$Coro::current->prio (Coro::PRIO_MAX);
515		489
516	eval {	490	wantarray ? @res : $res[-1]
517	close $fh1;
518
519	my @res = eval { $cb->(@args) };
520
521	syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
522	close $fh2;
523	};
524
525	warn $@ if $@;
526	_exit 0;
527	}
528	}	491	}
529		492
530	=item $value = cf::db_get $family => $key	493	=item $value = cf::db_get $family => $key
531		494
532	Returns a single value from the environment database.	495	Returns a single value from the environment database.
…		…
1370	$self->{deny_save} = 1;	1333	$self->{deny_save} = 1;
1371		1334
1372	$cf::PLAYER{$login} = $self;	1335	$cf::PLAYER{$login} = $self;
1373		1336
1374	$self	1337	$self
		1338	}
		1339
		1340	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1341
		1342	=cut
		1343
		1344	sub send_msg {
		1345	my $ns = shift->ns
		1346	or return;
		1347	$ns->send_msg (@_);
1375	}	1348	}
1376		1349
1377	=item $pl->quit_character	1350	=item $pl->quit_character
1378		1351
1379	Nukes the player without looking back. If logged in, the connection will	1352	Nukes the player without looking back. If logged in, the connection will
…		…
1921	$self->set_darkness_map;	1894	$self->set_darkness_map;
1922	Coro::cede;	1895	Coro::cede;
1923	$self->activate;	1896	$self->activate;
1924	}	1897	}
1925		1898
		1899	$self->{last_save} = $cf::RUNTIME;
		1900	$self->last_access ($cf::RUNTIME);
		1901
1926	$self->in_memory (cf::MAP_IN_MEMORY);	1902	$self->in_memory (cf::MAP_IN_MEMORY);
1927	}	1903	}
1928		1904
1929	$self->post_load;	1905	$self->post_load;
1930	}	1906	}
…		…
1940		1916
1941	$self	1917	$self
1942	}	1918	}
1943		1919
1944	# find and load all maps in the 3x3 area around a map	1920	# find and load all maps in the 3x3 area around a map
1945	sub load_diag {	1921	sub load_neighbours {
1946	my ($map) = @_;	1922	my ($map) = @_;
1947		1923
1948	my @diag; # diagonal neighbours	1924	my @neigh; # diagonal neighbours
1949		1925
1950	for (0 .. 3) {	1926	for (0 .. 3) {
1951	my $neigh = $map->tile_path ($_)	1927	my $neigh = $map->tile_path ($_)
1952	or next;	1928	or next;
1953	$neigh = find $neigh, $map	1929	$neigh = find $neigh, $map
1954	or next;	1930	or next;
1955	$neigh->load;	1931	$neigh->load;
1956		1932
		1933	push @neigh,
1957	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],	1934	[$neigh->tile_path (($_ + 3) % 4), $neigh],
1958	[$neigh->tile_path (($_ + 1) % 4), $neigh];	1935	[$neigh->tile_path (($_ + 1) % 4), $neigh];
1959	}	1936	}
1960		1937
1961	for (@diag) {	1938	for (grep defined $_->[0], @neigh) {
		1939	my ($path, $origin) = @$_;
1962	my $neigh = find @$_	1940	my $neigh = find $path, $origin
1963	or next;	1941	or next;
1964	$neigh->load;	1942	$neigh->load;
1965	}	1943	}
1966	}	1944	}
1967		1945
…		…
2240	$self->message ($msg, $flags);	2218	$self->message ($msg, $flags);
2241	}	2219	}
2242	}	2220	}
2243	}	2221	}
2244		2222
		2223	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2224
		2225	=cut
		2226
		2227	sub cf::object::send_msg {
		2228	my $pl = shift->contr
		2229	or return;
		2230	$pl->send_msg (@_);
		2231	}
		2232
2245	=item $player_object->may ("access")	2233	=item $player_object->may ("access")
2246		2234
2247	Returns wether the given player is authorized to access resource "access"	2235	Returns wether the given player is authorized to access resource "access"
2248	(e.g. "command_wizcast").	2236	(e.g. "command_wizcast").
2249		2237
…		…
2326	# use -1 or undef as default coordinates, not 0, 0	2314	# use -1 or undef as default coordinates, not 0, 0
2327	($x, $y) = ($map->enter_x, $map->enter_y)	2315	($x, $y) = ($map->enter_x, $map->enter_y)
2328	if $x <=0 && $y <= 0;	2316	if $x <=0 && $y <= 0;
2329		2317
2330	$map->load;	2318	$map->load;
2331	$map->load_diag;	2319	$map->load_neighbours;
2332		2320
2333	return unless $self->contr->active;	2321	return unless $self->contr->active;
2334	$self->activate_recursive;	2322	$self->activate_recursive;
2335		2323
2336	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2324	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
…		…
2512	sub cf::client::send_msg {	2500	sub cf::client::send_msg {
2513	my ($self, $channel, $msg, $color, @extra) = @_;	2501	my ($self, $channel, $msg, $color, @extra) = @_;
2514		2502
2515	$msg = $self->pl->expand_cfpod ($msg);	2503	$msg = $self->pl->expand_cfpod ($msg);
2516		2504
2517	$color &= ~cf::NDI_UNIQUE; # just in case...	2505	$color &= cf::NDI_CLIENT_MASK; # just in case...
2518		2506
2519	if (ref $channel) {	2507	if (ref $channel) {
2520	# send meta info to client, if not yet sent	2508	# send meta info to client, if not yet sent
2521	unless (exists $self->{channel}{$channel->{id}}) {	2509	unless (exists $self->{channel}{$channel->{id}}) {
2522	$self->{channel}{$channel->{id}} = $channel;	2510	$self->{channel}{$channel->{id}} = $channel;
2523	$self->ext_msg (channel_info => %$channel);	2511	$self->ext_msg (channel_info => $channel);
2524	}	2512	}
2525		2513
2526	$channel = $channel->{id};	2514	$channel = $channel->{id};
2527	}	2515	}
2528		2516
2529	return unless @extra \|\| length $msg;	2517	return unless @extra \|\| length $msg;
2530		2518
2531	if ($self->can_msg) {	2519	if ($self->can_msg) {
		2520	# default colour, mask it out
		2521	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2522	if $color & cf::NDI_DEF;
		2523
2532	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra]));	2524	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2525	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2533	} else {	2526	} else {
2534	# replace some tags by gcfclient-compatible ones
2535	for ($msg) {
2536	1 while
2537	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2538	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2539	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2540	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2541	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2542	}
2543
2544	if ($color >= 0) {	2527	if ($color >= 0) {
		2528	# replace some tags by gcfclient-compatible ones
		2529	for ($msg) {
		2530	1 while
		2531	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2532	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2533	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2534	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2535	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2536	}
		2537
		2538	$color &= cf::NDI_COLOR_MASK;
		2539
		2540	utf8::encode $msg;
		2541
2545	if (0 && $msg =~ /\[/) {	2542	if (0 && $msg =~ /\[/) {
		2543	# COMMAND/INFO
2546	$self->send_packet ("drawextinfo $color 4 0 $msg")	2544	$self->send_packet ("drawextinfo $color 10 8 $msg")
2547	} else {	2545	} else {
2548	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2546	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2549	$self->send_packet ("drawinfo $color $msg")	2547	$self->send_packet ("drawinfo $color $msg")
2550	}	2548	}
2551	}	2549	}
…		…
2698	our $safe = new Safe "safe";	2696	our $safe = new Safe "safe";
2699	our $safe_hole = new Safe::Hole;	2697	our $safe_hole = new Safe::Hole;
2700		2698
2701	$SIG{FPE} = 'IGNORE';	2699	$SIG{FPE} = 'IGNORE';
2702		2700
2703	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2701	$safe->permit_only (Opcode::opset qw(
		2702	:base_core :base_mem :base_orig :base_math
		2703	grepstart grepwhile mapstart mapwhile
		2704	sort time
		2705	));
2704		2706
2705	# here we export the classes and methods available to script code	2707	# here we export the classes and methods available to script code
2706		2708
2707	=pod	2709	=pod
2708		2710
2709	The following functions and methods are available within a safe environment:	2711	The following functions and methods are available within a safe environment:
2710		2712
2711	cf::object	2713	cf::object
2712	contr pay_amount pay_player map x y force_find force_add	2714	contr pay_amount pay_player map x y force_find force_add
2713	insert remove	2715	insert remove name archname title slaying race
2714		2716
2715	cf::object::player	2717	cf::object::player
2716	player	2718	player
2717		2719
2718	cf::player	2720	cf::player
…		…
2723		2725
2724	=cut	2726	=cut
2725		2727
2726	for (	2728	for (
2727	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2729	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2728	insert remove)],	2730	insert remove inv name archname title slaying race)],
2729	["cf::object::player" => qw(player)],	2731	["cf::object::player" => qw(player)],
2730	["cf::player" => qw(peaceful)],	2732	["cf::player" => qw(peaceful)],
2731	["cf::map" => qw(trigger)],	2733	["cf::map" => qw(trigger)],
2732	) {	2734	) {
2733	no strict 'refs';	2735	no strict 'refs';
…		…
2809	# the server's init and main functions	2811	# the server's init and main functions
2810		2812
2811	sub load_facedata($) {	2813	sub load_facedata($) {
2812	my ($path) = @_;	2814	my ($path) = @_;
2813		2815
		2816	my $enc = JSON::XS->new->utf8->canonical;
		2817
2814	warn "loading facedata from $path\n";	2818	warn "loading facedata from $path\n";
2815		2819
2816	my $facedata;	2820	my $facedata;
2817	0 < aio_load $path, $facedata	2821	0 < aio_load $path, $facedata
2818	or die "$path: $!";	2822	or die "$path: $!";
2819		2823
2820	$facedata = Coro::Storable::thaw $facedata;	2824	$facedata = Coro::Storable::thaw $facedata;
2821		2825
2822	$facedata->{version} == 2	2826	$facedata->{version} == 2
2823	or cf::cleanup "$path: version mismatch, cannot proceed.";	2827	or cf::cleanup "$path: version mismatch, cannot proceed.";
		2828
		2829	# patch in the exptable
		2830	cf::cede_to_tick;
		2831	$facedata->{resource}{"res/exp_table"} = {
		2832	type => FT_RSRC,
		2833	data => $enc->encode ([map cf::level_to_min_exp $_, 0 .. cf::settings->max_level]),
		2834	};
		2835	cf::cede_to_tick;
2824		2836
2825	{	2837	{
2826	my $faces = $facedata->{faceinfo};	2838	my $faces = $facedata->{faceinfo};
2827		2839
2828	while (my ($face, $info) = each %$faces) {	2840	while (my ($face, $info) = each %$faces) {
2829	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2841	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2830	cf::face::set_visibility $idx, $info->{visibility};	2842	cf::face::set_visibility $idx, $info->{visibility};
2831	cf::face::set_magicmap $idx, $info->{magicmap};	2843	cf::face::set_magicmap $idx, $info->{magicmap};
2832	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2844	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2833	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2845	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2834		2846
2835	cf::cede_to_tick;	2847	cf::cede_to_tick;
2836	}	2848	}
2837		2849
2838	while (my ($face, $info) = each %$faces) {	2850	while (my ($face, $info) = each %$faces) {
…		…
2863		2875
2864	{	2876	{
2865	# TODO: for gcfclient pleasure, we should give resources	2877	# TODO: for gcfclient pleasure, we should give resources
2866	# that gcfclient doesn't grok a >10000 face index.	2878	# that gcfclient doesn't grok a >10000 face index.
2867	my $res = $facedata->{resource};	2879	my $res = $facedata->{resource};
2868	my $enc = JSON::XS->new->utf8->canonical;	2880
		2881	my $soundconf = delete $res->{"res/sound.conf"};
2869		2882
2870	while (my ($name, $info) = each %$res) {	2883	while (my ($name, $info) = each %$res) {
2871	my $meta = $enc->encode ({
2872	name => $name,
2873	type => $info->{type},
2874	copyright => $info->{copyright}, #TODO#
2875	});
2876
2877	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	2884	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		2885	my $data;
2878		2886
2879	if ($name =~ /\.jpg$/) {	2887	if ($info->{type} & 1) {
2880	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack	2888	# prepend meta info
2881	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack	2889
2882	} else {	2890	my $meta = $enc->encode ({
		2891	name => $name,
		2892	%{ $info->{meta} \|\| {} },
		2893	});
		2894
2883	my $data = pack "(w/a)", $meta, $info->{data};	2895	$data = pack "(w/a)", $meta, $info->{data};
2884	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2885
2886	cf::face::set_type $idx, 1;
2887	cf::face::set_data $idx, 0, $data, $chk;
2888	}	2896	}
2889		2897
		2898	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
		2899	cf::face::set_type $idx, $info->{type};
		2900
2890	cf::cede_to_tick;	2901	cf::cede_to_tick;
2891	}	2902	}
		2903
		2904	if ($soundconf) {
		2905	$soundconf = $enc->decode (delete $soundconf->{data});
		2906
		2907	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		2908	my $sound = $soundconf->{compat}[$_]
		2909	or next;
		2910
		2911	my $face = cf::face::find "sound/$sound->[1]";
		2912	cf::sound::set $sound->[0] => $face;
		2913	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		2914	}
		2915
		2916	while (my ($k, $v) = each %{$soundconf->{event}}) {
		2917	my $face = cf::face::find "sound/$v";
		2918	cf::sound::set $k => $face;
		2919	}
		2920	}
2892	}	2921	}
2893		2922
2894	1	2923	1
2895	}	2924	}
		2925
		2926	register_exticmd fx_want => sub {
		2927	my ($ns, $want) = @_;
		2928
		2929	while (my ($k, $v) = each %$want) {
		2930	$ns->fx_want ($k, $v);
		2931	}
		2932	};
2896		2933
2897	sub reload_regions {	2934	sub reload_regions {
2898	load_resource_file "$MAPDIR/regions"	2935	load_resource_file "$MAPDIR/regions"
2899	or die "unable to load regions file\n";	2936	or die "unable to load regions file\n";
2900		2937

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.316 by root, Mon Jul 23 21:02:50 2007 UTC vs. Revision 1.334 by root, Mon Aug 20 22:09:04 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.316 by root, Mon Jul 23 21:02:50 2007 UTC vs.
Revision 1.334 by root, Mon Aug 20 22:09:04 2007 UTC