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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.434 by root, Thu May 29 03:27:37 2008 UTC vs.
Revision 1.458 by root, Sat Dec 13 20:34:37 2008 UTC

…		…
19	# The authors can be reached via e-mail to <support@deliantra.net>	19	# The authors can be reached via e-mail to <support@deliantra.net>
20	#	20	#
21		21
22	package cf;	22	package cf;
23		23
		24	use 5.10.0;
24	use utf8;	25	use utf8;
25	use strict;	26	use strict "vars", "subs";
26		27
27	use Symbol;	28	use Symbol;
28	use List::Util;	29	use List::Util;
29	use Socket;	30	use Socket;
30	use EV;	31	use EV;
31	use Opcode;	32	use Opcode;
32	use Safe;	33	use Safe;
33	use Safe::Hole;	34	use Safe::Hole;
34	use Storable ();	35	use Storable ();
35		36
		37	use Guard ();
36	use Coro ();	38	use Coro ();
37	use Coro::State;	39	use Coro::State;
38	use Coro::Handle;	40	use Coro::Handle;
		41	use Coro::EV;
39	use Coro::AnyEvent;	42	use Coro::AnyEvent;
40	use Coro::Timer;	43	use Coro::Timer;
41	use Coro::Signal;	44	use Coro::Signal;
42	use Coro::Semaphore;	45	use Coro::Semaphore;
43	use Coro::AnyEvent;	46	use Coro::AnyEvent;
44	use Coro::AIO;	47	use Coro::AIO;
45	use Coro::BDB;	48	use Coro::BDB 1.6;
46	use Coro::Storable;	49	use Coro::Storable;
47	use Coro::Util ();	50	use Coro::Util ();
48		51
49	use JSON::XS 2.01 ();	52	use JSON::XS 2.01 ();
50	use BDB ();	53	use BDB ();
…		…
57	use Compress::LZF;	60	use Compress::LZF;
58	use Digest::MD5 ();	61	use Digest::MD5 ();
59		62
60	AnyEvent::detect;	63	AnyEvent::detect;
61		64
62	IO::AIO::max_poll_reqs 1;#d#
63
64	# configure various modules to our taste	65	# configure various modules to our taste
65	#	66	#
66	$Storable::canonical = 1; # reduce rsync transfers	67	$Storable::canonical = 1; # reduce rsync transfers
67	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator	68	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
		69
		70	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
		71
		72	# make sure c-lzf reinitialises itself
		73	Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
68	Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later	74	Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
69
70	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
71		75
72	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	76	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
73		77
74	our %COMMAND = ();	78	our %COMMAND = ();
75	our %COMMAND_TIME = ();	79	our %COMMAND_TIME = ();
…		…
78	our %EXTCMD = ();	82	our %EXTCMD = ();
79	our %EXTICMD = ();	83	our %EXTICMD = ();
80	our %EXT_CORO = (); # coroutines bound to extensions	84	our %EXT_CORO = (); # coroutines bound to extensions
81	our %EXT_MAP = (); # pluggable maps	85	our %EXT_MAP = (); # pluggable maps
82		86
83	our $RELOAD; # number of reloads so far	87	our $RELOAD; # number of reloads so far, non-zero while in reload
84	our @EVENT;	88	our @EVENT;
85		89
86	our $CONFDIR = confdir;	90	our $CONFDIR = confdir;
87	our $DATADIR = datadir;	91	our $DATADIR = datadir;
88	our $LIBDIR = "$DATADIR/ext";	92	our $LIBDIR = "$DATADIR/ext";
89	our $PODDIR = "$DATADIR/pod";	93	our $PODDIR = "$DATADIR/pod";
90	our $MAPDIR = "$DATADIR/" . mapdir;	94	our $MAPDIR = "$DATADIR/" . mapdir;
91	our $LOCALDIR = localdir;	95	our $LOCALDIR = localdir;
92	our $TMPDIR = "$LOCALDIR/" . tmpdir;	96	our $TMPDIR = "$LOCALDIR/" . tmpdir;
93	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;	97	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
94	our $PLAYERDIR = "$LOCALDIR/" . playerdir;	98	our $PLAYERDIR = "$LOCALDIR/" . playerdir;
95	our $RANDOMDIR = "$LOCALDIR/random";	99	our $RANDOMDIR = "$LOCALDIR/random";
96	our $BDBDIR = "$LOCALDIR/db";	100	our $BDBDIR = "$LOCALDIR/db";
		101	our $PIDFILE = "$LOCALDIR/pid";
		102	our $RUNTIMEFILE = "$LOCALDIR/runtime";
		103
97	our %RESOURCE;	104	our %RESOURCE;
98		105
99	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	106	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
100	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	107	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
101	our $NEXT_TICK;	108	our $NEXT_TICK;
…		…
122	our $LOAD; # a number between 0 (idle) and 1 (too many objects)	129	our $LOAD; # a number between 0 (idle) and 1 (too many objects)
123	our $LOADAVG; # same thing, but with alpha-smoothing	130	our $LOADAVG; # same thing, but with alpha-smoothing
124	our $JITTER; # average jitter	131	our $JITTER; # average jitter
125	our $TICK_START; # for load detecting purposes	132	our $TICK_START; # for load detecting purposes
126		133
		134	our @POST_INIT;
		135
		136	our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow)
		137
127	binmode STDOUT;	138	binmode STDOUT;
128	binmode STDERR;	139	binmode STDERR;
129		140
130	# read virtual server time, if available	141	# read virtual server time, if available
131	unless ($RUNTIME \|\| !-e "$LOCALDIR/runtime") {	142	unless ($RUNTIME \|\| !-e $RUNTIMEFILE) {
132	open my $fh, "<", "$LOCALDIR/runtime"	143	open my $fh, "<", $RUNTIMEFILE
133	or die "unable to read runtime file: $!";	144	or die "unable to read $RUNTIMEFILE file: $!";
134	$RUNTIME = <$fh> + 0.;	145	$RUNTIME = <$fh> + 0.;
135	}	146	}
136		147
137	mkdir $_	148	mkdir $_
138	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;	149	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
…		…
245	for my $pkg (qw(	256	for my $pkg (qw(
246	cf::global cf::attachable	257	cf::global cf::attachable
247	cf::object cf::object::player	258	cf::object cf::object::player
248	cf::client cf::player	259	cf::client cf::player
249	cf::arch cf::living	260	cf::arch cf::living
		261	cf::map cf::mapspace
250	cf::map cf::party cf::region	262	cf::party cf::region
251	)) {	263	)) {
252	no strict 'refs';
253	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	264	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
254	}	265	}
255		266
256	$EV::DIED = sub {	267	$EV::DIED = sub {
257	warn "error in event callback: @_";	268	warn "error in event callback: @_";
…		…
299	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max	310	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
300		311
301	sub encode_json($) { $json_coder->encode ($_[0]) }	312	sub encode_json($) { $json_coder->encode ($_[0]) }
302	sub decode_json($) { $json_coder->decode ($_[0]) }	313	sub decode_json($) { $json_coder->decode ($_[0]) }
303		314
		315	=item cf::post_init { BLOCK }
		316
		317	Execute the given codeblock, I<after> all extensions have been (re-)loaded,
		318	but I<before> the server starts ticking again.
		319
		320	The cdoeblock will have a single boolean argument to indicate whether this
		321	is a reload or not.
		322
		323	=cut
		324
		325	sub post_init(&) {
		326	push @POST_INIT, shift;
		327	}
		328
304	=item cf::lock_wait $string	329	=item cf::lock_wait $string
305		330
306	Wait until the given lock is available. See cf::lock_acquire.	331	Wait until the given lock is available. See cf::lock_acquire.
307		332
308	=item my $lock = cf::lock_acquire $string	333	=item my $lock = cf::lock_acquire $string
309		334
310	Wait until the given lock is available and then acquires it and returns	335	Wait until the given lock is available and then acquires it and returns
311	a Coro::guard object. If the guard object gets destroyed (goes out of scope,	336	a L<Guard> object. If the guard object gets destroyed (goes out of scope,
312	for example when the coroutine gets canceled), the lock is automatically	337	for example when the coroutine gets canceled), the lock is automatically
313	returned.	338	returned.
314		339
315	Locks are not recursive, locking from the same coro twice results in a	340	Locks are not recursive, locking from the same coro twice results in a
316	deadlocked coro.	341	deadlocked coro.
…		…
335	return;#d#	360	return;#d#
336	}#d#	361	}#d#
337		362
338	# wait for lock, if any	363	# wait for lock, if any
339	while ($LOCK{$key}) {	364	while ($LOCK{$key}) {
		365	#local $Coro::current->{desc} = "$Coro::current->{desc} <waiting for lock $key>";
340	push @{ $LOCK{$key} }, $Coro::current;	366	push @{ $LOCK{$key} }, $Coro::current;
341	Coro::schedule;	367	Coro::schedule;
342	}	368	}
343	}	369	}
344		370
…		…
349	lock_wait $key;	375	lock_wait $key;
350		376
351	$LOCK{$key} = [];	377	$LOCK{$key} = [];
352	$LOCKER{$key} = $Coro::current;#d#	378	$LOCKER{$key} = $Coro::current;#d#
353		379
354	Coro::guard {	380	Guard::guard {
355	delete $LOCKER{$key};#d#	381	delete $LOCKER{$key};#d#
356	# wake up all waiters, to be on the safe side	382	# wake up all waiters, to be on the safe side
357	$_->ready for @{ delete $LOCK{$key} };	383	$_->ready for @{ delete $LOCK{$key} };
358	}	384	}
359	}	385	}
…		…
365	}	391	}
366		392
367	sub freeze_mainloop {	393	sub freeze_mainloop {
368	tick_inhibit_inc;	394	tick_inhibit_inc;
369		395
370	Coro::guard \&tick_inhibit_dec;	396	&Guard::guard (\&tick_inhibit_dec);
371	}	397	}
372		398
373	=item cf::periodic $interval, $cb	399	=item cf::periodic $interval, $cb
374		400
375	Like EV::periodic, but randomly selects a starting point so that the actions	401	Like EV::periodic, but randomly selects a starting point so that the actions
…		…
727		753
728	#############################################################################	754	#############################################################################
729		755
730	=head2 ATTACHABLE OBJECTS	756	=head2 ATTACHABLE OBJECTS
731		757
732	Many objects in crossfire are so-called attachable objects. That means you can	758	Many objects in deliantra are so-called attachable objects. That means you can
733	attach callbacks/event handlers (a collection of which is called an "attachment")	759	attach callbacks/event handlers (a collection of which is called an "attachment")
734	to it. All such attachable objects support the following methods.	760	to it. All such attachable objects support the following methods.
735		761
736	In the following description, CLASS can be any of C<global>, C<object>	762	In the following description, CLASS can be any of C<global>, C<object>
737	C<player>, C<client> or C<map> (i.e. the attachable objects in	763	C<player>, C<client> or C<map> (i.e. the attachable objects in
…		…
787	=item cf::CLASS::attachment $name, ...	813	=item cf::CLASS::attachment $name, ...
788		814
789	Register an attachment by C<$name> through which attachable objects of the	815	Register an attachment by C<$name> through which attachable objects of the
790	given CLASS can refer to this attachment.	816	given CLASS can refer to this attachment.
791		817
792	Some classes such as crossfire maps and objects can specify attachments	818	Some classes such as deliantra maps and objects can specify attachments
793	that are attached at load/instantiate time, thus the need for a name.	819	that are attached at load/instantiate time, thus the need for a name.
794		820
795	These calls expect any number of the following handler/hook descriptions:	821	These calls expect any number of the following handler/hook descriptions:
796		822
797	=over 4	823	=over 4
…		…
1088		1114
1089	sub reattach {	1115	sub reattach {
1090	# basically do the same as instantiate, without calling instantiate	1116	# basically do the same as instantiate, without calling instantiate
1091	my ($obj) = @_;	1117	my ($obj) = @_;
1092		1118
		1119	# no longer needed after getting rid of delete_package?
1093	bless $obj, ref $obj; # re-bless in case extensions have been reloaded	1120	#bless $obj, ref $obj; # re-bless in case extensions have been reloaded
1094		1121
1095	my $registry = $obj->registry;	1122	my $registry = $obj->registry;
1096		1123
1097	@$registry = ();	1124	@$registry = ();
1098		1125
…		…
1163	} else {	1190	} else {
1164	aio_unlink "$filename.pst";	1191	aio_unlink "$filename.pst";
1165	}	1192	}
1166		1193
1167	aio_rename "$filename~", $filename;	1194	aio_rename "$filename~", $filename;
		1195
		1196	$filename =~ s%/[^/]+$%%;
		1197	aio_pathsync $filename if $cf::USE_FSYNC;
1168	} else {	1198	} else {
1169	warn "FATAL: $filename~: $!\n";	1199	warn "FATAL: $filename~: $!\n";
1170	}	1200	}
1171	} else {	1201	} else {
1172	aio_unlink $filename;	1202	aio_unlink $filename;
…		…
1265	my ($name, $cb) = @_;	1295	my ($name, $cb) = @_;
1266		1296
1267	$EXTICMD{$name} = $cb;	1297	$EXTICMD{$name} = $cb;
1268	}	1298	}
1269		1299
		1300	use File::Glob ();
		1301
1270	cf::player->attach (	1302	cf::player->attach (
1271	on_command => sub {	1303	on_command => sub {
1272	my ($pl, $name, $params) = @_;	1304	my ($pl, $name, $params) = @_;
1273		1305
1274	my $cb = $COMMAND{$name}	1306	my $cb = $COMMAND{$name}
…		…
1306		1338
1307	cf::override;	1339	cf::override;
1308	},	1340	},
1309	);	1341	);
1310		1342
		1343	# "readahead" all extensions
		1344	sub cache_extensions {
		1345	my $grp = IO::AIO::aio_group;
		1346
		1347	add $grp IO::AIO::aio_readdir $LIBDIR, sub {
		1348	for (grep /\.ext$/, @{$_[0]}) {
		1349	add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
		1350	}
		1351	};
		1352
		1353	$grp
		1354	}
		1355
1311	sub load_extensions {	1356	sub load_extensions {
1312	cf::sync_job {	1357	cf::sync_job {
1313	my %todo;	1358	my %todo;
1314		1359
1315	for my $path (<$LIBDIR/*.ext>) {	1360	for my $path (<$LIBDIR/*.ext>) {
…		…
1334		1379
1335	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }	1380	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1336	if $source =~ /\A#!.?perl.?#\s(.)$/m;	1381	if $source =~ /\A#!.?perl.?#\s(.)$/m;
1337		1382
1338	$ext{source} =	1383	$ext{source} =
1339	"package $pkg; use strict; use utf8;\n"	1384	"package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1340	. "#line 1 \"$path\"\n{\n"	1385	. "#line 1 \"$path\"\n{\n"
1341	. $source	1386	. $source
1342	. "\n};\n1";	1387	. "\n};\n1";
1343		1388
1344	$todo{$base} = \%ext;	1389	$todo{$base} = \%ext;
…		…
1384		1429
1385	=back	1430	=back
1386		1431
1387	=head2 CORE EXTENSIONS	1432	=head2 CORE EXTENSIONS
1388		1433
1389	Functions and methods that extend core crossfire objects.	1434	Functions and methods that extend core deliantra objects.
1390		1435
1391	=cut	1436	=cut
1392		1437
1393	package cf::player;	1438	package cf::player;
1394		1439
…		…
1437		1482
1438	sub exists($) {	1483	sub exists($) {
1439	my ($login) = @_;	1484	my ($login) = @_;
1440		1485
1441	$cf::PLAYER{$login}	1486	$cf::PLAYER{$login}
1442	or cf::sync_job { !aio_stat path $login }	1487	or !aio_stat path $login
1443	}	1488	}
1444		1489
1445	sub find($) {	1490	sub find($) {
1446	return $cf::PLAYER{$_[0]} \|\| do {	1491	return $cf::PLAYER{$_[0]} \|\| do {
1447	my $login = $_[0];	1492	my $login = $_[0];
…		…
1522	my ($pl) = @_;	1567	my ($pl) = @_;
1523		1568
1524	my $name = $pl->ob->name;	1569	my $name = $pl->ob->name;
1525		1570
1526	$pl->{deny_save} = 1;	1571	$pl->{deny_save} = 1;
1527	$pl->password ("*"); # this should lock out the player until we nuked the dir	1572	$pl->password ("*"); # this should lock out the player until we have nuked the dir
1528		1573
1529	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;	1574	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1530	$pl->deactivate;	1575	$pl->deactivate;
1531	my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;	1576	my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1532	$pl->ob->check_score;	1577	$pl->ob->check_score;
…		…
1618	}	1663	}
1619		1664
1620	\@paths	1665	\@paths
1621	}	1666	}
1622		1667
1623	=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)	1668	=item $protocol_xml = $player->expand_cfpod ($cfpod)
1624		1669
1625	Expand crossfire pod fragments into protocol xml.	1670	Expand deliantra pod fragments into protocol xml.
1626
1627	=cut
1628
1629	use re 'eval';
1630
1631	my $group;
1632	my $interior; $interior = qr{
1633	# match a pod interior sequence sans C<< >>
1634	(?:
1635	\ (.*?)\ (?{ $group = $^N })
1636	\| < (??{$interior}) >
1637	)
1638	}x;
1639
1640	sub expand_cfpod {
1641	my ($self, $pod) = @_;
1642
1643	my $xml;
1644
1645	while () {
1646	if ($pod =~ /\G( (?: [^BCGHITU]+ \| .(?!<) )+ )/xgcs) {
1647	$group = $1;
1648
1649	$group =~ s/&/&/g;
1650	$group =~ s/</</g;
1651
1652	$xml .= $group;
1653	} elsif ($pod =~ m%\G
1654	([BCGHITU])
1655	<
1656	(?:
1657	([^<>]*) (?{ $group = $^N })
1658	\| < $interior >
1659	)
1660	>
1661	%gcsx
1662	) {
1663	my ($code, $data) = ($1, $group);
1664
1665	if ($code eq "B") {
1666	$xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1667	} elsif ($code eq "I") {
1668	$xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1669	} elsif ($code eq "U") {
1670	$xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1671	} elsif ($code eq "C") {
1672	$xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1673	} elsif ($code eq "T") {
1674	$xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1675	} elsif ($code eq "G") {
1676	my ($male, $female) = split /\\|/, $data;
1677	$data = $self->gender ? $female : $male;
1678	$xml .= expand_cfpod ($self, $data);
1679	} elsif ($code eq "H") {
1680	$xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1681	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1682	"")
1683	[$self->{hintmode}];
1684	} else {
1685	$xml .= "error processing '$code($data)' directive";
1686	}
1687	} else {
1688	if ($pod =~ /\G(.+)/) {
1689	warn "parse error while expanding $pod (at $1)";
1690	}
1691	last;
1692	}
1693	}
1694
1695	for ($xml) {
1696	# create single paragraphs (very hackish)
1697	s/(?<=\S)\n(?=\w)/ /g;
1698
1699	# compress some whitespace
1700	s/\s+\n/\n/g; # ws line-ends
1701	s/\n\n+/\n/g; # double lines
1702	s/^\n+//; # beginning lines
1703	s/\n+$//; # ending lines
1704	}
1705
1706	$xml
1707	}
1708
1709	no re 'eval';
1710
1711	sub hintmode {
1712	$_[0]{hintmode} = $_[1] if @_ > 1;
1713	$_[0]{hintmode}
1714	}
1715		1671
1716	=item $player->ext_reply ($msgid, @msg)	1672	=item $player->ext_reply ($msgid, @msg)
1717		1673
1718	Sends an ext reply to the player.	1674	Sends an ext reply to the player.
1719		1675
…		…
2088	my $f = new_from_file cf::object::thawer $self->{load_path};	2044	my $f = new_from_file cf::object::thawer $self->{load_path};
2089	$f->skip_block;	2045	$f->skip_block;
2090	$self->_load_objects ($f)	2046	$self->_load_objects ($f)
2091	or return;	2047	or return;
2092		2048
2093	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	2049	$self->post_load_original
2094	if delete $self->{load_original};	2050	if delete $self->{load_original};
2095		2051
2096	if (my $uniq = $self->uniq_path) {	2052	if (my $uniq = $self->uniq_path) {
2097	utf8::encode $uniq;	2053	utf8::encode $uniq;
2098	unless (aio_stat $uniq) {	2054	unless (aio_stat $uniq) {
…		…
2533		2489
2534	=item $player_object->enter_link	2490	=item $player_object->enter_link
2535		2491
2536	Freezes the player and moves him/her to a special map (C<{link}>).	2492	Freezes the player and moves him/her to a special map (C<{link}>).
2537		2493
2538	The player should be reasonably safe there for short amounts of time. You	2494	The player should be reasonably safe there for short amounts of time (e.g.
2539	I<MUST> call C<leave_link> as soon as possible, though.	2495	for loading a map). You I<MUST> call C<leave_link> as soon as possible,
		2496	though, as the palyer cannot control the character while it is on the link
		2497	map.
2540		2498
2541	Will never block.	2499	Will never block.
2542		2500
2543	=item $player_object->leave_link ($map, $x, $y)	2501	=item $player_object->leave_link ($map, $x, $y)
2544		2502
…		…
2602		2560
2603	$map->load;	2561	$map->load;
2604	$map->load_neighbours;	2562	$map->load_neighbours;
2605		2563
2606	return unless $self->contr->active;	2564	return unless $self->contr->active;
		2565	$self->flag (cf::FLAG_DEBUG, 0);#d# temp
2607	$self->activate_recursive;	2566	$self->activate_recursive;
2608		2567
2609	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2568	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2610	$self->enter_map ($map, $x, $y);	2569	$self->enter_map ($map, $x, $y);
2611	}	2570	}
…		…
2615	Moves the player to the given map-path and coordinates by first freezing	2574	Moves the player to the given map-path and coordinates by first freezing
2616	her, loading and preparing them map, calling the provided $check callback	2575	her, loading and preparing them map, calling the provided $check callback
2617	that has to return the map if sucecssful, and then unfreezes the player on	2576	that has to return the map if sucecssful, and then unfreezes the player on
2618	the new (success) or old (failed) map position. In either case, $done will	2577	the new (success) or old (failed) map position. In either case, $done will
2619	be called at the end of this process.	2578	be called at the end of this process.
		2579
		2580	Note that $check will be called with a potentially non-loaded map, so if
		2581	it needs a loaded map it has to call C<< ->load >>.
2620		2582
2621	=cut	2583	=cut
2622		2584
2623	our $GOTOGEN;	2585	our $GOTOGEN;
2624		2586
…		…
2771	$self->contr->savebed ($map, $x, $y)	2733	$self->contr->savebed ($map, $x, $y)
2772	if $exit->flag (cf::FLAG_DAMNED);	2734	if $exit->flag (cf::FLAG_DAMNED);
2773		2735
2774	1	2736	1
2775	}) {	2737	}) {
2776	$self->message ("Something went wrong deep within the crossfire server. "	2738	$self->message ("Something went wrong deep within the deliantra server. "
2777	. "I'll try to bring you back to the map you were before. "	2739	. "I'll try to bring you back to the map you were before. "
2778	. "Please report this to the dungeon master!",	2740	. "Please report this to the dungeon master!",
2779	cf::NDI_UNIQUE \| cf::NDI_RED);	2741	cf::NDI_UNIQUE \| cf::NDI_RED);
2780		2742
2781	warn "ERROR in enter_exit: $@";	2743	warn "ERROR in enter_exit: $@";
…		…
2847	id => "infobox",	2809	id => "infobox",
2848	title => "Body Parts",	2810	title => "Body Parts",
2849	reply => undef,	2811	reply => undef,
2850	tooltip => "Shows which body parts you posess and are available",	2812	tooltip => "Shows which body parts you posess and are available",
2851	},	2813	},
		2814	"c/skills" => {
		2815	id => "infobox",
		2816	title => "Skills",
		2817	reply => undef,
		2818	tooltip => "Shows your experience per skill and item power",
		2819	},
2852	"c/uptime" => {	2820	"c/uptime" => {
2853	id => "infobox",	2821	id => "infobox",
2854	title => "Uptime",	2822	title => "Uptime",
2855	reply => undef,	2823	reply => undef,
2856	tooltip => "How long the server has been running since last restart",	2824	tooltip => "How long the server has been running since last restart",
…		…
2870	);	2838	);
2871		2839
2872	sub cf::client::send_msg {	2840	sub cf::client::send_msg {
2873	my ($self, $channel, $msg, $color, @extra) = @_;	2841	my ($self, $channel, $msg, $color, @extra) = @_;
2874		2842
2875	$msg = $self->pl->expand_cfpod ($msg);	2843	$msg = $self->pl->expand_cfpod ($msg)
		2844	unless $color & cf::NDI_VERBATIM;
2876		2845
2877	$color &= cf::NDI_CLIENT_MASK; # just in case...	2846	$color &= cf::NDI_CLIENT_MASK; # just in case...
2878		2847
2879	# check predefined channels, for the benefit of C	2848	# check predefined channels, for the benefit of C
2880	if ($CHANNEL{$channel}) {	2849	if ($CHANNEL{$channel}) {
…		…
2901	if ($self->can_msg) {	2870	if ($self->can_msg) {
2902	# default colour, mask it out	2871	# default colour, mask it out
2903	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)	2872	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
2904	if $color & cf::NDI_DEF;	2873	if $color & cf::NDI_DEF;
2905		2874
2906	$self->send_packet ("msg " . $self->{json_coder}->encode (	2875	my $pkt = "msg "
		2876	. $self->{json_coder}->encode (
2907	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));	2877	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
		2878	);
		2879
		2880	# try lzf for large packets
		2881	$pkt = "lzf " . Compress::LZF::compress $pkt
		2882	if 1024 <= length $pkt and $self->{can_lzf};
		2883
		2884	# split very large packets
		2885	if (8192 < length $pkt and $self->{can_lzf}) {
		2886	$self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
		2887	$pkt = "frag";
		2888	}
		2889
		2890	$self->send_packet ($pkt);
2908	} else {	2891	} else {
2909	if ($color >= 0) {	2892	if ($color >= 0) {
2910	# replace some tags by gcfclient-compatible ones	2893	# replace some tags by gcfclient-compatible ones
2911	for ($msg) {	2894	for ($msg) {
2912	1 while	2895	1 while
…		…
3127	=cut	3110	=cut
3128		3111
3129	for (	3112	for (
3130	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	3113	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3131	insert remove inv nrof name archname title slaying race	3114	insert remove inv nrof name archname title slaying race
3132	decrease split destroy)],	3115	decrease split destroy change_exp)],
3133	["cf::object::player" => qw(player)],	3116	["cf::object::player" => qw(player)],
3134	["cf::player" => qw(peaceful)],	3117	["cf::player" => qw(peaceful)],
3135	["cf::map" => qw(trigger)],	3118	["cf::map" => qw(trigger)],
3136	) {	3119	) {
3137	no strict 'refs';	3120	no strict 'refs';
…		…
3395	reload_treasures;	3378	reload_treasures;
3396		3379
3397	warn "finished reloading resource files\n";	3380	warn "finished reloading resource files\n";
3398	}	3381	}
3399		3382
3400	sub init {
3401	my $guard = freeze_mainloop;
3402
3403	reload_resources;
3404	}
3405
3406	sub reload_config {	3383	sub reload_config {
3407	open my $fh, "<:utf8", "$CONFDIR/config"	3384	open my $fh, "<:utf8", "$CONFDIR/config"
3408	or return;	3385	or return;
3409		3386
3410	local $/;	3387	local $/;
…		…
3422	};	3399	};
3423	warn $@ if $@;	3400	warn $@ if $@;
3424	}	3401	}
3425	}	3402	}
3426		3403
		3404	sub pidfile() {
		3405	sysopen my $fh, $PIDFILE, O_RDWR \| O_CREAT
		3406	or die "$PIDFILE: $!";
		3407	flock $fh, &Fcntl::LOCK_EX
		3408	or die "$PIDFILE: flock: $!";
		3409	$fh
		3410	}
		3411
		3412	# make sure only one server instance is running at any one time
		3413	sub atomic {
		3414	my $fh = pidfile;
		3415
		3416	my $pid = <$fh>;
		3417	kill 9, $pid if $pid > 0;
		3418
		3419	seek $fh, 0, 0;
		3420	print $fh $$;
		3421	}
		3422
3427	sub main {	3423	sub main {
		3424	cf::init_globals; # initialise logging
		3425
		3426	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
		3427	LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
		3428	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
		3429	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
		3430
		3431	cf::init_experience;
		3432	cf::init_anim;
		3433	cf::init_attackmess;
		3434	cf::init_dynamic;
		3435	cf::init_block;
		3436
		3437	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
		3438
3428	# we must not ever block the main coroutine	3439	# we must not ever block the main coroutine
3429	local $Coro::idle = sub {	3440	local $Coro::idle = sub {
3430	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#	3441	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3431	(async {	3442	(async {
3432	$Coro::current->{desc} = "IDLE BUG HANDLER";	3443	$Coro::current->{desc} = "IDLE BUG HANDLER";
3433	EV::loop EV::LOOP_ONESHOT;	3444	EV::loop EV::LOOP_ONESHOT;
3434	})->prio (Coro::PRIO_MAX);	3445	})->prio (Coro::PRIO_MAX);
3435	};	3446	};
3436		3447
3437	{	3448	evthread_start IO::AIO::poll_fileno;
3438	my $guard = freeze_mainloop;	3449
		3450	cf::sync_job {
		3451	reload_resources;
3439	reload_config;	3452	reload_config;
3440	db_init;	3453	db_init;
		3454
		3455	cf::load_settings;
		3456	cf::load_materials;
		3457	cf::init_uuid;
		3458	cf::init_signals;
		3459	cf::init_commands;
		3460	cf::init_skills;
		3461
		3462	cf::init_beforeplay;
		3463
		3464	atomic;
		3465
3441	load_extensions;	3466	load_extensions;
3442		3467
3443	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority	3468	utime time, time, $RUNTIMEFILE;
		3469
		3470	# no (long-running) fork's whatsoever before this point(!)
		3471	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
		3472
		3473	(pop @POST_INIT)->(0) while @POST_INIT;
3444	}	3474	};
3445		3475
3446	EV::loop;	3476	EV::loop;
3447	}	3477	}
3448		3478
3449	#############################################################################	3479	#############################################################################
…		…
3458	};	3488	};
3459	}	3489	}
3460	}	3490	}
3461		3491
3462	sub write_runtime_sync {	3492	sub write_runtime_sync {
3463	my $runtime = "$LOCALDIR/runtime";
3464
3465	# first touch the runtime file to show we are still running:	3493	# first touch the runtime file to show we are still running:
3466	# the fsync below can take a very very long time.	3494	# the fsync below can take a very very long time.
3467		3495
3468	IO::AIO::aio_utime $runtime, undef, undef;	3496	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3469		3497
3470	my $guard = cf::lock_acquire "write_runtime";	3498	my $guard = cf::lock_acquire "write_runtime";
3471		3499
3472	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644	3500	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY \| O_CREAT, 0644
3473	or return;	3501	or return;
3474		3502
3475	my $value = $cf::RUNTIME + 90 + 10;	3503	my $value = $cf::RUNTIME + 90 + 10;
3476	# 10 is the runtime save interval, for a monotonic clock	3504	# 10 is the runtime save interval, for a monotonic clock
3477	# 60 allows for the watchdog to kill the server.	3505	# 60 allows for the watchdog to kill the server.
…		…
3487	aio_utime $fh, undef, undef;	3515	aio_utime $fh, undef, undef;
3488		3516
3489	close $fh	3517	close $fh
3490	or return;	3518	or return;
3491		3519
3492	aio_rename "$runtime~", $runtime	3520	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3493	and return;	3521	and return;
3494		3522
3495	warn "runtime file written.\n";	3523	warn "runtime file written.\n";
3496		3524
3497	1	3525	1
…		…
3509	my $uuid = "$LOCALDIR/uuid";	3537	my $uuid = "$LOCALDIR/uuid";
3510		3538
3511	my $fh = aio_open "$uuid~", O_WRONLY \| O_CREAT, 0644	3539	my $fh = aio_open "$uuid~", O_WRONLY \| O_CREAT, 0644
3512	or return;	3540	or return;
3513		3541
3514	my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;	3542	my $value = uuid_seq uuid_cur;
		3543
		3544	unless ($value) {
		3545	warn "cowardly refusing to write zero uuid value!\n";
		3546	return;
		3547	}
		3548
		3549	my $value = uuid_str $value + $uuid_skip;
3515	$uuid_skip = 0;	3550	$uuid_skip = 0;
3516		3551
3517	(aio_write $fh, 0, (length $value), $value, 0) <= 0	3552	(aio_write $fh, 0, (length $value), $value, 0) <= 0
3518	and return;	3553	and return;
3519		3554
…		…
3541	}	3576	}
3542		3577
3543	sub emergency_save() {	3578	sub emergency_save() {
3544	my $freeze_guard = cf::freeze_mainloop;	3579	my $freeze_guard = cf::freeze_mainloop;
3545		3580
3546	warn "enter emergency perl save\n";	3581	warn "emergency_perl_save: enter\n";
3547		3582
3548	cf::sync_job {	3583	cf::sync_job {
		3584	# this is a trade-off: we want to be very quick here, so
		3585	# save all maps without fsync, and later call a global sync
		3586	# (which in turn might be very very slow)
		3587	local $USE_FSYNC = 0;
		3588
3549	# use a peculiar iteration method to avoid tripping on perl	3589	# use a peculiar iteration method to avoid tripping on perl
3550	# refcount bugs in for. also avoids problems with players	3590	# refcount bugs in for. also avoids problems with players
3551	# and maps saved/destroyed asynchronously.	3591	# and maps saved/destroyed asynchronously.
3552	warn "begin emergency player save\n";	3592	warn "emergency_perl_save: begin player save\n";
3553	for my $login (keys %cf::PLAYER) {	3593	for my $login (keys %cf::PLAYER) {
3554	my $pl = $cf::PLAYER{$login} or next;	3594	my $pl = $cf::PLAYER{$login} or next;
3555	$pl->valid or next;	3595	$pl->valid or next;
3556	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt	3596	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3557	$pl->save;	3597	$pl->save;
3558	}	3598	}
3559	warn "end emergency player save\n";	3599	warn "emergency_perl_save: end player save\n";
3560		3600
3561	warn "begin emergency map save\n";	3601	warn "emergency_perl_save: begin map save\n";
3562	for my $path (keys %cf::MAP) {	3602	for my $path (keys %cf::MAP) {
3563	my $map = $cf::MAP{$path} or next;	3603	my $map = $cf::MAP{$path} or next;
3564	$map->valid or next;	3604	$map->valid or next;
3565	$map->save;	3605	$map->save;
3566	}	3606	}
3567	warn "end emergency map save\n";	3607	warn "emergency_perl_save: end map save\n";
3568		3608
3569	warn "begin emergency database checkpoint\n";	3609	warn "emergency_perl_save: begin database checkpoint\n";
3570	BDB::db_env_txn_checkpoint $DB_ENV;	3610	BDB::db_env_txn_checkpoint $DB_ENV;
3571	warn "end emergency database checkpoint\n";	3611	warn "emergency_perl_save: end database checkpoint\n";
3572		3612
3573	warn "begin write uuid\n";	3613	warn "emergency_perl_save: begin write uuid\n";
3574	write_uuid_sync 1;	3614	write_uuid_sync 1;
3575	warn "end write uuid\n";	3615	warn "emergency_perl_save: end write uuid\n";
3576	};	3616	};
3577		3617
		3618	warn "emergency_perl_save: starting sync()\n";
		3619	IO::AIO::aio_sync sub {
		3620	warn "emergency_perl_save: finished sync()\n";
		3621	};
		3622
3578	warn "leave emergency perl save\n";	3623	warn "emergency_perl_save: leave\n";
3579	}	3624	}
3580		3625
3581	sub post_cleanup {	3626	sub post_cleanup {
3582	my ($make_core) = @_;	3627	my ($make_core) = @_;
3583		3628
3584	warn Carp::longmess "post_cleanup backtrace"	3629	warn Carp::longmess "post_cleanup backtrace"
3585	if $make_core;	3630	if $make_core;
		3631
		3632	my $fh = pidfile;
		3633	unlink $PIDFILE if <$fh> == $$;
		3634	}
		3635
		3636	# a safer delete_package, copied from Symbol
		3637	sub clear_package($) {
		3638	my $pkg = shift;
		3639
		3640	# expand to full symbol table name if needed
		3641	unless ($pkg =~ /^main::.*::$/) {
		3642	$pkg = "main$pkg" if $pkg =~ /^::/;
		3643	$pkg = "main::$pkg" unless $pkg =~ /^main::/;
		3644	$pkg .= '::' unless $pkg =~ /::$/;
		3645	}
		3646
		3647	my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
		3648	my $stem_symtab = *{$stem}{HASH};
		3649
		3650	defined $stem_symtab and exists $stem_symtab->{$leaf}
		3651	or return;
		3652
		3653	# clear all symbols
		3654	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
		3655	for my $name (keys %$leaf_symtab) {
		3656	_gv_clear *{"$pkg$name"};
		3657	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
		3658	}
		3659	warn "cleared package $pkg\n";#d#
3586	}	3660	}
3587		3661
3588	sub do_reload_perl() {	3662	sub do_reload_perl() {
3589	# can/must only be called in main	3663	# can/must only be called in main
3590	if ($Coro::current != $Coro::main) {	3664	if ($Coro::current != $Coro::main) {
3591	warn "can only reload from main coroutine";	3665	warn "can only reload from main coroutine";
3592	return;	3666	return;
3593	}	3667	}
3594		3668
		3669	return if $RELOAD++;
		3670
		3671	my $t1 = EV::time;
		3672
		3673	while ($RELOAD) {
3595	warn "reloading...";	3674	warn "reloading...";
3596		3675
3597	warn "entering sync_job";	3676	warn "entering sync_job";
3598		3677
3599	cf::sync_job {	3678	cf::sync_job {
3600	cf::write_runtime_sync; # external watchdog should not bark	3679	cf::write_runtime_sync; # external watchdog should not bark
3601	cf::emergency_save;	3680	cf::emergency_save;
3602	cf::write_runtime_sync; # external watchdog should not bark	3681	cf::write_runtime_sync; # external watchdog should not bark
3603		3682
3604	warn "syncing database to disk";	3683	warn "syncing database to disk";
3605	BDB::db_env_txn_checkpoint $DB_ENV;	3684	BDB::db_env_txn_checkpoint $DB_ENV;
3606		3685
3607	# if anything goes wrong in here, we should simply crash as we already saved	3686	# if anything goes wrong in here, we should simply crash as we already saved
3608		3687
3609	warn "flushing outstanding aio requests";	3688	warn "flushing outstanding aio requests";
3610	for (;;) {
3611	BDB::flush;
3612	IO::AIO::flush;
3613	Coro::cede_notself;
3614	last unless IO::AIO::nreqs \|\| BDB::nreqs;	3689	while (IO::AIO::nreqs \|\| BDB::nreqs) {
3615	warn "iterate...";	3690	Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3616	}
3617
3618	++$RELOAD;
3619
3620	warn "cancelling all extension coros";
3621	$_->cancel for values %EXT_CORO;
3622	%EXT_CORO = ();
3623
3624	warn "removing commands";
3625	%COMMAND = ();
3626
3627	warn "removing ext/exti commands";
3628	%EXTCMD = ();
3629	%EXTICMD = ();
3630
3631	warn "unloading/nuking all extensions";
3632	for my $pkg (@EXTS) {
3633	warn "... unloading $pkg";
3634
3635	if (my $cb = $pkg->can ("unload")) {
3636	eval {
3637	$cb->($pkg);
3638	1
3639	} or warn "$pkg unloaded, but with errors: $@";
3640	}	3691	}
3641		3692
3642	warn "... nuking $pkg";	3693	warn "cancelling all extension coros";
3643	Symbol::delete_package $pkg;	3694	$_->cancel for values %EXT_CORO;
3644	}	3695	%EXT_CORO = ();
3645		3696
3646	warn "unloading all perl modules loaded from $LIBDIR";	3697	warn "removing commands";
3647	while (my ($k, $v) = each %INC) {	3698	%COMMAND = ();
3648	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3649		3699
		3700	warn "removing ext/exti commands";
		3701	%EXTCMD = ();
		3702	%EXTICMD = ();
		3703
		3704	warn "unloading/nuking all extensions";
		3705	for my $pkg (@EXTS) {
3650	warn "... unloading $k";	3706	warn "... unloading $pkg";
3651	delete $INC{$k};
3652		3707
3653	$k =~ s/\.pm$//;
3654	$k =~ s/\//::/g;
3655
3656	if (my $cb = $k->can ("unload_module")) {	3708	if (my $cb = $pkg->can ("unload")) {
		3709	eval {
3657	$cb->();	3710	$cb->($pkg);
		3711	1
		3712	} or warn "$pkg unloaded, but with errors: $@";
		3713	}
		3714
		3715	warn "... clearing $pkg";
		3716	clear_package $pkg;
3658	}	3717	}
3659		3718
3660	Symbol::delete_package $k;	3719	warn "unloading all perl modules loaded from $LIBDIR";
		3720	while (my ($k, $v) = each %INC) {
		3721	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
		3722
		3723	warn "... unloading $k";
		3724	delete $INC{$k};
		3725
		3726	$k =~ s/\.pm$//;
		3727	$k =~ s/\//::/g;
		3728
		3729	if (my $cb = $k->can ("unload_module")) {
		3730	$cb->();
		3731	}
		3732
		3733	clear_package $k;
3661	}	3734	}
3662		3735
3663	warn "getting rid of safe::, as good as possible";	3736	warn "getting rid of safe::, as good as possible";
3664	Symbol::delete_package "safe::$_"	3737	clear_package "safe::$_"
3665	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	3738	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3666		3739
3667	warn "unloading cf.pm \"a bit\"";	3740	warn "unloading cf.pm \"a bit\"";
3668	delete $INC{"cf.pm"};	3741	delete $INC{"cf.pm"};
3669	delete $INC{"cf/pod.pm"};	3742	delete $INC{"cf/pod.pm"};
3670		3743
3671	# don't, removes xs symbols, too,	3744	# don't, removes xs symbols, too,
3672	# and global variables created in xs	3745	# and global variables created in xs
3673	#Symbol::delete_package __PACKAGE__;	3746	#clear_package __PACKAGE__;
3674		3747
3675	warn "unload completed, starting to reload now";	3748	warn "unload completed, starting to reload now";
3676		3749
3677	warn "reloading cf.pm";	3750	warn "reloading cf.pm";
3678	require cf;	3751	require cf;
3679	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3752	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3680		3753
3681	warn "loading config and database again";	3754	warn "loading config and database again";
3682	cf::reload_config;	3755	cf::reload_config;
3683		3756
3684	warn "loading extensions";	3757	warn "loading extensions";
3685	cf::load_extensions;	3758	cf::load_extensions;
3686		3759
		3760	if ($REATTACH_ON_RELOAD) {
3687	warn "reattaching attachments to objects/players";	3761	warn "reattaching attachments to objects/players";
3688	_global_reattach; # objects, sockets	3762	_global_reattach; # objects, sockets
3689	warn "reattaching attachments to maps";	3763	warn "reattaching attachments to maps";
3690	reattach $_ for values %MAP;	3764	reattach $_ for values %MAP;
3691	warn "reattaching attachments to players";	3765	warn "reattaching attachments to players";
3692	reattach $_ for values %PLAYER;	3766	reattach $_ for values %PLAYER;
		3767	}
3693		3768
		3769	warn "running post_init jobs";
		3770	(pop @POST_INIT)->(1) while @POST_INIT;
		3771
3694	warn "leaving sync_job";	3772	warn "leaving sync_job";
3695		3773
3696	1	3774	1
3697	} or do {	3775	} or do {
3698	warn $@;	3776	warn $@;
3699	cf::cleanup "error while reloading, exiting.";	3777	cf::cleanup "error while reloading, exiting.";
3700	};	3778	};
3701		3779
3702	warn "reloaded";	3780	warn "reloaded";
		3781	--$RELOAD;
		3782	}
		3783
		3784	$t1 = EV::time - $t1;
		3785	warn "reload completed in ${t1}s\n";
3703	};	3786	};
3704		3787
3705	our $RELOAD_WATCHER; # used only during reload	3788	our $RELOAD_WATCHER; # used only during reload
3706		3789
3707	sub reload_perl() {	3790	sub reload_perl() {
3708	# doing reload synchronously and two reloads happen back-to-back,	3791	# doing reload synchronously and two reloads happen back-to-back,
3709	# coro crashes during coro_state_free->destroy here.	3792	# coro crashes during coro_state_free->destroy here.
3710		3793
		3794	$RELOAD_WATCHER \|\|= cf::async {
		3795	Coro::AIO::aio_wait cache_extensions;
		3796
3711	$RELOAD_WATCHER \|\|= EV::timer 0, 0, sub {	3797	$RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3712	do_reload_perl;	3798	do_reload_perl;
3713	undef $RELOAD_WATCHER;	3799	undef $RELOAD_WATCHER;
		3800	};
3714	};	3801	};
3715	}	3802	}
3716		3803
3717	register_command "reload" => sub {	3804	register_command "reload" => sub {
3718	my ($who, $arg) = @_;	3805	my ($who, $arg) = @_;
…		…
3793	BDB::max_poll_reqs $TICK * 0.1;	3880	BDB::max_poll_reqs $TICK * 0.1;
3794	$AnyEvent::BDB::WATCHER->priority (1);	3881	$AnyEvent::BDB::WATCHER->priority (1);
3795		3882
3796	unless ($DB_ENV) {	3883	unless ($DB_ENV) {
3797	$DB_ENV = BDB::db_env_create;	3884	$DB_ENV = BDB::db_env_create;
3798	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC	3885	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT);
3799	\| BDB::LOG_AUTOREMOVE, 1);	3886	$DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
		3887	$DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3800	$DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);	3888	$DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3801	$DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);	3889	$DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3802		3890
3803	cf::sync_job {	3891	cf::sync_job {
3804	eval {	3892	eval {
…		…
3830	{	3918	{
3831	# configure IO::AIO	3919	# configure IO::AIO
3832		3920
3833	IO::AIO::min_parallel 8;	3921	IO::AIO::min_parallel 8;
3834	IO::AIO::max_poll_time $TICK * 0.1;	3922	IO::AIO::max_poll_time $TICK * 0.1;
3835	#undef $AnyEvent::AIO::WATCHER;	3923	undef $AnyEvent::AIO::WATCHER;
3836	}	3924	}
3837		3925
3838	my $_log_backtrace;	3926	my $_log_backtrace;
3839		3927
3840	sub _log_backtrace {	3928	sub _log_backtrace {
…		…
3843	$msg =~ s/\n//;	3931	$msg =~ s/\n//;
3844		3932
3845	# limit the # of concurrent backtraces	3933	# limit the # of concurrent backtraces
3846	if ($_log_backtrace < 2) {	3934	if ($_log_backtrace < 2) {
3847	++$_log_backtrace;	3935	++$_log_backtrace;
		3936	my $perl_bt = Carp::longmess $msg;
3848	async {	3937	async {
3849	$Coro::current->{desc} = "abt $msg";	3938	$Coro::current->{desc} = "abt $msg";
3850		3939
3851	my @bt = fork_call {	3940	my @bt = fork_call {
3852	@addr = map { sprintf "%x", $_ } @addr;	3941	@addr = map { sprintf "%x", $_ } @addr;
…		…
3863	}	3952	}
3864		3953
3865	@funcs	3954	@funcs
3866	};	3955	};
3867		3956
3868	LOG llevInfo, "[ABT] $msg\n";	3957	LOG llevInfo, "[ABT] $perl_bt\n";
		3958	LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3869	LOG llevInfo, "[ABT] $_\n" for @bt;	3959	LOG llevInfo, "[ABT] $_\n" for @bt;
3870	--$_log_backtrace;	3960	--$_log_backtrace;
3871	};	3961	};
3872	} else {	3962	} else {
3873	LOG llevInfo, "[ABT] $msg\n";	3963	LOG llevInfo, "[ABT] $msg\n";
…		…
3878	# load additional modules	3968	# load additional modules
3879	use cf::pod;	3969	use cf::pod;
3880		3970
3881	END { cf::emergency_save }	3971	END { cf::emergency_save }
3882		3972
3883	evthread_start IO::AIO::poll_fileno;
3884
3885	1	3973	1
3886		3974

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.434 by root, Thu May 29 03:27:37 2008 UTC vs. Revision 1.458 by root, Sat Dec 13 20:34:37 2008 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.434 by root, Thu May 29 03:27:37 2008 UTC vs.
Revision 1.458 by root, Sat Dec 13 20:34:37 2008 UTC