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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.253 by root, Wed Apr 18 17:32:07 2007 UTC vs.
Revision 1.278 by root, Mon Jun 11 21:38:14 2007 UTC

…		…
90	our $LINK_MAP; # the special {link} map, which is always available	90	our $LINK_MAP; # the special {link} map, which is always available
91		91
92	# used to convert map paths into valid unix filenames by replacing / by ∕	92	# used to convert map paths into valid unix filenames by replacing / by ∕
93	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons	93	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94		94
		95	our $LOAD; # a number between 0 (idle) and 1 (too many objects)
		96	our $LOADAVG; # same thing, but with alpha-smoothing
		97	our $tick_start; # for load detecting purposes
		98
95	binmode STDOUT;	99	binmode STDOUT;
96	binmode STDERR;	100	binmode STDERR;
97		101
98	# read virtual server time, if available	102	# read virtual server time, if available
99	unless ($RUNTIME \|\| !-e "$LOCALDIR/runtime") {	103	unless ($RUNTIME \|\| !-e "$LOCALDIR/runtime") {
…		…
139		143
140	=item $cf::TICK	144	=item $cf::TICK
141		145
142	The interval between server ticks, in seconds.	146	The interval between server ticks, in seconds.
143		147
		148	=item $cf::LOADAVG
		149
		150	The current CPU load on the server (alpha-smoothed), as a value between 0
		151	(none) and 1 (overloaded), indicating how much time is spent on processing
		152	objects per tick. Healthy values are < 0.5.
		153
		154	=item $cf::LOAD
		155
		156	The raw value load value from the last tick.
		157
144	=item %cf::CFG	158	=item %cf::CFG
145		159
146	Configuration for the server, loaded from C</etc/crossfire/config>, or	160	Configuration for the server, loaded from C</etc/crossfire/config>, or
147	from wherever your confdir points to.	161	from wherever your confdir points to.
148		162
…		…
161	my $msg = join "", @_;	175	my $msg = join "", @_;
162		176
163	$msg .= "\n"	177	$msg .= "\n"
164	unless $msg =~ /\n$/;	178	unless $msg =~ /\n$/;
165		179
166	$msg =~ s/([\x00-\x09\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;	180	$msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
167		181
168	utf8::encode $msg;	182	utf8::encode $msg;
169	LOG llevError, $msg;	183	LOG llevError, $msg;
170	};	184	};
171	}	185	}
…		…
173	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	187	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
174	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';	188	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
175	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';	189	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
176	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';	190	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
177	@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';	191	@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
		192	@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
178	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';	193	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
179		194
180	# we bless all objects into (empty) derived classes to force a method lookup	195	# we bless all objects into (empty) derived classes to force a method lookup
181	# within the Safe compartment.	196	# within the Safe compartment.
182	for my $pkg (qw(	197	for my $pkg (qw(
183	cf::global cf::attachable	198	cf::global cf::attachable
…		…
318		333
319	sub sync_job(&) {	334	sub sync_job(&) {
320	my ($job) = @_;	335	my ($job) = @_;
321		336
322	if ($Coro::current == $Coro::main) {	337	if ($Coro::current == $Coro::main) {
		338	my $time = Event::time;
		339
323	# this is the main coro, too bad, we have to block	340	# this is the main coro, too bad, we have to block
324	# till the operation succeeds, freezing the server :/	341	# till the operation succeeds, freezing the server :/
325		342
326	# TODO: use suspend/resume instead	343	# TODO: use suspend/resume instead
327	# (but this is cancel-safe)	344	# (but this is cancel-safe)
…		…
338		355
339	while ($busy) {	356	while ($busy) {
340	Coro::cede or Event::one_event;	357	Coro::cede or Event::one_event;
341	}	358	}
342		359
		360	$time = Event::time - $time;
		361
		362	LOG llevError \| logBacktrace, Carp::longmess "long sync job"
		363	if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
		364
		365	$tick_start += $time; # do not account sync jobs to server load
		366
343	wantarray ? @res : $res[0]	367	wantarray ? @res : $res[0]
344	} else {	368	} else {
345	# we are in another coroutine, how wonderful, everything just works	369	# we are in another coroutine, how wonderful, everything just works
346		370
347	$job->()	371	$job->()
…		…
367		391
368	$coro	392	$coro
369	}	393	}
370		394
371	sub write_runtime {	395	sub write_runtime {
		396	my $runtime = "$LOCALDIR/runtime";
		397
		398	# first touch the runtime file to show we are still running:
		399	# the fsync below can take a very very long time.
		400
		401	IO::AIO::aio_utime $runtime, undef, undef;
		402
372	my $guard = cf::lock_acquire "write_runtime";	403	my $guard = cf::lock_acquire "write_runtime";
373
374	my $runtime = "$LOCALDIR/runtime";
375		404
376	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644	405	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644
377	or return;	406	or return;
378		407
379	my $value = $cf::RUNTIME + 90 + 10;	408	my $value = $cf::RUNTIME + 90 + 10;
…		…
385		414
386	# always fsync - this file is important	415	# always fsync - this file is important
387	aio_fsync $fh	416	aio_fsync $fh
388	and return;	417	and return;
389		418
		419	# touch it again to show we are up-to-date
		420	aio_utime $fh, undef, undef;
		421
390	close $fh	422	close $fh
391	or return;	423	or return;
392		424
393	aio_rename "$runtime~", $runtime	425	aio_rename "$runtime~", $runtime
394	and return;	426	and return;
		427
		428	warn "runtime file written.\n";
395		429
396	1	430	1
397	}	431	}
398		432
399	=item cf::datalog type => key => value, ...	433	=item cf::datalog type => key => value, ...
…		…
592	$registry = $CB_TYPE[$object_type] \|\|= [];	626	$registry = $CB_TYPE[$object_type] \|\|= [];
593		627
594	} elsif ($type eq "subtype") {	628	} elsif ($type eq "subtype") {
595	defined $object_type or Carp::croak "subtype specified without type";	629	defined $object_type or Carp::croak "subtype specified without type";
596	my $object_subtype = shift @arg;	630	my $object_subtype = shift @arg;
597	$registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] \|\|= [];	631	$registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] \|\|= [];
598		632
599	} elsif ($type eq "package") {	633	} elsif ($type eq "package") {
600	my $pkg = shift @arg;	634	my $pkg = shift @arg;
601		635
602	while (my ($name, $id) = each %cb_id) {	636	while (my ($name, $id) = each %cb_id) {
…		…
643	if (ref $_[0]) {	677	if (ref $_[0]) {
644	_object_attach @_;	678	_object_attach @_;
645	} else {	679	} else {
646	_attach shift->_attach_registry, @_;	680	_attach shift->_attach_registry, @_;
647	}	681	}
		682	_recalc_want;
648	};	683	};
649		684
650	# all those should be optimised	685	# all those should be optimised
651	sub cf::attachable::detach {	686	sub cf::attachable::detach {
652	my ($obj, $name) = @_;	687	my ($obj, $name) = @_;
…		…
655	delete $obj->{_attachment}{$name};	690	delete $obj->{_attachment}{$name};
656	reattach ($obj);	691	reattach ($obj);
657	} else {	692	} else {
658	Carp::croak "cannot, currently, detach class attachments";	693	Carp::croak "cannot, currently, detach class attachments";
659	}	694	}
		695	_recalc_want;
660	};	696	};
661		697
662	sub cf::attachable::attached {	698	sub cf::attachable::attached {
663	my ($obj, $name) = @_;	699	my ($obj, $name) = @_;
664		700
…		…
837	or return;	873	or return;
838	$av = eval { (Storable::thaw $av)->{objs} };	874	$av = eval { (Storable::thaw $av)->{objs} };
839	}	875	}
840		876
841	warn sprintf "loading %s (%d)\n",	877	warn sprintf "loading %s (%d)\n",
842	$filename, length $data, scalar @{$av \|\| []};#d#	878	$filename, length $data, scalar @{$av \|\| []};
843	return ($data, $av);	879	return ($data, $av);
844	}	880	}
845		881
846	#############################################################################	882	#############################################################################
847	# command handling &c	883	# command handling &c
…		…
907		943
908	cf::override;	944	cf::override;
909	},	945	},
910	);	946	);
911		947
912	sub load_extension {
913	my ($path) = @_;
914
915	$path =~ /([^\/\\]+)\.ext$/ or die "$path";
916	my $base = $1;
917	my $pkg = $1;
918	$pkg =~ s/[^[:word:]]/_/g;
919	$pkg = "ext::$pkg";
920
921	warn "... loading '$path' into '$pkg'\n";
922
923	open my $fh, "<:utf8", $path
924	or die "$path: $!";
925
926	my $source =
927	"package $pkg; use strict; use utf8;\n"
928	. "#line 1 \"$path\"\n{\n"
929	. (do { local $/; <$fh> })
930	. "\n};\n1";
931
932	unless (eval $source) {
933	my $msg = $@ ? "$path: $@\n"
934	: "extension disabled.\n";
935	if ($source =~ /^#!.perl.#.*MANDATORY/m) { # ugly match
936	warn $@;
937	warn "mandatory extension failed to load, exiting.\n";
938	exit 1;
939	}
940	die $@;
941	}
942
943	push @EXTS, $pkg;
944	}
945
946	sub load_extensions {	948	sub load_extensions {
		949	cf::sync_job {
		950	my %todo;
		951
947	for my $ext (<$LIBDIR/*.ext>) {	952	for my $path (<$LIBDIR/*.ext>) {
948	next unless -r $ext;	953	next unless -r $path;
949	eval {	954
950	load_extension $ext;	955	$path =~ /([^\/\\]+)\.ext$/ or die "$path";
		956	my $base = $1;
		957	my $pkg = $1;
		958	$pkg =~ s/[^[:word:]]/_/g;
		959	$pkg = "ext::$pkg";
		960
		961	open my $fh, "<:utf8", $path
		962	or die "$path: $!";
		963
		964	my $source = do { local $/; <$fh> };
		965
		966	my %ext = (
		967	path => $path,
		968	base => $base,
		969	pkg => $pkg,
		970	);
		971
		972	$ext{meta} = { map { split /=/, $_, 2 } split /\s+/, $1 }
		973	if $source =~ /^#!.?perl.?#\s(.)$/;
		974
		975	$ext{source} =
		976	"package $pkg; use strict; use utf8;\n"
		977	. "#line 1 \"$path\"\n{\n"
		978	. $source
		979	. "\n};\n1";
		980
		981	$todo{$base} = \%ext;
		982	}
		983
		984	my %done;
		985	while (%todo) {
		986	my $progress;
		987
		988	while (my ($k, $v) = each %todo) {
		989	for (split /,\s*/, $ext{meta}{depends}) {
		990	goto skip
		991	unless exists $done{$_};
		992	}
		993
		994	warn "... loading '$k' into '$v->{pkg}'\n";
		995
		996	unless (eval $v->{source}) {
		997	my $msg = $@ ? "$v->{path}: $@\n"
		998	: "extension disabled.\n";
		999
		1000	if (exists $v->{meta}{mandatory}) {
		1001	warn $msg;
		1002	warn "mandatory extension failed to load, exiting.\n";
		1003	exit 1;
		1004	}
		1005
		1006	die $msg;
		1007	}
		1008
		1009	$done{$k} = delete $todo{$k};
		1010	push @EXTS, $v->{pkg};
951	1	1011	}
952	} or warn "$ext not loaded: $@";	1012
		1013	skip:
		1014	die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
		1015	unless $progress;
		1016	}
953	}	1017	};
954	}	1018	}
955		1019
956	#############################################################################	1020	#############################################################################
957		1021
958	=head2 CORE EXTENSIONS	1022	=head2 CORE EXTENSIONS
…		…
1269	my ($self, $merge) = @_;	1333	my ($self, $merge) = @_;
1270		1334
1271	# we have to keep some variables in memory intact	1335	# we have to keep some variables in memory intact
1272	local $self->{path};	1336	local $self->{path};
1273	local $self->{load_path};	1337	local $self->{load_path};
1274	local $self->{deny_save};
1275	local $self->{deny_reset};
1276		1338
1277	$self->SUPER::thawer_merge ($merge);	1339	$self->SUPER::thawer_merge ($merge);
1278	}	1340	}
1279		1341
1280	sub normalise {	1342	sub normalise {
…		…
1352		1414
1353	# the original (read-only) location	1415	# the original (read-only) location
1354	sub load_path {	1416	sub load_path {
1355	my ($self) = @_;	1417	my ($self) = @_;
1356		1418
1357	"$MAPDIR($self->{path}"	1419	"$MAPDIR/$self->{path}.map"
1358	}	1420	}
1359		1421
1360	# the temporary/swap location	1422	# the temporary/swap location
1361	sub save_path {	1423	sub save_path {
1362	my ($self) = @_;	1424	my ($self) = @_;
1363		1425
1364	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;	1426	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1365	"$TMPDIR/$path"	1427	"$TMPDIR/$path.map"
1366	}	1428	}
1367		1429
1368	# the unique path, undef == no special unique path	1430	# the unique path, undef == no special unique path
1369	sub uniq_path {	1431	sub uniq_path {
1370	my ($self) = @_;	1432	my ($self) = @_;
…		…
1378	sub change_all_map_light {	1440	sub change_all_map_light {
1379	my ($change) = @_;	1441	my ($change) = @_;
1380		1442
1381	$_->change_map_light ($change)	1443	$_->change_map_light ($change)
1382	for grep $_->outdoor, values %cf::MAP;	1444	for grep $_->outdoor, values %cf::MAP;
		1445	}
		1446
		1447	sub decay_objects {
		1448	my ($self) = @_;
		1449
		1450	return if $self->{deny_reset};
		1451
		1452	$self->do_decay_objects;
1383	}	1453	}
1384		1454
1385	sub unlink_save {	1455	sub unlink_save {
1386	my ($self) = @_;	1456	my ($self) = @_;
1387		1457
…		…
1445	$self->load_header_orig	1515	$self->load_header_orig
1446	or return;	1516	or return;
1447	$self->prepare_orig;	1517	$self->prepare_orig;
1448	}	1518	}
1449		1519
		1520	$self->{deny_reset} = 1
		1521	if $self->no_reset;
		1522
1450	$self->default_region (cf::region::find_by_path $self->{path})	1523	$self->default_region (cf::region::find_by_path $self->{path})
1451	unless $self->default_region;	1524	unless $self->default_region;
1452		1525
1453	1	1526	1
1454	}	1527	}
…		…
1469	$map->{last_save} = $cf::RUNTIME;	1542	$map->{last_save} = $cf::RUNTIME;
1470		1543
1471	$map->load_header	1544	$map->load_header
1472	or return;	1545	or return;
1473		1546
1474	if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?)	1547	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1475	# doing this can freeze the server in a sync job, obviously	1548	# doing this can freeze the server in a sync job, obviously
1476	#$cf::WAIT_FOR_TICK->wait;	1549	#$cf::WAIT_FOR_TICK->wait;
1477	$map->reset;	1550	$map->reset;
1478	undef $guard;	1551	undef $guard;
1479	return find $path;	1552	return find $path;
…		…
1490	my ($self) = @_;	1563	my ($self) = @_;
1491		1564
1492	local $self->{deny_reset} = 1; # loading can take a long time	1565	local $self->{deny_reset} = 1; # loading can take a long time
1493		1566
1494	my $path = $self->{path};	1567	my $path = $self->{path};
		1568
		1569	{
1495	my $guard = cf::lock_acquire "map_load:$path";	1570	my $guard = cf::lock_acquire "map_load:$path";
1496		1571
1497	return if $self->in_memory != cf::MAP_SWAPPED;	1572	return if $self->in_memory != cf::MAP_SWAPPED;
1498		1573
1499	$self->in_memory (cf::MAP_LOADING);	1574	$self->in_memory (cf::MAP_LOADING);
1500		1575
1501	$self->alloc;	1576	$self->alloc;
1502		1577
1503	$self->pre_load;	1578	$self->pre_load;
1504	Coro::cede;
1505
1506	$self->_load_objects ($self->{load_path}, 1)
1507	or return;
1508
1509	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1510	if delete $self->{load_original};
1511
1512	if (my $uniq = $self->uniq_path) {
1513	utf8::encode $uniq;
1514	if (aio_open $uniq, O_RDONLY, 0) {
1515	$self->clear_unique_items;
1516	$self->_load_objects ($uniq, 0);
1517	}
1518	}
1519
1520	Coro::cede;
1521	# now do the right thing for maps
1522	$self->link_multipart_objects;
1523	Coro::cede;
1524
1525	unless ($self->{deny_activate}) {
1526	$self->decay_objects;
1527	$self->fix_auto_apply;
1528	$self->update_buttons;
1529	Coro::cede;	1579	Coro::cede;
1530	$self->set_darkness_map;	1580
		1581	$self->_load_objects ($self->{load_path}, 1)
		1582	or return;
		1583
		1584	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
		1585	if delete $self->{load_original};
		1586
		1587	if (my $uniq = $self->uniq_path) {
		1588	utf8::encode $uniq;
		1589	if (aio_open $uniq, O_RDONLY, 0) {
		1590	$self->clear_unique_items;
		1591	$self->_load_objects ($uniq, 0);
		1592	}
		1593	}
		1594
		1595	Coro::cede;
		1596	# now do the right thing for maps
		1597	$self->link_multipart_objects;
1531	$self->difficulty ($self->estimate_difficulty)	1598	$self->difficulty ($self->estimate_difficulty)
1532	unless $self->difficulty;	1599	unless $self->difficulty;
1533	Coro::cede;	1600	Coro::cede;
		1601
		1602	unless ($self->{deny_activate}) {
		1603	$self->decay_objects;
		1604	$self->fix_auto_apply;
		1605	$self->update_buttons;
		1606	Coro::cede;
		1607	$self->set_darkness_map;
		1608	Coro::cede;
1534	$self->activate;	1609	$self->activate;
1535	Coro::cede;	1610	}
		1611
		1612	$self->in_memory (cf::MAP_IN_MEMORY);
1536	}	1613	}
1537		1614
1538	$self->post_load;	1615	$self->post_load;
1539	Coro::cede;
1540
1541	$self->in_memory (cf::MAP_IN_MEMORY);
1542	}	1616	}
1543		1617
1544	sub customise_for {	1618	sub customise_for {
1545	my ($self, $ob) = @_;	1619	my ($self, $ob) = @_;
1546		1620
1547	return find "~" . $ob->name . "/" . $self->{path}	1621	return find "~" . $ob->name . "/" . $self->{path}
1548	if $self->per_player;	1622	if $self->per_player;
		1623
		1624	# return find "?party/" . $ob->name . "/" . $self->{path}
		1625	# if $self->per_party;
1549		1626
1550	$self	1627	$self
1551	}	1628	}
1552		1629
1553	# find and load all maps in the 3x3 area around a map	1630	# find and load all maps in the 3x3 area around a map
…		…
1664		1741
1665	sub reset_at {	1742	sub reset_at {
1666	my ($self) = @_;	1743	my ($self) = @_;
1667		1744
1668	# TODO: safety, remove and allow resettable per-player maps	1745	# TODO: safety, remove and allow resettable per-player maps
1669	return 1e99 if $self->isa ("ext::map_per_player");#d#
1670	return 1e99 if $self->{deny_reset};	1746	return 1e99 if $self->{deny_reset};
1671		1747
1672	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;	1748	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1673	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;	1749	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;
1674		1750
…		…
1685	my ($self) = @_;	1761	my ($self) = @_;
1686		1762
1687	my $lock = cf::lock_acquire "map_data:$self->{path}";	1763	my $lock = cf::lock_acquire "map_data:$self->{path}";
1688		1764
1689	return if $self->players;	1765	return if $self->players;
1690	return if $self->isa ("ext::map_per_player");#d#
1691		1766
1692	warn "resetting map ", $self->path;#d#	1767	warn "resetting map ", $self->path;
1693		1768
1694	$self->in_memory (cf::MAP_SWAPPED);	1769	$self->in_memory (cf::MAP_SWAPPED);
1695		1770
1696	# need to save uniques path	1771	# need to save uniques path
1697	unless ($self->{deny_save}) {	1772	unless ($self->{deny_save}) {
…		…
1729	$cf::MAP{$self->path} = $self;	1804	$cf::MAP{$self->path} = $self;
1730		1805
1731	$self->reset; # polite request, might not happen	1806	$self->reset; # polite request, might not happen
1732	}	1807	}
1733		1808
		1809	=item $maps = cf::map::tmp_maps
		1810
		1811	Returns an arrayref with all map paths of currently instantiated and saved
		1812	maps. May block.
		1813
		1814	=cut
		1815
		1816	sub tmp_maps() {
		1817	[
		1818	map {
		1819	utf8::decode $_;
		1820	/\.map$/
		1821	? normalise $_
		1822	: ()
		1823	} @{ aio_readdir $TMPDIR or [] }
		1824	]
		1825	}
		1826
		1827	=item $maps = cf::map::random_maps
		1828
		1829	Returns an arrayref with all map paths of currently instantiated and saved
		1830	random maps. May block.
		1831
		1832	=cut
		1833
		1834	sub random_maps() {
		1835	[
		1836	map {
		1837	utf8::decode $_;
		1838	/\.map$/
		1839	? normalise "?random/$_"
		1840	: ()
		1841	} @{ aio_readdir $RANDOMDIR or [] }
		1842	]
		1843	}
		1844
1734	=item cf::map::unique_maps	1845	=item cf::map::unique_maps
1735		1846
1736	Returns an arrayref of paths of all shared maps that have	1847	Returns an arrayref of paths of all shared maps that have
1737	instantiated unique items. May block.	1848	instantiated unique items. May block.
1738		1849
1739	=cut	1850	=cut
1740		1851
1741	sub unique_maps() {	1852	sub unique_maps() {
1742	my $files = aio_readdir $UNIQUEDIR	1853	[
1743	or return;	1854	map {
1744
1745	my @paths;
1746
1747	for (@$files) {
1748	utf8::decode $_;	1855	utf8::decode $_;
1749	next if /\.pst$/;	1856	/\.map$/
1750	next unless /^$PATH_SEP/o;	1857	? normalise $_
1751		1858	: ()
1752	push @paths, cf::map::normalise $_;	1859	} @{ aio_readdir $UNIQUEDIR or [] }
1753	}	1860	]
1754
1755	\@paths
1756	}	1861	}
1757		1862
1758	package cf;	1863	package cf;
1759		1864
1760	=back	1865	=back
…		…
1866	$self->deactivate_recursive;	1971	$self->deactivate_recursive;
1867		1972
1868	return if UNIVERSAL::isa $self->map, "ext::map_link";	1973	return if UNIVERSAL::isa $self->map, "ext::map_link";
1869		1974
1870	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]	1975	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]
1871	if $self->map;	1976	if $self->map && $self->map->{path} ne "{link}";
1872		1977
1873	$self->enter_map ($LINK_MAP \|\| link_map, 10, 10);	1978	$self->enter_map ($LINK_MAP \|\| link_map, 10, 10);
1874	}	1979	}
1875		1980
1876	sub cf::object::player::leave_link {	1981	sub cf::object::player::leave_link {
1877	my ($self, $map, $x, $y) = @_;	1982	my ($self, $map, $x, $y) = @_;
		1983
		1984	return unless $self->contr->active;
1878		1985
1879	my $link_pos = delete $self->{_link_pos};	1986	my $link_pos = delete $self->{_link_pos};
1880		1987
1881	unless ($map) {	1988	unless ($map) {
1882	# restore original map position	1989	# restore original map position
…		…
1905		2012
1906	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2013	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1907	$self->enter_map ($map, $x, $y);	2014	$self->enter_map ($map, $x, $y);
1908	}	2015	}
1909		2016
1910	cf::player->attach (
1911	on_logout => sub {
1912	my ($pl) = @_;
1913
1914	# abort map switching before logout
1915	if ($pl->ob->{_link_pos}) {
1916	cf::sync_job {
1917	$pl->ob->leave_link
1918	};
1919	}
1920	},
1921	on_login => sub {
1922	my ($pl) = @_;
1923
1924	# try to abort aborted map switching on player login :)
1925	# should happen only on crashes
1926	if ($pl->ob->{_link_pos}) {
1927	$pl->ob->enter_link;
1928	(async {
1929	$pl->ob->reply (undef,
1930	"There was an internal problem at your last logout, "
1931	. "the server will try to bring you to your intended destination in a second.",
1932	cf::NDI_RED);
1933	# we need this sleep as the login has a concurrent enter_exit running
1934	# and this sleep increases chances of the player not ending up in scorn
1935	Coro::Timer::sleep 1;
1936	$pl->ob->leave_link;
1937	})->prio (2);
1938	}
1939	},
1940	);
1941
1942	=item $player_object->goto ($path, $x, $y)	2017	=item $player_object->goto ($path, $x, $y[, $check->($map)])
1943		2018
		2019	Moves the player to the given map-path and coordinates by first freezing
		2020	her, loading and preparing them map, calling the provided $check callback
		2021	that has to return the map if sucecssful, and then unfreezes the player on
		2022	the new (success) or old (failed) map position.
		2023
1944	=cut	2024	=cut
		2025
		2026	our $GOTOGEN;
1945		2027
1946	sub cf::object::player::goto {	2028	sub cf::object::player::goto {
1947	my ($self, $path, $x, $y) = @_;	2029	my ($self, $path, $x, $y, $check) = @_;
		2030
		2031	# do generation counting so two concurrent goto's will be executed in-order
		2032	my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1948		2033
1949	$self->enter_link;	2034	$self->enter_link;
1950		2035
1951	(async {	2036	(async {
1952	my $map = eval {	2037	my $map = eval {
1953	my $map = cf::map::find $path;	2038	my $map = cf::map::find $path;
		2039
		2040	if ($map) {
1954	$map = $map->customise_for ($self) if $map;	2041	$map = $map->customise_for ($self);
		2042	$map = $check->($map) if $check && $map;
		2043	} else {
		2044	$self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE \| cf::NDI_RED);
		2045	}
		2046
1955	$map	2047	$map
		2048	};
		2049
		2050	if ($@) {
		2051	$self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE \| cf::NDI_RED);
		2052	LOG llevError \| logBacktrace, Carp::longmess $@;
1956	} or	2053	}
1957	$self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE \| cf::NDI_RED);
1958		2054
		2055	if ($gen == $self->{_goto_generation}) {
		2056	delete $self->{_goto_generation};
1959	$self->leave_link ($map, $x, $y);	2057	$self->leave_link ($map, $x, $y);
		2058	}
1960	})->prio (1);	2059	})->prio (1);
1961	}	2060	}
1962		2061
1963	=item $player_object->enter_exit ($exit_object)	2062	=item $player_object->enter_exit ($exit_object)
1964		2063
…		…
2434		2533
2435	die $$res unless "ARRAY" eq ref $res;	2534	die $$res unless "ARRAY" eq ref $res;
2436		2535
2437	return wantarray ? @$res : $res->[-1];	2536	return wantarray ? @$res : $res->[-1];
2438	} else {	2537	} else {
		2538	reset_signals;
2439	local $SIG{__WARN__};	2539	local $SIG{__WARN__};
		2540	local $SIG{__DIE__};
2440	eval {	2541	eval {
2441	local $SIG{__DIE__};
2442	close $fh1;	2542	close $fh1;
2443		2543
2444	my @res = eval { $cb->(@args) };	2544	my @res = eval { $cb->(@args) };
2445	syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);	2545	syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2446	};	2546	};
2447		2547
2448	warn $@ if $@;	2548	warn $@ if $@;
2449	_exit 0;	2549	_exit 0;
2450	}	2550	}
2451	}	2551	}
2452
2453
2454		2552
2455	#############################################################################	2553	#############################################################################
2456	# the server's init and main functions	2554	# the server's init and main functions
2457		2555
2458	sub load_facedata($) {	2556	sub load_facedata($) {
…		…
2530	sub reload_resources {	2628	sub reload_resources {
2531	warn "reloading resource files...\n";	2629	warn "reloading resource files...\n";
2532		2630
2533	reload_regions;	2631	reload_regions;
2534	reload_facedata;	2632	reload_facedata;
		2633	#reload_archetypes;#d#
2535	reload_archetypes;	2634	reload_archetypes;
2536	reload_treasures;	2635	reload_treasures;
2537		2636
2538	warn "finished reloading resource files\n";	2637	warn "finished reloading resource files\n";
2539	}	2638	}
…		…
2809	my $signal = new Coro::Signal;	2908	my $signal = new Coro::Signal;
2810	push @WAIT_FOR_TICK_BEGIN, $signal;	2909	push @WAIT_FOR_TICK_BEGIN, $signal;
2811	$signal->wait;	2910	$signal->wait;
2812	}	2911	}
2813		2912
		2913	my $min = 1e6;#d#
		2914	my $avg = 10;
2814	$TICK_WATCHER = Event->timer (	2915	$TICK_WATCHER = Event->timer (
2815	reentrant => 0,	2916	reentrant => 0,
2816	parked => 1,	2917	parked => 1,
2817	prio => 0,	2918	prio => 0,
2818	at => $NEXT_TICK \|\| $TICK,	2919	at => $NEXT_TICK \|\| $TICK,
…		…
2822	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"	2923	Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2823	unless ++$bug_warning > 10;	2924	unless ++$bug_warning > 10;
2824	return;	2925	return;
2825	}	2926	}
2826		2927
2827	$NOW = Event::time;	2928	$NOW = $tick_start = Event::time;
2828		2929
2829	cf::server_tick; # one server iteration	2930	cf::server_tick; # one server iteration
		2931
		2932	0 && sync_job {#d#
		2933	for(1..10) {
		2934	my $t = Event::time;
		2935	my $map = my $map = new_from_path cf::map "/tmp/x.map"
		2936	or die;
		2937
		2938	$map->width (50);
		2939	$map->height (50);
		2940	$map->alloc;
		2941	$map->_load_objects ("/tmp/x.map", 1);
		2942	my $t = Event::time - $t;
		2943
		2944	#next unless $t < 0.0013;#d#
		2945	if ($t < $min) {
		2946	$min = $t;
		2947	}
		2948	$avg = $avg * 0.99 + $t * 0.01;
		2949	}
		2950	warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
		2951	exit 0;
		2952	# 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
		2953	};
2830		2954
2831	$RUNTIME += $TICK;	2955	$RUNTIME += $TICK;
2832	$NEXT_TICK += $TICK;	2956	$NEXT_TICK += $TICK;
2833		2957
2834	if ($NOW >= $NEXT_RUNTIME_WRITE) {	2958	if ($NOW >= $NEXT_RUNTIME_WRITE) {
…		…
2840	}	2964	}
2841		2965
2842	# my $AFTER = Event::time;	2966	# my $AFTER = Event::time;
2843	# warn $AFTER - $NOW;#d#	2967	# warn $AFTER - $NOW;#d#
2844		2968
		2969	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
		2970	$sig->send;
		2971	}
		2972	while (my $sig = shift @WAIT_FOR_TICK) {
		2973	$sig->send;
		2974	}
		2975
		2976	$NOW = Event::time;
		2977
2845	# if we are delayed by four ticks or more, skip them all	2978	# if we are delayed by four ticks or more, skip them all
2846	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;	2979	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2847		2980
2848	$TICK_WATCHER->at ($NEXT_TICK);	2981	$TICK_WATCHER->at ($NEXT_TICK);
2849	$TICK_WATCHER->start;	2982	$TICK_WATCHER->start;
2850		2983
2851	if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {	2984	$LOAD = ($NOW - $tick_start) / $TICK;
2852	$sig->send;	2985	$LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2853	}
2854	while (my $sig = shift @WAIT_FOR_TICK) {
2855	$sig->send;
2856	}
2857		2986
2858	_post_tick;	2987	_post_tick;
		2988
		2989
2859	},	2990	},
2860	);	2991	);
2861		2992
2862	{	2993	{
2863	BDB::max_poll_time $TICK * 0.1;	2994	BDB::max_poll_time $TICK * 0.1;
…		…
2922	prio => 6,	3053	prio => 6,
2923	cb => \&IO::AIO::poll_cb,	3054	cb => \&IO::AIO::poll_cb,
2924	);	3055	);
2925	}	3056	}
2926		3057
		3058	my $_log_backtrace;
		3059
		3060	sub _log_backtrace {
		3061	my ($msg, @addr) = @_;
		3062
		3063	$msg =~ s/\n//;
		3064
		3065	# limit the # of concurrent backtraces
		3066	if ($_log_backtrace < 2) {
		3067	++$_log_backtrace;
		3068	async {
		3069	my @bt = fork_call {
		3070	@addr = map { sprintf "%x", $_ } @addr;
		3071	my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
		3072	open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 \|"
		3073	or die "addr2line: $!";
		3074
		3075	my @funcs;
		3076	my @res = <$fh>;
		3077	chomp for @res;
		3078	while (@res) {
		3079	my ($func, $line) = splice @res, 0, 2, ();
		3080	push @funcs, "[$func] $line";
		3081	}
		3082
		3083	@funcs
		3084	};
		3085
		3086	LOG llevInfo, "[ABT] $msg\n";
		3087	LOG llevInfo, "[ABT] $_\n" for @bt;
		3088	--$_log_backtrace;
		3089	};
		3090	} else {
		3091	LOG llevInfo, "[ABT] $msg\n";
		3092	LOG llevInfo, "[ABT] [suppressed]\n";
		3093	}
		3094	}
		3095
2927	# load additional modules	3096	# load additional modules
2928	use cf::pod;	3097	use cf::pod;
2929		3098
2930	END { cf::emergency_save }	3099	END { cf::emergency_save }
2931		3100

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.253 by root, Wed Apr 18 17:32:07 2007 UTC vs. Revision 1.278 by root, Mon Jun 11 21:38:14 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.253 by root, Wed Apr 18 17:32:07 2007 UTC vs.
Revision 1.278 by root, Mon Jun 11 21:38:14 2007 UTC