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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.426 by root, Thu Apr 24 04:40:31 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 3.2;	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 4.50 ();	38	use Coro ();
37	use Coro::State;	39	use Coro::State;
38	use Coro::Handle;	40	use Coro::Handle;
39	use Coro::EV;	41	use Coro::EV;
		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;
		46	use Coro::AnyEvent;
43	use Coro::AIO;	47	use Coro::AIO;
44	use Coro::BDB;	48	use Coro::BDB 1.6;
45	use Coro::Storable;	49	use Coro::Storable;
46	use Coro::Util ();	50	use Coro::Util ();
47		51
48	use JSON::XS 2.01 ();	52	use JSON::XS 2.01 ();
49	use BDB ();	53	use BDB ();
50	use Data::Dumper;	54	use Data::Dumper;
51	use Digest::MD5;	55	use Digest::MD5;
52	use Fcntl;	56	use Fcntl;
53	use YAML ();	57	use YAML ();
54	use IO::AIO 2.51 ();	58	use IO::AIO ();
55	use Time::HiRes;	59	use Time::HiRes;
56	use Compress::LZF;	60	use Compress::LZF;
57	use Digest::MD5 ();	61	use Digest::MD5 ();
		62
		63	AnyEvent::detect;
58		64
59	# configure various modules to our taste	65	# configure various modules to our taste
60	#	66	#
61	$Storable::canonical = 1; # reduce rsync transfers	67	$Storable::canonical = 1; # reduce rsync transfers
62	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";
63	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
64
65	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
66		75
67	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	76	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
68		77
69	our %COMMAND = ();	78	our %COMMAND = ();
70	our %COMMAND_TIME = ();	79	our %COMMAND_TIME = ();
…		…
73	our %EXTCMD = ();	82	our %EXTCMD = ();
74	our %EXTICMD = ();	83	our %EXTICMD = ();
75	our %EXT_CORO = (); # coroutines bound to extensions	84	our %EXT_CORO = (); # coroutines bound to extensions
76	our %EXT_MAP = (); # pluggable maps	85	our %EXT_MAP = (); # pluggable maps
77		86
78	our $RELOAD; # number of reloads so far	87	our $RELOAD; # number of reloads so far, non-zero while in reload
79	our @EVENT;	88	our @EVENT;
80		89
81	our $CONFDIR = confdir;	90	our $CONFDIR = confdir;
82	our $DATADIR = datadir;	91	our $DATADIR = datadir;
83	our $LIBDIR = "$DATADIR/ext";	92	our $LIBDIR = "$DATADIR/ext";
84	our $PODDIR = "$DATADIR/pod";	93	our $PODDIR = "$DATADIR/pod";
85	our $MAPDIR = "$DATADIR/" . mapdir;	94	our $MAPDIR = "$DATADIR/" . mapdir;
86	our $LOCALDIR = localdir;	95	our $LOCALDIR = localdir;
87	our $TMPDIR = "$LOCALDIR/" . tmpdir;	96	our $TMPDIR = "$LOCALDIR/" . tmpdir;
88	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;	97	our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
89	our $PLAYERDIR = "$LOCALDIR/" . playerdir;	98	our $PLAYERDIR = "$LOCALDIR/" . playerdir;
90	our $RANDOMDIR = "$LOCALDIR/random";	99	our $RANDOMDIR = "$LOCALDIR/random";
91	our $BDBDIR = "$LOCALDIR/db";	100	our $BDBDIR = "$LOCALDIR/db";
		101	our $PIDFILE = "$LOCALDIR/pid";
		102	our $RUNTIMEFILE = "$LOCALDIR/runtime";
		103
92	our %RESOURCE;	104	our %RESOURCE;
93		105
94	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	106	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
95	our $AIO_POLL_WATCHER;
96	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	107	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
97	our $NEXT_TICK;	108	our $NEXT_TICK;
98	our $USE_FSYNC = 1; # use fsync to write maps - default off	109	our $USE_FSYNC = 1; # use fsync to write maps - default off
99		110
100	our $BDB_POLL_WATCHER;
101	our $BDB_DEADLOCK_WATCHER;	111	our $BDB_DEADLOCK_WATCHER;
102	our $BDB_CHECKPOINT_WATCHER;	112	our $BDB_CHECKPOINT_WATCHER;
103	our $BDB_TRICKLE_WATCHER;	113	our $BDB_TRICKLE_WATCHER;
104	our $DB_ENV;	114	our $DB_ENV;
105		115
…		…
119	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)
120	our $LOADAVG; # same thing, but with alpha-smoothing	130	our $LOADAVG; # same thing, but with alpha-smoothing
121	our $JITTER; # average jitter	131	our $JITTER; # average jitter
122	our $TICK_START; # for load detecting purposes	132	our $TICK_START; # for load detecting purposes
123		133
		134	our @POST_INIT;
		135
		136	our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow)
		137
124	binmode STDOUT;	138	binmode STDOUT;
125	binmode STDERR;	139	binmode STDERR;
126		140
127	# read virtual server time, if available	141	# read virtual server time, if available
128	unless ($RUNTIME \|\| !-e "$LOCALDIR/runtime") {	142	unless ($RUNTIME \|\| !-e $RUNTIMEFILE) {
129	open my $fh, "<", "$LOCALDIR/runtime"	143	open my $fh, "<", $RUNTIMEFILE
130	or die "unable to read runtime file: $!";	144	or die "unable to read $RUNTIMEFILE file: $!";
131	$RUNTIME = <$fh> + 0.;	145	$RUNTIME = <$fh> + 0.;
132	}	146	}
133		147
134	mkdir $_	148	mkdir $_
135	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;	149	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
…		…
242	for my $pkg (qw(	256	for my $pkg (qw(
243	cf::global cf::attachable	257	cf::global cf::attachable
244	cf::object cf::object::player	258	cf::object cf::object::player
245	cf::client cf::player	259	cf::client cf::player
246	cf::arch cf::living	260	cf::arch cf::living
		261	cf::map cf::mapspace
247	cf::map cf::party cf::region	262	cf::party cf::region
248	)) {	263	)) {
249	no strict 'refs';
250	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	264	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
251	}	265	}
252		266
253	$EV::DIED = sub {	267	$EV::DIED = sub {
254	warn "error in event callback: @_";	268	warn "error in event callback: @_";
…		…
296	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
297		311
298	sub encode_json($) { $json_coder->encode ($_[0]) }	312	sub encode_json($) { $json_coder->encode ($_[0]) }
299	sub decode_json($) { $json_coder->decode ($_[0]) }	313	sub decode_json($) { $json_coder->decode ($_[0]) }
300		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
301	=item cf::lock_wait $string	329	=item cf::lock_wait $string
302		330
303	Wait until the given lock is available. See cf::lock_acquire.	331	Wait until the given lock is available. See cf::lock_acquire.
304		332
305	=item my $lock = cf::lock_acquire $string	333	=item my $lock = cf::lock_acquire $string
306		334
307	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
308	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,
309	for example when the coroutine gets canceled), the lock is automatically	337	for example when the coroutine gets canceled), the lock is automatically
310	returned.	338	returned.
311		339
312	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
313	deadlocked coro.	341	deadlocked coro.
…		…
332	return;#d#	360	return;#d#
333	}#d#	361	}#d#
334		362
335	# wait for lock, if any	363	# wait for lock, if any
336	while ($LOCK{$key}) {	364	while ($LOCK{$key}) {
		365	#local $Coro::current->{desc} = "$Coro::current->{desc} <waiting for lock $key>";
337	push @{ $LOCK{$key} }, $Coro::current;	366	push @{ $LOCK{$key} }, $Coro::current;
338	Coro::schedule;	367	Coro::schedule;
339	}	368	}
340	}	369	}
341		370
…		…
346	lock_wait $key;	375	lock_wait $key;
347		376
348	$LOCK{$key} = [];	377	$LOCK{$key} = [];
349	$LOCKER{$key} = $Coro::current;#d#	378	$LOCKER{$key} = $Coro::current;#d#
350		379
351	Coro::guard {	380	Guard::guard {
352	delete $LOCKER{$key};#d#	381	delete $LOCKER{$key};#d#
353	# wake up all waiters, to be on the safe side	382	# wake up all waiters, to be on the safe side
354	$_->ready for @{ delete $LOCK{$key} };	383	$_->ready for @{ delete $LOCK{$key} };
355	}	384	}
356	}	385	}
…		…
362	}	391	}
363		392
364	sub freeze_mainloop {	393	sub freeze_mainloop {
365	tick_inhibit_inc;	394	tick_inhibit_inc;
366		395
367	Coro::guard \&tick_inhibit_dec;	396	&Guard::guard (\&tick_inhibit_dec);
368	}	397	}
369		398
370	=item cf::periodic $interval, $cb	399	=item cf::periodic $interval, $cb
371		400
372	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
…		…
724		753
725	#############################################################################	754	#############################################################################
726		755
727	=head2 ATTACHABLE OBJECTS	756	=head2 ATTACHABLE OBJECTS
728		757
729	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
730	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")
731	to it. All such attachable objects support the following methods.	760	to it. All such attachable objects support the following methods.
732		761
733	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>
734	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
…		…
784	=item cf::CLASS::attachment $name, ...	813	=item cf::CLASS::attachment $name, ...
785		814
786	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
787	given CLASS can refer to this attachment.	816	given CLASS can refer to this attachment.
788		817
789	Some classes such as crossfire maps and objects can specify attachments	818	Some classes such as deliantra maps and objects can specify attachments
790	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.
791		820
792	These calls expect any number of the following handler/hook descriptions:	821	These calls expect any number of the following handler/hook descriptions:
793		822
794	=over 4	823	=over 4
…		…
1085		1114
1086	sub reattach {	1115	sub reattach {
1087	# basically do the same as instantiate, without calling instantiate	1116	# basically do the same as instantiate, without calling instantiate
1088	my ($obj) = @_;	1117	my ($obj) = @_;
1089		1118
		1119	# no longer needed after getting rid of delete_package?
1090	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
1091		1121
1092	my $registry = $obj->registry;	1122	my $registry = $obj->registry;
1093		1123
1094	@$registry = ();	1124	@$registry = ();
1095		1125
…		…
1141	utf8::decode (my $decname = $filename);	1171	utf8::decode (my $decname = $filename);
1142	warn sprintf "saving %s (%d,%d)\n",	1172	warn sprintf "saving %s (%d,%d)\n",
1143	$decname, length $$rdata, scalar @$objs;	1173	$decname, length $$rdata, scalar @$objs;
1144		1174
1145	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {	1175	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {
1146	chmod SAVE_MODE, $fh;	1176	aio_chmod $fh, SAVE_MODE;
1147	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1177	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1148	aio_fsync $fh if $cf::USE_FSYNC;	1178	aio_fsync $fh if $cf::USE_FSYNC;
1149	close $fh;	1179	aio_close $fh;
1150		1180
1151	if (@$objs) {	1181	if (@$objs) {
1152	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {	1182	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {
1153	chmod SAVE_MODE, $fh;	1183	aio_chmod $fh, SAVE_MODE;
1154	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };	1184	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1155	aio_write $fh, 0, (length $data), $data, 0;	1185	aio_write $fh, 0, (length $data), $data, 0;
1156	aio_fsync $fh if $cf::USE_FSYNC;	1186	aio_fsync $fh if $cf::USE_FSYNC;
1157	close $fh;	1187	aio_close $fh;
1158	aio_rename "$filename.pst~", "$filename.pst";	1188	aio_rename "$filename.pst~", "$filename.pst";
1159	}	1189	}
1160	} else {	1190	} else {
1161	aio_unlink "$filename.pst";	1191	aio_unlink "$filename.pst";
1162	}	1192	}
1163		1193
1164	aio_rename "$filename~", $filename;	1194	aio_rename "$filename~", $filename;
		1195
		1196	$filename =~ s%/[^/]+$%%;
		1197	aio_pathsync $filename if $cf::USE_FSYNC;
1165	} else {	1198	} else {
1166	warn "FATAL: $filename~: $!\n";	1199	warn "FATAL: $filename~: $!\n";
1167	}	1200	}
1168	} else {	1201	} else {
1169	aio_unlink $filename;	1202	aio_unlink $filename;
…		…
1262	my ($name, $cb) = @_;	1295	my ($name, $cb) = @_;
1263		1296
1264	$EXTICMD{$name} = $cb;	1297	$EXTICMD{$name} = $cb;
1265	}	1298	}
1266		1299
		1300	use File::Glob ();
		1301
1267	cf::player->attach (	1302	cf::player->attach (
1268	on_command => sub {	1303	on_command => sub {
1269	my ($pl, $name, $params) = @_;	1304	my ($pl, $name, $params) = @_;
1270		1305
1271	my $cb = $COMMAND{$name}	1306	my $cb = $COMMAND{$name}
…		…
1303		1338
1304	cf::override;	1339	cf::override;
1305	},	1340	},
1306	);	1341	);
1307		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
1308	sub load_extensions {	1356	sub load_extensions {
1309	cf::sync_job {	1357	cf::sync_job {
1310	my %todo;	1358	my %todo;
1311		1359
1312	for my $path (<$LIBDIR/*.ext>) {	1360	for my $path (<$LIBDIR/*.ext>) {
…		…
1331		1379
1332	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }	1380	$ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1333	if $source =~ /\A#!.?perl.?#\s(.)$/m;	1381	if $source =~ /\A#!.?perl.?#\s(.)$/m;
1334		1382
1335	$ext{source} =	1383	$ext{source} =
1336	"package $pkg; use strict; use utf8;\n"	1384	"package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1337	. "#line 1 \"$path\"\n{\n"	1385	. "#line 1 \"$path\"\n{\n"
1338	. $source	1386	. $source
1339	. "\n};\n1";	1387	. "\n};\n1";
1340		1388
1341	$todo{$base} = \%ext;	1389	$todo{$base} = \%ext;
…		…
1381		1429
1382	=back	1430	=back
1383		1431
1384	=head2 CORE EXTENSIONS	1432	=head2 CORE EXTENSIONS
1385		1433
1386	Functions and methods that extend core crossfire objects.	1434	Functions and methods that extend core deliantra objects.
1387		1435
1388	=cut	1436	=cut
1389		1437
1390	package cf::player;	1438	package cf::player;
1391		1439
…		…
1434		1482
1435	sub exists($) {	1483	sub exists($) {
1436	my ($login) = @_;	1484	my ($login) = @_;
1437		1485
1438	$cf::PLAYER{$login}	1486	$cf::PLAYER{$login}
1439	or cf::sync_job { !aio_stat path $login }	1487	or !aio_stat path $login
1440	}	1488	}
1441		1489
1442	sub find($) {	1490	sub find($) {
1443	return $cf::PLAYER{$_[0]} \|\| do {	1491	return $cf::PLAYER{$_[0]} \|\| do {
1444	my $login = $_[0];	1492	my $login = $_[0];
…		…
1456	my $f = new_from_file cf::object::thawer path $login	1504	my $f = new_from_file cf::object::thawer path $login
1457	or return;	1505	or return;
1458		1506
1459	my $pl = cf::player::load_pl $f	1507	my $pl = cf::player::load_pl $f
1460	or return;	1508	or return;
		1509
1461	local $cf::PLAYER_LOADING{$login} = $pl;	1510	local $cf::PLAYER_LOADING{$login} = $pl;
1462	$f->resolve_delayed_derefs;	1511	$f->resolve_delayed_derefs;
1463	$cf::PLAYER{$login} = $pl	1512	$cf::PLAYER{$login} = $pl
1464	}	1513	}
1465	}	1514	}
…		…
1518	my ($pl) = @_;	1567	my ($pl) = @_;
1519		1568
1520	my $name = $pl->ob->name;	1569	my $name = $pl->ob->name;
1521		1570
1522	$pl->{deny_save} = 1;	1571	$pl->{deny_save} = 1;
1523	$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
1524		1573
1525	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;	1574	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1526	$pl->deactivate;	1575	$pl->deactivate;
		1576	my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
		1577	$pl->ob->check_score;
1527	$pl->invoke (cf::EVENT_PLAYER_QUIT);	1578	$pl->invoke (cf::EVENT_PLAYER_QUIT);
1528	$pl->ns->destroy if $pl->ns;	1579	$pl->ns->destroy if $pl->ns;
1529		1580
1530	my $path = playerdir $pl;	1581	my $path = playerdir $pl;
1531	my $temp = "$path~$cf::RUNTIME~deleting~";	1582	my $temp = "$path~$cf::RUNTIME~deleting~";
…		…
1570		1621
1571	for my $login (@$dirs) {	1622	for my $login (@$dirs) {
1572	my $path = path $login;	1623	my $path = path $login;
1573		1624
1574	# a .pst is a dead give-away for a valid player	1625	# a .pst is a dead give-away for a valid player
1575	unless (-e "$path.pst") {	1626	# if no pst file found, open and chekc for blocked users
		1627	if (aio_stat "$path.pst") {
1576	my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;	1628	my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1577	aio_read $fh, 0, 512, my $buf, 0 or next;	1629	aio_read $fh, 0, 512, my $buf, 0 or next;
1578	$buf !~ /^password -------------$/m or next; # official not-valid tag	1630	$buf !~ /^password -------------$/m or next; # official not-valid tag
1579	}	1631	}
1580		1632
…		…
1611	}	1663	}
1612		1664
1613	\@paths	1665	\@paths
1614	}	1666	}
1615		1667
1616	=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)	1668	=item $protocol_xml = $player->expand_cfpod ($cfpod)
1617		1669
1618	Expand crossfire pod fragments into protocol xml.	1670	Expand deliantra pod fragments into protocol xml.
1619
1620	=cut
1621
1622	use re 'eval';
1623
1624	my $group;
1625	my $interior; $interior = qr{
1626	# match a pod interior sequence sans C<< >>
1627	(?:
1628	\ (.*?)\ (?{ $group = $^N })
1629	\| < (??{$interior}) >
1630	)
1631	}x;
1632
1633	sub expand_cfpod {
1634	my ($self, $pod) = @_;
1635
1636	my $xml;
1637
1638	while () {
1639	if ($pod =~ /\G( (?: [^BCGHITU]+ \| .(?!<) )+ )/xgcs) {
1640	$group = $1;
1641
1642	$group =~ s/&/&/g;
1643	$group =~ s/</</g;
1644
1645	$xml .= $group;
1646	} elsif ($pod =~ m%\G
1647	([BCGHITU])
1648	<
1649	(?:
1650	([^<>]*) (?{ $group = $^N })
1651	\| < $interior >
1652	)
1653	>
1654	%gcsx
1655	) {
1656	my ($code, $data) = ($1, $group);
1657
1658	if ($code eq "B") {
1659	$xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1660	} elsif ($code eq "I") {
1661	$xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1662	} elsif ($code eq "U") {
1663	$xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1664	} elsif ($code eq "C") {
1665	$xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1666	} elsif ($code eq "T") {
1667	$xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1668	} elsif ($code eq "G") {
1669	my ($male, $female) = split /\\|/, $data;
1670	$data = $self->gender ? $female : $male;
1671	$xml .= expand_cfpod ($self, $data);
1672	} elsif ($code eq "H") {
1673	$xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1674	"<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1675	"")
1676	[$self->{hintmode}];
1677	} else {
1678	$xml .= "error processing '$code($data)' directive";
1679	}
1680	} else {
1681	if ($pod =~ /\G(.+)/) {
1682	warn "parse error while expanding $pod (at $1)";
1683	}
1684	last;
1685	}
1686	}
1687
1688	for ($xml) {
1689	# create single paragraphs (very hackish)
1690	s/(?<=\S)\n(?=\w)/ /g;
1691
1692	# compress some whitespace
1693	s/\s+\n/\n/g; # ws line-ends
1694	s/\n\n+/\n/g; # double lines
1695	s/^\n+//; # beginning lines
1696	s/\n+$//; # ending lines
1697	}
1698
1699	$xml
1700	}
1701
1702	no re 'eval';
1703
1704	sub hintmode {
1705	$_[0]{hintmode} = $_[1] if @_ > 1;
1706	$_[0]{hintmode}
1707	}
1708		1671
1709	=item $player->ext_reply ($msgid, @msg)	1672	=item $player->ext_reply ($msgid, @msg)
1710		1673
1711	Sends an ext reply to the player.	1674	Sends an ext reply to the player.
1712		1675
…		…
2029		1992
2030	cf::lock_wait "map_data:$path";#d#remove	1993	cf::lock_wait "map_data:$path";#d#remove
2031	cf::lock_wait "map_find:$path";	1994	cf::lock_wait "map_find:$path";
2032		1995
2033	$cf::MAP{$path} \|\| do {	1996	$cf::MAP{$path} \|\| do {
2034	my $guard1 = cf::lock_acquire "map_find:$path";
2035	my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it	1997	my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
		1998	my $guard2 = cf::lock_acquire "map_find:$path";
2036		1999
2037	my $map = new_from_path cf::map $path	2000	my $map = new_from_path cf::map $path
2038	or return;	2001	or return;
2039		2002
2040	$map->{last_save} = $cf::RUNTIME;	2003	$map->{last_save} = $cf::RUNTIME;
…		…
2043	or return;	2006	or return;
2044		2007
2045	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)	2008	if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2046	# doing this can freeze the server in a sync job, obviously	2009	# doing this can freeze the server in a sync job, obviously
2047	#$cf::WAIT_FOR_TICK->wait;	2010	#$cf::WAIT_FOR_TICK->wait;
		2011	undef $guard2;
2048	undef $guard1;	2012	undef $guard1;
2049	undef $guard2;
2050	$map->reset;	2013	$map->reset;
2051	return find $path;	2014	return find $path;
2052	}	2015	}
2053		2016
2054	$cf::MAP{$path} = $map	2017	$cf::MAP{$path} = $map
…		…
2081	my $f = new_from_file cf::object::thawer $self->{load_path};	2044	my $f = new_from_file cf::object::thawer $self->{load_path};
2082	$f->skip_block;	2045	$f->skip_block;
2083	$self->_load_objects ($f)	2046	$self->_load_objects ($f)
2084	or return;	2047	or return;
2085		2048
2086	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	2049	$self->post_load_original
2087	if delete $self->{load_original};	2050	if delete $self->{load_original};
2088		2051
2089	if (my $uniq = $self->uniq_path) {	2052	if (my $uniq = $self->uniq_path) {
2090	utf8::encode $uniq;	2053	utf8::encode $uniq;
2091	unless (aio_stat $uniq) {	2054	unless (aio_stat $uniq) {
…		…
2457	can be C<undef>. Does the right thing when the player is currently in a	2420	can be C<undef>. Does the right thing when the player is currently in a
2458	dialogue with the given NPC character.	2421	dialogue with the given NPC character.
2459		2422
2460	=cut	2423	=cut
2461		2424
		2425	our $SAY_CHANNEL = {
		2426	id => "say",
		2427	title => "Map",
		2428	reply => "say ",
		2429	tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
		2430	};
		2431
		2432	our $CHAT_CHANNEL = {
		2433	id => "chat",
		2434	title => "Chat",
		2435	reply => "chat ",
		2436	tooltip => "Player chat and shouts, global to the server.",
		2437	};
		2438
2462	# rough implementation of a future "reply" method that works	2439	# rough implementation of a future "reply" method that works
2463	# with dialog boxes.	2440	# with dialog boxes.
2464	#TODO: the first argument must go, split into a $npc->reply_to ( method	2441	#TODO: the first argument must go, split into a $npc->reply_to ( method
2465	sub cf::object::player::reply($$$;$) {	2442	sub cf::object::player::reply($$$;$) {
2466	my ($self, $npc, $msg, $flags) = @_;	2443	my ($self, $npc, $msg, $flags) = @_;
…		…
2477	my $dialog = $pl->{npc_dialog};	2454	my $dialog = $pl->{npc_dialog};
2478	$dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));	2455	$dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2479		2456
2480	} else {	2457	} else {
2481	$msg = $npc->name . " says: $msg" if $npc;	2458	$msg = $npc->name . " says: $msg" if $npc;
2482	$self->message ($msg, $flags);	2459	$self->send_msg ($SAY_CHANNEL => $msg, $flags);
2483	}	2460	}
2484	}	2461	}
2485	}	2462	}
2486		2463
2487	=item $object->send_msg ($channel, $msg, $color, [extra...])	2464	=item $object->send_msg ($channel, $msg, $color, [extra...])
…		…
2512		2489
2513	=item $player_object->enter_link	2490	=item $player_object->enter_link
2514		2491
2515	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}>).
2516		2493
2517	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.
2518	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.
2519		2498
2520	Will never block.	2499	Will never block.
2521		2500
2522	=item $player_object->leave_link ($map, $x, $y)	2501	=item $player_object->leave_link ($map, $x, $y)
2523		2502
…		…
2581		2560
2582	$map->load;	2561	$map->load;
2583	$map->load_neighbours;	2562	$map->load_neighbours;
2584		2563
2585	return unless $self->contr->active;	2564	return unless $self->contr->active;
		2565	$self->flag (cf::FLAG_DEBUG, 0);#d# temp
2586	$self->activate_recursive;	2566	$self->activate_recursive;
2587		2567
2588	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2568	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2589	$self->enter_map ($map, $x, $y);	2569	$self->enter_map ($map, $x, $y);
2590	}	2570	}
…		…
2594	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
2595	her, loading and preparing them map, calling the provided $check callback	2575	her, loading and preparing them map, calling the provided $check callback
2596	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
2597	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
2598	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 >>.
2599		2582
2600	=cut	2583	=cut
2601		2584
2602	our $GOTOGEN;	2585	our $GOTOGEN;
2603		2586
…		…
2682	}	2665	}
2683		2666
2684	sub prepare_random_map {	2667	sub prepare_random_map {
2685	my ($exit) = @_;	2668	my ($exit) = @_;
2686		2669
2687	my $guard = cf::lock_acquire "exit_prepare:$exit";
2688
2689	# all this does is basically replace the /! path by	2670	# all this does is basically replace the /! path by
2690	# a new random map path (?random/...) with a seed	2671	# a new random map path (?random/...) with a seed
2691	# that depends on the exit object	2672	# that depends on the exit object
2692		2673
2693	my $rmp = parse_random_map_params $exit->msg;	2674	my $rmp = parse_random_map_params $exit->msg;
…		…
2695	if ($exit->map) {	2676	if ($exit->map) {
2696	$rmp->{region} = $exit->region->name;	2677	$rmp->{region} = $exit->region->name;
2697	$rmp->{origin_map} = $exit->map->path;	2678	$rmp->{origin_map} = $exit->map->path;
2698	$rmp->{origin_x} = $exit->x;	2679	$rmp->{origin_x} = $exit->x;
2699	$rmp->{origin_y} = $exit->y;	2680	$rmp->{origin_y} = $exit->y;
		2681
		2682	$exit->map->touch;
2700	}	2683	}
2701		2684
2702	$rmp->{random_seed} \|\|= $exit->random_seed;	2685	$rmp->{random_seed} \|\|= $exit->random_seed;
2703		2686
2704	my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);	2687	my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
…		…
2708	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {	2691	if (my $fh = aio_open "$meta~", O_WRONLY \| O_CREAT, 0666) {
2709	aio_write $fh, 0, (length $data), $data, 0;	2692	aio_write $fh, 0, (length $data), $data, 0;
2710	undef $fh;	2693	undef $fh;
2711	aio_rename "$meta~", $meta;	2694	aio_rename "$meta~", $meta;
2712		2695
		2696	my $slaying = "?random/$md5";
		2697
		2698	if ($exit->valid) {
2713	$exit->slaying ("?random/$md5");	2699	$exit->slaying ("?random/$md5");
2714	$exit->msg (undef);	2700	$exit->msg (undef);
		2701	}
2715	}	2702	}
2716	}	2703	}
2717		2704
2718	sub cf::object::player::enter_exit {	2705	sub cf::object::player::enter_exit {
2719	my ($self, $exit) = @_;	2706	my ($self, $exit) = @_;
2720		2707
2721	return unless $self->type == cf::PLAYER;	2708	return unless $self->type == cf::PLAYER;
2722		2709
2723	if ($exit->slaying eq "/!") {
2724	#TODO: this should de-fi-ni-te-ly not be a sync-job
2725	# the problem is that $exit might not survive long enough
2726	# so it needs to be done right now, right here
2727	cf::sync_job { prepare_random_map $exit };
2728	}
2729
2730	my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2731	my $hp = $exit->stats->hp;
2732	my $sp = $exit->stats->sp;
2733
2734	$self->enter_link;	2710	$self->enter_link;
2735		2711
2736	# if exit is damned, update players death & WoR home-position
2737	$self->contr->savebed ($slaying, $hp, $sp)
2738	if $exit->flag (FLAG_DAMNED);
2739
2740	(async {	2712	(async {
2741	$Coro::current->{desc} = "enter_exit $slaying $hp $sp";	2713	$Coro::current->{desc} = "enter_exit";
2742		2714
2743	$self->deactivate_recursive; # just to be sure
2744	unless (eval {	2715	unless (eval {
		2716	$self->deactivate_recursive; # just to be sure
		2717
		2718	# random map handling
		2719	{
		2720	my $guard = cf::lock_acquire "exit_prepare:$exit";
		2721
		2722	prepare_random_map $exit
		2723	if $exit->slaying eq "/!";
		2724	}
		2725
		2726	my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
		2727	my $x = $exit->stats->hp;
		2728	my $y = $exit->stats->sp;
		2729
2745	$self->goto ($slaying, $hp, $sp);	2730	$self->goto ($map, $x, $y);
2746		2731
		2732	# if exit is damned, update players death & WoR home-position
		2733	$self->contr->savebed ($map, $x, $y)
		2734	if $exit->flag (cf::FLAG_DAMNED);
		2735
2747	1;	2736	1
2748	}) {	2737	}) {
2749	$self->message ("Something went wrong deep within the crossfire server. "	2738	$self->message ("Something went wrong deep within the deliantra server. "
2750	. "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. "
2751	. "Please report this to the dungeon master!",	2740	. "Please report this to the dungeon master!",
2752	cf::NDI_UNIQUE \| cf::NDI_RED);	2741	cf::NDI_UNIQUE \| cf::NDI_RED);
2753		2742
2754	warn "ERROR in enter_exit: $@";	2743	warn "ERROR in enter_exit: $@";
…		…
2820	id => "infobox",	2809	id => "infobox",
2821	title => "Body Parts",	2810	title => "Body Parts",
2822	reply => undef,	2811	reply => undef,
2823	tooltip => "Shows which body parts you posess and are available",	2812	tooltip => "Shows which body parts you posess and are available",
2824	},	2813	},
		2814	"c/skills" => {
		2815	id => "infobox",
		2816	title => "Skills",
		2817	reply => undef,
		2818	tooltip => "Shows your experience per skill and item power",
		2819	},
2825	"c/uptime" => {	2820	"c/uptime" => {
2826	id => "infobox",	2821	id => "infobox",
2827	title => "Uptime",	2822	title => "Uptime",
2828	reply => undef,	2823	reply => undef,
2829	tooltip => "How long the server has been running since last restart",	2824	tooltip => "How long the server has been running since last restart",
…		…
2843	);	2838	);
2844		2839
2845	sub cf::client::send_msg {	2840	sub cf::client::send_msg {
2846	my ($self, $channel, $msg, $color, @extra) = @_;	2841	my ($self, $channel, $msg, $color, @extra) = @_;
2847		2842
2848	$msg = $self->pl->expand_cfpod ($msg);	2843	$msg = $self->pl->expand_cfpod ($msg)
		2844	unless $color & cf::NDI_VERBATIM;
2849		2845
2850	$color &= cf::NDI_CLIENT_MASK; # just in case...	2846	$color &= cf::NDI_CLIENT_MASK; # just in case...
2851		2847
2852	# check predefined channels, for the benefit of C	2848	# check predefined channels, for the benefit of C
2853	if ($CHANNEL{$channel}) {	2849	if ($CHANNEL{$channel}) {
…		…
2874	if ($self->can_msg) {	2870	if ($self->can_msg) {
2875	# default colour, mask it out	2871	# default colour, mask it out
2876	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)	2872	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
2877	if $color & cf::NDI_DEF;	2873	if $color & cf::NDI_DEF;
2878		2874
2879	$self->send_packet ("msg " . $self->{json_coder}->encode (	2875	my $pkt = "msg "
		2876	. $self->{json_coder}->encode (
2880	[$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);
2881	} else {	2891	} else {
2882	if ($color >= 0) {	2892	if ($color >= 0) {
2883	# replace some tags by gcfclient-compatible ones	2893	# replace some tags by gcfclient-compatible ones
2884	for ($msg) {	2894	for ($msg) {
2885	1 while	2895	1 while
…		…
3099		3109
3100	=cut	3110	=cut
3101		3111
3102	for (	3112	for (
3103	["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
3104	insert remove inv name archname title slaying race	3114	insert remove inv nrof name archname title slaying race
3105	decrease split destroy)],	3115	decrease split destroy change_exp)],
3106	["cf::object::player" => qw(player)],	3116	["cf::object::player" => qw(player)],
3107	["cf::player" => qw(peaceful)],	3117	["cf::player" => qw(peaceful)],
3108	["cf::map" => qw(trigger)],	3118	["cf::map" => qw(trigger)],
3109	) {	3119	) {
3110	no strict 'refs';	3120	no strict 'refs';
…		…
3368	reload_treasures;	3378	reload_treasures;
3369		3379
3370	warn "finished reloading resource files\n";	3380	warn "finished reloading resource files\n";
3371	}	3381	}
3372		3382
3373	sub init {
3374	my $guard = freeze_mainloop;
3375
3376	reload_resources;
3377	}
3378
3379	sub reload_config {	3383	sub reload_config {
3380	open my $fh, "<:utf8", "$CONFDIR/config"	3384	open my $fh, "<:utf8", "$CONFDIR/config"
3381	or return;	3385	or return;
3382		3386
3383	local $/;	3387	local $/;
…		…
3395	};	3399	};
3396	warn $@ if $@;	3400	warn $@ if $@;
3397	}	3401	}
3398	}	3402	}
3399		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
3400	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
3401	# we must not ever block the main coroutine	3439	# we must not ever block the main coroutine
3402	local $Coro::idle = sub {	3440	local $Coro::idle = sub {
3403	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#
3404	(async {	3442	(async {
3405	$Coro::current->{desc} = "IDLE BUG HANDLER";	3443	$Coro::current->{desc} = "IDLE BUG HANDLER";
3406	EV::loop EV::LOOP_ONESHOT;	3444	EV::loop EV::LOOP_ONESHOT;
3407	})->prio (Coro::PRIO_MAX);	3445	})->prio (Coro::PRIO_MAX);
3408	};	3446	};
3409		3447
3410	{	3448	evthread_start IO::AIO::poll_fileno;
3411	my $guard = freeze_mainloop;	3449
		3450	cf::sync_job {
		3451	reload_resources;
3412	reload_config;	3452	reload_config;
3413	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
3414	load_extensions;	3466	load_extensions;
3415		3467
3416	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority	3468	utime time, time, $RUNTIMEFILE;
3417	evthread_start IO::AIO::poll_fileno;	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;
3418	}	3474	};
3419		3475
3420	EV::loop;	3476	EV::loop;
3421	}	3477	}
3422		3478
3423	#############################################################################	3479	#############################################################################
…		…
3432	};	3488	};
3433	}	3489	}
3434	}	3490	}
3435		3491
3436	sub write_runtime_sync {	3492	sub write_runtime_sync {
3437	my $runtime = "$LOCALDIR/runtime";
3438
3439	# first touch the runtime file to show we are still running:	3493	# first touch the runtime file to show we are still running:
3440	# the fsync below can take a very very long time.	3494	# the fsync below can take a very very long time.
3441		3495
3442	IO::AIO::aio_utime $runtime, undef, undef;	3496	IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3443		3497
3444	my $guard = cf::lock_acquire "write_runtime";	3498	my $guard = cf::lock_acquire "write_runtime";
3445		3499
3446	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644	3500	my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY \| O_CREAT, 0644
3447	or return;	3501	or return;
3448		3502
3449	my $value = $cf::RUNTIME + 90 + 10;	3503	my $value = $cf::RUNTIME + 90 + 10;
3450	# 10 is the runtime save interval, for a monotonic clock	3504	# 10 is the runtime save interval, for a monotonic clock
3451	# 60 allows for the watchdog to kill the server.	3505	# 60 allows for the watchdog to kill the server.
…		…
3461	aio_utime $fh, undef, undef;	3515	aio_utime $fh, undef, undef;
3462		3516
3463	close $fh	3517	close $fh
3464	or return;	3518	or return;
3465		3519
3466	aio_rename "$runtime~", $runtime	3520	aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3467	and return;	3521	and return;
3468		3522
3469	warn "runtime file written.\n";	3523	warn "runtime file written.\n";
3470		3524
3471	1	3525	1
…		…
3483	my $uuid = "$LOCALDIR/uuid";	3537	my $uuid = "$LOCALDIR/uuid";
3484		3538
3485	my $fh = aio_open "$uuid~", O_WRONLY \| O_CREAT, 0644	3539	my $fh = aio_open "$uuid~", O_WRONLY \| O_CREAT, 0644
3486	or return;	3540	or return;
3487		3541
3488	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;
3489	$uuid_skip = 0;	3550	$uuid_skip = 0;
3490		3551
3491	(aio_write $fh, 0, (length $value), $value, 0) <= 0	3552	(aio_write $fh, 0, (length $value), $value, 0) <= 0
3492	and return;	3553	and return;
3493		3554
…		…
3515	}	3576	}
3516		3577
3517	sub emergency_save() {	3578	sub emergency_save() {
3518	my $freeze_guard = cf::freeze_mainloop;	3579	my $freeze_guard = cf::freeze_mainloop;
3519		3580
3520	warn "enter emergency perl save\n";	3581	warn "emergency_perl_save: enter\n";
3521		3582
3522	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
3523	# use a peculiar iteration method to avoid tripping on perl	3589	# use a peculiar iteration method to avoid tripping on perl
3524	# refcount bugs in for. also avoids problems with players	3590	# refcount bugs in for. also avoids problems with players
3525	# and maps saved/destroyed asynchronously.	3591	# and maps saved/destroyed asynchronously.
3526	warn "begin emergency player save\n";	3592	warn "emergency_perl_save: begin player save\n";
3527	for my $login (keys %cf::PLAYER) {	3593	for my $login (keys %cf::PLAYER) {
3528	my $pl = $cf::PLAYER{$login} or next;	3594	my $pl = $cf::PLAYER{$login} or next;
3529	$pl->valid or next;	3595	$pl->valid or next;
3530	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt	3596	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3531	$pl->save;	3597	$pl->save;
3532	}	3598	}
3533	warn "end emergency player save\n";	3599	warn "emergency_perl_save: end player save\n";
3534		3600
3535	warn "begin emergency map save\n";	3601	warn "emergency_perl_save: begin map save\n";
3536	for my $path (keys %cf::MAP) {	3602	for my $path (keys %cf::MAP) {
3537	my $map = $cf::MAP{$path} or next;	3603	my $map = $cf::MAP{$path} or next;
3538	$map->valid or next;	3604	$map->valid or next;
3539	$map->save;	3605	$map->save;
3540	}	3606	}
3541	warn "end emergency map save\n";	3607	warn "emergency_perl_save: end map save\n";
3542		3608
3543	warn "begin emergency database checkpoint\n";	3609	warn "emergency_perl_save: begin database checkpoint\n";
3544	BDB::db_env_txn_checkpoint $DB_ENV;	3610	BDB::db_env_txn_checkpoint $DB_ENV;
3545	warn "end emergency database checkpoint\n";	3611	warn "emergency_perl_save: end database checkpoint\n";
3546		3612
3547	warn "begin write uuid\n";	3613	warn "emergency_perl_save: begin write uuid\n";
3548	write_uuid_sync 1;	3614	write_uuid_sync 1;
3549	warn "end write uuid\n";	3615	warn "emergency_perl_save: end write uuid\n";
3550	};	3616	};
3551		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
3552	warn "leave emergency perl save\n";	3623	warn "emergency_perl_save: leave\n";
3553	}	3624	}
3554		3625
3555	sub post_cleanup {	3626	sub post_cleanup {
3556	my ($make_core) = @_;	3627	my ($make_core) = @_;
3557		3628
3558	warn Carp::longmess "post_cleanup backtrace"	3629	warn Carp::longmess "post_cleanup backtrace"
3559	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#
3560	}	3660	}
3561		3661
3562	sub do_reload_perl() {	3662	sub do_reload_perl() {
3563	# can/must only be called in main	3663	# can/must only be called in main
3564	if ($Coro::current != $Coro::main) {	3664	if ($Coro::current != $Coro::main) {
3565	warn "can only reload from main coroutine";	3665	warn "can only reload from main coroutine";
3566	return;	3666	return;
3567	}	3667	}
3568		3668
		3669	return if $RELOAD++;
		3670
		3671	my $t1 = EV::time;
		3672
		3673	while ($RELOAD) {
3569	warn "reloading...";	3674	warn "reloading...";
3570		3675
3571	warn "entering sync_job";	3676	warn "entering sync_job";
3572		3677
3573	cf::sync_job {	3678	cf::sync_job {
3574	cf::write_runtime_sync; # external watchdog should not bark	3679	cf::write_runtime_sync; # external watchdog should not bark
3575	cf::emergency_save;	3680	cf::emergency_save;
3576	cf::write_runtime_sync; # external watchdog should not bark	3681	cf::write_runtime_sync; # external watchdog should not bark
3577		3682
3578	warn "syncing database to disk";	3683	warn "syncing database to disk";
3579	BDB::db_env_txn_checkpoint $DB_ENV;	3684	BDB::db_env_txn_checkpoint $DB_ENV;
3580		3685
3581	# 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
3582		3687
3583	warn "flushing outstanding aio requests";	3688	warn "flushing outstanding aio requests";
3584	for (;;) {
3585	BDB::flush;
3586	IO::AIO::flush;
3587	Coro::cede_notself;
3588	last unless IO::AIO::nreqs \|\| BDB::nreqs;	3689	while (IO::AIO::nreqs \|\| BDB::nreqs) {
3589	warn "iterate...";	3690	Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3590	}
3591
3592	++$RELOAD;
3593
3594	warn "cancelling all extension coros";
3595	$_->cancel for values %EXT_CORO;
3596	%EXT_CORO = ();
3597
3598	warn "removing commands";
3599	%COMMAND = ();
3600
3601	warn "removing ext/exti commands";
3602	%EXTCMD = ();
3603	%EXTICMD = ();
3604
3605	warn "unloading/nuking all extensions";
3606	for my $pkg (@EXTS) {
3607	warn "... unloading $pkg";
3608
3609	if (my $cb = $pkg->can ("unload")) {
3610	eval {
3611	$cb->($pkg);
3612	1
3613	} or warn "$pkg unloaded, but with errors: $@";
3614	}	3691	}
3615		3692
3616	warn "... nuking $pkg";	3693	warn "cancelling all extension coros";
3617	Symbol::delete_package $pkg;	3694	$_->cancel for values %EXT_CORO;
3618	}	3695	%EXT_CORO = ();
3619		3696
3620	warn "unloading all perl modules loaded from $LIBDIR";	3697	warn "removing commands";
3621	while (my ($k, $v) = each %INC) {	3698	%COMMAND = ();
3622	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3623		3699
		3700	warn "removing ext/exti commands";
		3701	%EXTCMD = ();
		3702	%EXTICMD = ();
		3703
		3704	warn "unloading/nuking all extensions";
		3705	for my $pkg (@EXTS) {
3624	warn "... unloading $k";	3706	warn "... unloading $pkg";
3625	delete $INC{$k};
3626		3707
3627	$k =~ s/\.pm$//;
3628	$k =~ s/\//::/g;
3629
3630	if (my $cb = $k->can ("unload_module")) {	3708	if (my $cb = $pkg->can ("unload")) {
		3709	eval {
3631	$cb->();	3710	$cb->($pkg);
		3711	1
		3712	} or warn "$pkg unloaded, but with errors: $@";
		3713	}
		3714
		3715	warn "... clearing $pkg";
		3716	clear_package $pkg;
3632	}	3717	}
3633		3718
3634	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;
3635	}	3734	}
3636		3735
3637	warn "getting rid of safe::, as good as possible";	3736	warn "getting rid of safe::, as good as possible";
3638	Symbol::delete_package "safe::$_"	3737	clear_package "safe::$_"
3639	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);
3640		3739
3641	warn "unloading cf.pm \"a bit\"";	3740	warn "unloading cf.pm \"a bit\"";
3642	delete $INC{"cf.pm"};	3741	delete $INC{"cf.pm"};
3643	delete $INC{"cf/pod.pm"};	3742	delete $INC{"cf/pod.pm"};
3644		3743
3645	# don't, removes xs symbols, too,	3744	# don't, removes xs symbols, too,
3646	# and global variables created in xs	3745	# and global variables created in xs
3647	#Symbol::delete_package __PACKAGE__;	3746	#clear_package __PACKAGE__;
3648		3747
3649	warn "unload completed, starting to reload now";	3748	warn "unload completed, starting to reload now";
3650		3749
3651	warn "reloading cf.pm";	3750	warn "reloading cf.pm";
3652	require cf;	3751	require cf;
3653	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3752	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3654		3753
3655	warn "loading config and database again";	3754	warn "loading config and database again";
3656	cf::reload_config;	3755	cf::reload_config;
3657		3756
3658	warn "loading extensions";	3757	warn "loading extensions";
3659	cf::load_extensions;	3758	cf::load_extensions;
3660		3759
		3760	if ($REATTACH_ON_RELOAD) {
3661	warn "reattaching attachments to objects/players";	3761	warn "reattaching attachments to objects/players";
3662	_global_reattach; # objects, sockets	3762	_global_reattach; # objects, sockets
3663	warn "reattaching attachments to maps";	3763	warn "reattaching attachments to maps";
3664	reattach $_ for values %MAP;	3764	reattach $_ for values %MAP;
3665	warn "reattaching attachments to players";	3765	warn "reattaching attachments to players";
3666	reattach $_ for values %PLAYER;	3766	reattach $_ for values %PLAYER;
		3767	}
3667		3768
		3769	warn "running post_init jobs";
		3770	(pop @POST_INIT)->(1) while @POST_INIT;
		3771
3668	warn "leaving sync_job";	3772	warn "leaving sync_job";
3669		3773
3670	1	3774	1
3671	} or do {	3775	} or do {
3672	warn $@;	3776	warn $@;
3673	cf::cleanup "error while reloading, exiting.";	3777	cf::cleanup "error while reloading, exiting.";
3674	};	3778	};
3675		3779
3676	warn "reloaded";	3780	warn "reloaded";
		3781	--$RELOAD;
		3782	}
		3783
		3784	$t1 = EV::time - $t1;
		3785	warn "reload completed in ${t1}s\n";
3677	};	3786	};
3678		3787
3679	our $RELOAD_WATCHER; # used only during reload	3788	our $RELOAD_WATCHER; # used only during reload
3680		3789
3681	sub reload_perl() {	3790	sub reload_perl() {
3682	# doing reload synchronously and two reloads happen back-to-back,	3791	# doing reload synchronously and two reloads happen back-to-back,
3683	# coro crashes during coro_state_free->destroy here.	3792	# coro crashes during coro_state_free->destroy here.
3684		3793
		3794	$RELOAD_WATCHER \|\|= cf::async {
		3795	Coro::AIO::aio_wait cache_extensions;
		3796
3685	$RELOAD_WATCHER \|\|= EV::timer 0, 0, sub {	3797	$RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3686	do_reload_perl;	3798	do_reload_perl;
3687	undef $RELOAD_WATCHER;	3799	undef $RELOAD_WATCHER;
		3800	};
3688	};	3801	};
3689	}	3802	}
3690		3803
3691	register_command "reload" => sub {	3804	register_command "reload" => sub {
3692	my ($who, $arg) = @_;	3805	my ($who, $arg) = @_;
…		…
3763	{	3876	{
3764	# configure BDB	3877	# configure BDB
3765		3878
3766	BDB::min_parallel 8;	3879	BDB::min_parallel 8;
3767	BDB::max_poll_reqs $TICK * 0.1;	3880	BDB::max_poll_reqs $TICK * 0.1;
3768	$Coro::BDB::WATCHER->priority (1);	3881	$AnyEvent::BDB::WATCHER->priority (1);
3769		3882
3770	unless ($DB_ENV) {	3883	unless ($DB_ENV) {
3771	$DB_ENV = BDB::db_env_create;	3884	$DB_ENV = BDB::db_env_create;
3772	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT \| BDB::TXN_NOSYNC	3885	$DB_ENV->set_flags (BDB::AUTO_COMMIT \| BDB::REGION_INIT);
3773	\| 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;
3774	$DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);	3888	$DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3775	$DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);	3889	$DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3776		3890
3777	cf::sync_job {	3891	cf::sync_job {
3778	eval {	3892	eval {
…		…
3804	{	3918	{
3805	# configure IO::AIO	3919	# configure IO::AIO
3806		3920
3807	IO::AIO::min_parallel 8;	3921	IO::AIO::min_parallel 8;
3808	IO::AIO::max_poll_time $TICK * 0.1;	3922	IO::AIO::max_poll_time $TICK * 0.1;
3809	$Coro::AIO::WATCHER->priority (1);	3923	undef $AnyEvent::AIO::WATCHER;
3810	}	3924	}
3811		3925
3812	my $_log_backtrace;	3926	my $_log_backtrace;
3813		3927
3814	sub _log_backtrace {	3928	sub _log_backtrace {
…		…
3817	$msg =~ s/\n//;	3931	$msg =~ s/\n//;
3818		3932
3819	# limit the # of concurrent backtraces	3933	# limit the # of concurrent backtraces
3820	if ($_log_backtrace < 2) {	3934	if ($_log_backtrace < 2) {
3821	++$_log_backtrace;	3935	++$_log_backtrace;
		3936	my $perl_bt = Carp::longmess $msg;
3822	async {	3937	async {
3823	$Coro::current->{desc} = "abt $msg";	3938	$Coro::current->{desc} = "abt $msg";
3824		3939
3825	my @bt = fork_call {	3940	my @bt = fork_call {
3826	@addr = map { sprintf "%x", $_ } @addr;	3941	@addr = map { sprintf "%x", $_ } @addr;
…		…
3837	}	3952	}
3838		3953
3839	@funcs	3954	@funcs
3840	};	3955	};
3841		3956
3842	LOG llevInfo, "[ABT] $msg\n";	3957	LOG llevInfo, "[ABT] $perl_bt\n";
		3958	LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3843	LOG llevInfo, "[ABT] $_\n" for @bt;	3959	LOG llevInfo, "[ABT] $_\n" for @bt;
3844	--$_log_backtrace;	3960	--$_log_backtrace;
3845	};	3961	};
3846	} else {	3962	} else {
3847	LOG llevInfo, "[ABT] $msg\n";	3963	LOG llevInfo, "[ABT] $msg\n";

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.426 by root, Thu Apr 24 04:40:31 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.426 by root, Thu Apr 24 04:40:31 2008 UTC vs.
Revision 1.458 by root, Sat Dec 13 20:34:37 2008 UTC