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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.295 by root, Wed Jul 4 05:08:15 2007 UTC vs.
Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC

…		…
29	use Fcntl;	29	use Fcntl;
30	use YAML::Syck ();	30	use YAML::Syck ();
31	use IO::AIO 2.32 ();	31	use IO::AIO 2.32 ();
32	use Time::HiRes;	32	use Time::HiRes;
33	use Compress::LZF;	33	use Compress::LZF;
		34	use Digest::MD5 ();
34		35
35	# configure various modules to our taste	36	# configure various modules to our taste
36	#	37	#
37	$Storable::canonical = 1; # reduce rsync transfers	38	$Storable::canonical = 1; # reduce rsync transfers
38	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator	39	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
…		…
409	Coro::Storable. May, of course, block. Note that the executed sub may	410	Coro::Storable. May, of course, block. Note that the executed sub may
410	never block itself or use any form of Event handling.	411	never block itself or use any form of Event handling.
411		412
412	=cut	413	=cut
413		414
		415	sub _store_scalar {
		416	open my $fh, ">", \my $buf
		417	or die "fork_call: cannot open fh-to-buf in child : $!";
		418	Storable::store_fd $_[0], $fh;
		419	close $fh;
		420
		421	$buf
		422	}
		423
414	sub fork_call(&@) {	424	sub fork_call(&@) {
415	my ($cb, @args) = @_;	425	my ($cb, @args) = @_;
416		426
417	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC	427	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
418	# or die "socketpair: $!";	428	# or die "socketpair: $!";
…		…
421		431
422	if (my $pid = fork) {	432	if (my $pid = fork) {
423	close $fh2;	433	close $fh2;
424		434
425	my $res = (Coro::Handle::unblock $fh1)->readline (undef);	435	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
		436	warn "pst<$res>" unless $res =~ /^pst/;
426	$res = Coro::Storable::thaw $res;	437	$res = Coro::Storable::thaw $res;
427		438
428	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave	439	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
429		440
430	die $$res unless "ARRAY" eq ref $res;	441	Carp::confess $$res unless "ARRAY" eq ref $res;
431		442
432	return wantarray ? @$res : $res->[-1];	443	return wantarray ? @$res : $res->[-1];
433	} else {	444	} else {
434	reset_signals;	445	reset_signals;
435	local $SIG{__WARN__};	446	local $SIG{__WARN__};
436	local $SIG{__DIE__};	447	local $SIG{__DIE__};
		448	# just in case, this hack effectively disables event
		449	# in the child. cleaner and slower would be canceling all watchers,
		450	# but this works for the time being.
		451	local $Coro::idle;
		452	$Coro::current->prio (Coro::PRIO_MAX);
		453
437	eval {	454	eval {
438	close $fh1;	455	close $fh1;
439		456
440	my @res = eval { $cb->(@args) };	457	my @res = eval { $cb->(@args) };
		458
441	syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);	459	syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
		460	close $fh2;
442	};	461	};
443		462
444	warn $@ if $@;	463	warn $@ if $@;
445	_exit 0;	464	_exit 0;
446	}	465	}
…		…
1470	my ($path) = @_;	1489	my ($path) = @_;
1471		1490
1472	my ($match, $specificity);	1491	my ($match, $specificity);
1473		1492
1474	for my $region (list) {	1493	for my $region (list) {
1475	if ($region->match && $path =~ $region->match) {	1494	if ($region->{match} && $path =~ $region->{match}) {
1476	($match, $specificity) = ($region, $region->specificity)	1495	($match, $specificity) = ($region, $region->specificity)
1477	if $region->specificity > $specificity;	1496	if $region->specificity > $specificity;
1478	}	1497	}
1479	}	1498	}
1480		1499
…		…
1600	$self->init; # pass $1 etc.	1619	$self->init; # pass $1 etc.
1601	return $self;	1620	return $self;
1602	}	1621	}
1603	}	1622	}
1604		1623
1605	Carp::carp "unable to resolve path '$path' (base '$base').";	1624	Carp::cluck "unable to resolve path '$path' (base '$base').";
1606	()	1625	()
1607	}	1626	}
1608		1627
1609	sub init {	1628	sub init {
1610	my ($self) = @_;	1629	my ($self) = @_;
…		…
1888		1907
1889	undef $MAP_PREFETCH{$path};	1908	undef $MAP_PREFETCH{$path};
1890	$MAP_PREFETCHER \|\|= cf::async {	1909	$MAP_PREFETCHER \|\|= cf::async {
1891	while (%MAP_PREFETCH) {	1910	while (%MAP_PREFETCH) {
1892	for my $path (keys %MAP_PREFETCH) {	1911	for my $path (keys %MAP_PREFETCH) {
1893	my $map = find $path	1912	if (my $map = find $path) {
1894	or next;
1895	$map->load;	1913	$map->load;
		1914	}
1896		1915
1897	delete $MAP_PREFETCH{$path};	1916	delete $MAP_PREFETCH{$path};
1898	}	1917	}
1899	}	1918	}
1900	undef $MAP_PREFETCHER;	1919	undef $MAP_PREFETCHER;
…		…
2237		2256
2238	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2257	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2239	$self->enter_map ($map, $x, $y);	2258	$self->enter_map ($map, $x, $y);
2240	}	2259	}
2241		2260
2242	=item $player_object->goto ($path, $x, $y[, $check->($map)])	2261	=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2243		2262
2244	Moves the player to the given map-path and coordinates by first freezing	2263	Moves the player to the given map-path and coordinates by first freezing
2245	her, loading and preparing them map, calling the provided $check callback	2264	her, loading and preparing them map, calling the provided $check callback
2246	that has to return the map if sucecssful, and then unfreezes the player on	2265	that has to return the map if sucecssful, and then unfreezes the player on
2247	the new (success) or old (failed) map position.	2266	the new (success) or old (failed) map position. In either case, $done will
		2267	be called at the end of this process.
2248		2268
2249	=cut	2269	=cut
2250		2270
2251	our $GOTOGEN;	2271	our $GOTOGEN;
2252		2272
2253	sub cf::object::player::goto {	2273	sub cf::object::player::goto {
2254	my ($self, $path, $x, $y, $check) = @_;	2274	my ($self, $path, $x, $y, $check, $done) = @_;
2255		2275
2256	# do generation counting so two concurrent goto's will be executed in-order	2276	# do generation counting so two concurrent goto's will be executed in-order
2257	my $gen = $self->{_goto_generation} = ++$GOTOGEN;	2277	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2258		2278
2259	$self->enter_link;	2279	$self->enter_link;
…		…
2279		2299
2280	if ($gen == $self->{_goto_generation}) {	2300	if ($gen == $self->{_goto_generation}) {
2281	delete $self->{_goto_generation};	2301	delete $self->{_goto_generation};
2282	$self->leave_link ($map, $x, $y);	2302	$self->leave_link ($map, $x, $y);
2283	}	2303	}
		2304
		2305	$done->() if $done;
2284	})->prio (1);	2306	})->prio (1);
2285	}	2307	}
2286		2308
2287	=item $player_object->enter_exit ($exit_object)	2309	=item $player_object->enter_exit ($exit_object)
2288		2310
…		…
2356	my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;	2378	my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2357	my $hp = $exit->stats->hp;	2379	my $hp = $exit->stats->hp;
2358	my $sp = $exit->stats->sp;	2380	my $sp = $exit->stats->sp;
2359		2381
2360	$self->enter_link;	2382	$self->enter_link;
		2383
		2384	# if exit is damned, update players death & WoR home-position
		2385	$self->contr->savebed ($slaying, $hp, $sp)
		2386	if $exit->flag (FLAG_DAMNED);
2361		2387
2362	(async {	2388	(async {
2363	$self->deactivate_recursive; # just to be sure	2389	$self->deactivate_recursive; # just to be sure
2364	unless (eval {	2390	unless (eval {
2365	$self->goto ($slaying, $hp, $sp);	2391	$self->goto ($slaying, $hp, $sp);
…		…
2442	=cut	2468	=cut
2443		2469
2444	sub cf::client::ext_event($$%) {	2470	sub cf::client::ext_event($$%) {
2445	my ($self, $type, %msg) = @_;	2471	my ($self, $type, %msg) = @_;
2446		2472
		2473	return unless $self->extcmd;
		2474
2447	$msg{msgtype} = "event_$type";	2475	$msg{msgtype} = "event_$type";
2448	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2476	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2449	}	2477	}
2450		2478
2451	=item $success = $client->query ($flags, "text", \&cb)	2479	=item $success = $client->query ($flags, "text", \&cb)
…		…
2578		2606
2579	=pod	2607	=pod
2580		2608
2581	The following functions and methods are available within a safe environment:	2609	The following functions and methods are available within a safe environment:
2582		2610
2583	cf::object contr pay_amount pay_player map	2611	cf::object
		2612	contr pay_amount pay_player map x y force_find force_add
		2613	insert remove
		2614
2584	cf::object::player player	2615	cf::object::player
2585	cf::player peaceful	2616	player
2586	cf::map trigger	2617
		2618	cf::player
		2619	peaceful
		2620
		2621	cf::map
		2622	trigger
2587		2623
2588	=cut	2624	=cut
2589		2625
2590	for (	2626	for (
2591	["cf::object" => qw(contr pay_amount pay_player map)],	2627	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2628	insert remove)],
2592	["cf::object::player" => qw(player)],	2629	["cf::object::player" => qw(player)],
2593	["cf::player" => qw(peaceful)],	2630	["cf::player" => qw(peaceful)],
2594	["cf::map" => qw(trigger)],	2631	["cf::map" => qw(trigger)],
2595	) {	2632	) {
2596	no strict 'refs';	2633	no strict 'refs';
…		…
2688	{	2725	{
2689	my $faces = $facedata->{faceinfo};	2726	my $faces = $facedata->{faceinfo};
2690		2727
2691	while (my ($face, $info) = each %$faces) {	2728	while (my ($face, $info) = each %$faces) {
2692	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2729	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2693	cf::face::set $idx, $info->{visibility}, $info->{magicmap};	2730	cf::face::set_visibility $idx, $info->{visibility};
		2731	cf::face::set_magicmap $idx, $info->{magicmap};
2694	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2732	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2695	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2733	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2696	Coro::cede;	2734
		2735	cf::cede_to_tick;
2697	}	2736	}
2698		2737
2699	while (my ($face, $info) = each %$faces) {	2738	while (my ($face, $info) = each %$faces) {
2700	next unless $info->{smooth};	2739	next unless $info->{smooth};
2701	my $idx = cf::face::find $face	2740	my $idx = cf::face::find $face
2702	or next;	2741	or next;
2703	if (my $smooth = cf::face::find $info->{smooth}) {	2742	if (my $smooth = cf::face::find $info->{smooth}) {
		2743	cf::face::set_smooth $idx, $smooth;
2704	cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};	2744	cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2705	} else {	2745	} else {
2706	warn "smooth face '$info->{smooth}' not found for face '$face'";	2746	warn "smooth face '$info->{smooth}' not found for face '$face'";
2707	}	2747	}
2708	Coro::cede;	2748
		2749	cf::cede_to_tick;
2709	}	2750	}
2710	}	2751	}
2711		2752
2712	{	2753	{
2713	my $anims = $facedata->{animinfo};	2754	my $anims = $facedata->{animinfo};
2714		2755
2715	while (my ($anim, $info) = each %$anims) {	2756	while (my ($anim, $info) = each %$anims) {
2716	cf::anim::set $anim, $info->{frames}, $info->{facings};	2757	cf::anim::set $anim, $info->{frames}, $info->{facings};
2717	Coro::cede;	2758	cf::cede_to_tick;
2718	}	2759	}
2719		2760
2720	cf::anim::invalidate_all; # d'oh	2761	cf::anim::invalidate_all; # d'oh
		2762	}
		2763
		2764	{
		2765	# TODO: for gcfclient pleasure, we should give resources
		2766	# that gcfclient doesn't grok a >10000 face index.
		2767	my $res = $facedata->{resource};
		2768	my $enc = JSON::XS->new->utf8->canonical;
		2769
		2770	while (my ($name, $info) = each %$res) {
		2771	my $meta = $enc->encode ({
		2772	name => $name,
		2773	type => $info->{type},
		2774	copyright => $info->{copyright}, #TODO#
		2775	});
		2776
		2777	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		2778
		2779	if ($name =~ /\.jpg$/) {
		2780	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack
		2781	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack
		2782	} else {
		2783	my $data = pack "(w/a)", $meta, $info->{data};
		2784	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
		2785
		2786	cf::face::set_type $idx, 1;
		2787	cf::face::set_data $idx, 0, $data, $chk;
		2788	}
		2789
		2790	cf::cede_to_tick;
		2791	}
2721	}	2792	}
2722		2793
2723	1	2794	1
2724	}	2795	}
2725		2796
2726	sub reload_regions {	2797	sub reload_regions {
2727	load_resource_file "$MAPDIR/regions"	2798	load_resource_file "$MAPDIR/regions"
2728	or die "unable to load regions file\n";	2799	or die "unable to load regions file\n";
		2800
		2801	for (cf::region::list) {
		2802	$_->{match} = qr/$_->{match}/
		2803	if exists $_->{match};
		2804	}
2729	}	2805	}
2730		2806
2731	sub reload_facedata {	2807	sub reload_facedata {
2732	load_facedata "$DATADIR/facedata"	2808	load_facedata "$DATADIR/facedata"
2733	or die "unable to load facedata\n";	2809	or die "unable to load facedata\n";

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.295 by root, Wed Jul 4 05:08:15 2007 UTC vs. Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.295 by root, Wed Jul 4 05:08:15 2007 UTC vs.
Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC