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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.96 by root, Fri Dec 22 06:02:29 2006 UTC vs.
Revision 1.108 by root, Sun Dec 31 21:02:05 2006 UTC

…		…
8	use Storable;	8	use Storable;
9	use Opcode;	9	use Opcode;
10	use Safe;	10	use Safe;
11	use Safe::Hole;	11	use Safe::Hole;
12		12
13	use Coro;	13	use Coro 3.3;
14	use Coro::Event;	14	use Coro::Event;
15	use Coro::Timer;	15	use Coro::Timer;
16	use Coro::Signal;	16	use Coro::Signal;
17	use Coro::Semaphore;	17	use Coro::Semaphore;
18
19	use IO::AIO;	18	use Coro::AIO;
		19
		20	use Digest::MD5;
		21	use Fcntl;
		22	use IO::AIO 2.31 ();
20	use YAML::Syck ();	23	use YAML::Syck ();
21	use Time::HiRes;	24	use Time::HiRes;
22		25
23	use Event; $Event::Eval = 1; # no idea why this is required, but it is	26	use Event; $Event::Eval = 1; # no idea why this is required, but it is
24		27
25	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?	28	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
26	$YAML::Syck::ImplicitUnicode = 1;	29	$YAML::Syck::ImplicitUnicode = 1;
27		30
28	$Coro::main->prio (Coro::PRIO_MIN);	31	$Coro::main->prio (2); # run main coroutine ("the server") with very high priority
29		32
30	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	33	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
31		34
32	our %COMMAND = ();	35	our %COMMAND = ();
33	our %COMMAND_TIME = ();	36	our %COMMAND_TIME = ();
34	our %EXTCMD = ();	37	our %EXTCMD = ();
35		38
36	_init_vars;
37
38	our @EVENT;	39	our @EVENT;
39	our $LIBDIR = datadir . "/ext";	40	our $LIBDIR = datadir . "/ext";
40		41
41	our $TICK = MAX_TIME * 1e-6;	42	our $TICK = MAX_TIME * 1e-6;
42	our $TICK_WATCHER;	43	our $TICK_WATCHER;
43	our $NEXT_TICK;	44	our $NEXT_TICK;
		45	our $NOW;
44		46
45	our %CFG;	47	our %CFG;
46		48
47	our $UPTIME; $UPTIME \|\|= time;	49	our $UPTIME; $UPTIME \|\|= time;
		50	our $RUNTIME;
		51
		52	our %MAP; # all maps
		53	our $LINK_MAP; # the special {link} map
		54	our $FREEZE;
		55	our $RANDOM_MAPS = cf::localdir . "/random";
		56	our %EXT_CORO;
		57
		58	binmode STDOUT;
		59	binmode STDERR;
		60
		61	# read virtual server time, if available
		62	unless ($RUNTIME \|\| !-e cf::localdir . "/runtime") {
		63	open my $fh, "<", cf::localdir . "/runtime"
		64	or die "unable to read runtime file: $!";
		65	$RUNTIME = <$fh> + 0.;
		66	}
		67
		68	mkdir cf::localdir;
		69	mkdir cf::localdir . "/" . cf::playerdir;
		70	mkdir cf::localdir . "/" . cf::tmpdir;
		71	mkdir cf::localdir . "/" . cf::uniquedir;
		72	mkdir $RANDOM_MAPS;
		73
		74	# a special map that is always available
		75	our $LINK_MAP;
48		76
49	#############################################################################	77	#############################################################################
50		78
51	=head2 GLOBAL VARIABLES	79	=head2 GLOBAL VARIABLES
52		80
53	=over 4	81	=over 4
54		82
55	=item $cf::UPTIME	83	=item $cf::UPTIME
56		84
57	The timestamp of the server start (so not actually an uptime).	85	The timestamp of the server start (so not actually an uptime).
		86
		87	=item $cf::RUNTIME
		88
		89	The time this server has run, starts at 0 and is increased by $cf::TICK on
		90	every server tick.
58		91
59	=item $cf::LIBDIR	92	=item $cf::LIBDIR
60		93
61	The perl library directory, where extensions and cf-specific modules can	94	The perl library directory, where extensions and cf-specific modules can
62	be found. It will be added to C<@INC> automatically.	95	be found. It will be added to C<@INC> automatically.
		96
		97	=item $cf::NOW
		98
		99	The time of the last (current) server tick.
63		100
64	=item $cf::TICK	101	=item $cf::TICK
65		102
66	The interval between server ticks, in seconds.	103	The interval between server ticks, in seconds.
67		104
…		…
75	=cut	112	=cut
76		113
77	BEGIN {	114	BEGIN {
78	*CORE::GLOBAL::warn = sub {	115	*CORE::GLOBAL::warn = sub {
79	my $msg = join "", @_;	116	my $msg = join "", @_;
		117	utf8::encode $msg;
		118
80	$msg .= "\n"	119	$msg .= "\n"
81	unless $msg =~ /\n$/;	120	unless $msg =~ /\n$/;
82		121
83	print STDERR "cfperl: $msg";
84	LOG llevError, "cfperl: $msg";	122	LOG llevError, "cfperl: $msg";
85	};	123	};
86	}	124	}
87		125
88	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	126	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
…		…
93	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';	131	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
94		132
95	# we bless all objects into (empty) derived classes to force a method lookup	133	# we bless all objects into (empty) derived classes to force a method lookup
96	# within the Safe compartment.	134	# within the Safe compartment.
97	for my $pkg (qw(	135	for my $pkg (qw(
98	cf::global	136	cf::global cf::attachable
99	cf::object cf::object::player	137	cf::object cf::object::player
100	cf::client cf::player	138	cf::client cf::player
101	cf::arch cf::living	139	cf::arch cf::living
102	cf::map cf::party cf::region	140	cf::map cf::party cf::region
103	)) {	141	)) {
…		…
141	sub to_json($) {	179	sub to_json($) {
142	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs	180	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
143	JSON::Syck::Dump $_[0]	181	JSON::Syck::Dump $_[0]
144	}	182	}
145		183
		184	=item cf::sync_job { BLOCK }
		185
		186	The design of crossfire+ requires that the main coro ($Coro::main) is
		187	always able to handle events or runnable, as crossfire+ is only partly
		188	reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
		189
		190	If it must be done, put the blocking parts into C<sync_job>. This will run
		191	the given BLOCK in another coroutine while waiting for the result. The
		192	server will be frozen during this time, so the block should either finish
		193	fast or be very important.
		194
		195	=cut
		196
		197	sub sync_job(&) {
		198	my ($job) = @_;
		199
		200	my $busy = 1;
		201	my @res;
		202
		203	# TODO: use suspend/resume instead
		204	local $FREEZE = 1;
		205
		206	my $coro = Coro::async {
		207	@res = eval { $job->() };
		208	warn $@ if $@;
		209	undef $busy;
		210	};
		211
		212	if ($Coro::current == $Coro::main) {
		213	$coro->prio (Coro::PRIO_MAX);
		214	while ($busy) {
		215	Coro::cede_notself;
		216	Event::one_event unless Coro::nready;
		217	}
		218	} else {
		219	$coro->join;
		220	}
		221
		222	wantarray ? @res : $res[0]
		223	}
		224
		225	=item $coro = cf::coro { BLOCK }
		226
		227	Creates and returns a new coro. This coro is automcatially being canceled
		228	when the extension calling this is being unloaded.
		229
		230	=cut
		231
		232	sub coro(&) {
		233	my $cb = shift;
		234
		235	my $coro; $coro = async {
		236	eval {
		237	$cb->();
		238	};
		239	warn $@ if $@;
		240	};
		241
		242	$coro->on_destroy (sub {
		243	delete $EXT_CORO{$coro+0};
		244	});
		245	$EXT_CORO{$coro+0} = $coro;
		246
		247	$coro
		248	}
		249
		250	sub write_runtime {
		251	my $runtime = cf::localdir . "/runtime";
		252
		253	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644
		254	or return;
		255
		256	my $value = $cf::RUNTIME;
		257	(aio_write $fh, 0, (length $value), $value, 0) <= 0
		258	and return;
		259
		260	aio_fsync $fh
		261	and return;
		262
		263	close $fh
		264	or return;
		265
		266	aio_rename "$runtime~", $runtime
		267	and return;
		268
		269	1
		270	}
		271
146	=back	272	=back
147		273
148	=cut	274	=cut
		275
		276	#############################################################################
		277
		278	package cf::path;
		279
		280	sub new {
		281	my ($class, $path, $base) = @_;
		282
		283	my $self = bless { }, $class;
		284
		285	if ($path =~ s{^\?random/}{}) {
		286	$self->{random} = cf::from_json $path;
		287	} else {
		288	if ($path =~ s{^~([^/]+)?}{}) {
		289	$self->{user_rel} = 1;
		290
		291	if (defined $1) {
		292	$self->{user} = $1;
		293	} elsif ($base =~ m{^~([^/]+)/}) {
		294	$self->{user} = $1;
		295	} else {
		296	warn "cannot resolve user-relative path without user <$path,$base>\n";
		297	}
		298	} elsif ($path =~ /^\//) {
		299	# already absolute
		300	} else {
		301	$base =~ s{[^/]+/?$}{};
		302	return $class->new ("$base/$path");
		303	}
		304
		305	for ($path) {
		306	redo if s{/\.?/}{/};
		307	redo if s{/[^/]+/\.\./}{/};
		308	}
		309	}
		310
		311	$self->{path} = $path;
		312
		313	$self
		314	}
		315
		316	# the name / primary key / in-game path
		317	sub as_string {
		318	my ($self) = @_;
		319
		320	$self->{user_rel} ? "~$self->{user}$self->{path}"
		321	: $self->{random} ? "?random/$self->{path}"
		322	: $self->{path}
		323	}
		324
		325	# the displayed name, this is a one way mapping
		326	sub visible_name {
		327	my ($self) = @_;
		328
		329	$self->{random} ? "?random/$self->{random}{origin_map}+$self->{random}{origin_x}+$self->{random}{origin_y}/$self->{random}{dungeon_level}"
		330	: $self->as_string
		331	}
		332
		333	# escape the /'s in the path
		334	sub _escaped_path {
		335	# ∕ is U+2215
		336	(my $path = $_[0]{path}) =~ s/\//∕/g;
		337	$path
		338	}
		339
		340	# the original (read-only) location
		341	sub load_path {
		342	my ($self) = @_;
		343
		344	sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
		345	}
		346
		347	# the temporary/swap location
		348	sub save_path {
		349	my ($self) = @_;
		350
		351	$self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
		352	: $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, Digest::MD5::md5_hex $self->{path}
		353	: sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
		354	}
		355
		356	# the unique path, might be eq to save_path
		357	sub uniq_path {
		358	my ($self) = @_;
		359
		360	$self->{user_rel} \|\| $self->{random}
		361	? undef
		362	: sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
		363	}
		364
		365	# return random map parameters, or undef
		366	sub random_map_params {
		367	my ($self) = @_;
		368
		369	$self->{random}
		370	}
		371
		372	# this is somewhat ugly, but style maps do need special treatment
		373	sub is_style_map {
		374	$_[0]{path} =~ m{^/styles/}
		375	}
		376
		377	package cf;
149		378
150	#############################################################################	379	#############################################################################
151		380
152	=head2 ATTACHABLE OBJECTS	381	=head2 ATTACHABLE OBJECTS
153		382
…		…
269	exception.	498	exception.
270		499
271	=cut	500	=cut
272		501
273	# the following variables are defined in .xs and must not be re-created	502	# the following variables are defined in .xs and must not be re-created
274	our @CB_GLOBAL = (); # registry for all global events	503	our @CB_GLOBAL = (); # registry for all global events
		504	our @CB_ATTACHABLE = (); # registry for all attachables
275	our @CB_OBJECT = (); # all objects (should not be used except in emergency)	505	our @CB_OBJECT = (); # all objects (should not be used except in emergency)
276	our @CB_PLAYER = ();	506	our @CB_PLAYER = ();
277	our @CB_CLIENT = ();	507	our @CB_CLIENT = ();
278	our @CB_TYPE = (); # registry for type (cf-object class) based events	508	our @CB_TYPE = (); # registry for type (cf-object class) based events
279	our @CB_MAP = ();	509	our @CB_MAP = ();
280		510
281	my %attachment;	511	my %attachment;
282		512
283	sub _attach_cb($$$$) {	513	sub _attach_cb($$$$) {
284	my ($registry, $event, $prio, $cb) = @_;	514	my ($registry, $event, $prio, $cb) = @_;
…		…
289		519
290	@{$registry->[$event]} = sort	520	@{$registry->[$event]} = sort
291	{ $a->[0] cmp $b->[0] }	521	{ $a->[0] cmp $b->[0] }
292	@{$registry->[$event] \|\| []}, $cb;	522	@{$registry->[$event] \|\| []}, $cb;
293	}	523	}
		524
		525	# hack
		526	my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
294		527
295	# attach handles attaching event callbacks	528	# attach handles attaching event callbacks
296	# the only thing the caller has to do is pass the correct	529	# the only thing the caller has to do is pass the correct
297	# registry (== where the callback attaches to).	530	# registry (== where the callback attaches to).
298	sub _attach {	531	sub _attach {
…		…
300		533
301	my $object_type;	534	my $object_type;
302	my $prio = 0;	535	my $prio = 0;
303	my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;	536	my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
304		537
		538	#TODO: get rid of this hack
		539	if ($attachable_klass{$klass}) {
		540	%cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
		541	}
		542
305	while (@arg) {	543	while (@arg) {
306	my $type = shift @arg;	544	my $type = shift @arg;
307		545
308	if ($type eq "prio") {	546	if ($type eq "prio") {
309	$prio = shift @arg;	547	$prio = shift @arg;
…		…
384	my ($obj, $name) = @_;	622	my ($obj, $name) = @_;
385		623
386	exists $obj->{_attachment}{$name}	624	exists $obj->{_attachment}{$name}
387	}	625	}
388		626
389	for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) {	627	for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
390	eval "#line " . __LINE__ . " 'cf.pm'	628	eval "#line " . __LINE__ . " 'cf.pm'
391	sub cf::\L$klass\E::_attach_registry {	629	sub cf::\L$klass\E::_attach_registry {
392	(\\\@CB_$klass, KLASS_$klass)	630	(\\\@CB_$klass, KLASS_$klass)
393	}	631	}
394		632
…		…
447	=cut	685	=cut
448		686
449	#############################################################################	687	#############################################################################
450	# object support	688	# object support
451		689
452	sub instantiate {
453	my ($obj, $data) = @_;
454
455	$data = from_json $data;
456
457	for (@$data) {
458	my ($name, $args) = @$_;
459
460	$obj->attach ($name, %{$args \|\| {} });
461	}
462	}
463
464	# basically do the same as instantiate, without calling instantiate
465	sub reattach {	690	sub reattach {
		691	# basically do the same as instantiate, without calling instantiate
466	my ($obj) = @_;	692	my ($obj) = @_;
		693
467	my $registry = $obj->registry;	694	my $registry = $obj->registry;
468		695
469	@$registry = ();	696	@$registry = ();
470		697
471	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };	698	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };
…		…
480	warn "object uses attachment '$name' that is not available, postponing.\n";	707	warn "object uses attachment '$name' that is not available, postponing.\n";
481	}	708	}
482	}	709	}
483	}	710	}
484		711
485	sub object_freezer_save {	712	cf::attachable->attach (
486	my ($filename, $rdata, $objs) = @_;
487
488	if (length $$rdata) {
489	warn sprintf "saving %s (%d,%d)\n",
490	$filename, length $$rdata, scalar @$objs;
491
492	if (open my $fh, ">:raw", "$filename~") {
493	chmod SAVE_MODE, $fh;
494	syswrite $fh, $$rdata;
495	close $fh;
496
497	if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
498	chmod SAVE_MODE, $fh;
499	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
500	close $fh;
501	rename "$filename.pst~", "$filename.pst";
502	} else {
503	unlink "$filename.pst";
504	}
505
506	rename "$filename~", $filename;
507	} else {
508	warn "FATAL: $filename~: $!\n";
509	}
510	} else {
511	unlink $filename;
512	unlink "$filename.pst";
513	}
514	}
515
516	sub object_freezer_as_string {
517	my ($rdata, $objs) = @_;
518
519	use Data::Dumper;
520
521	$$rdata . Dumper $objs
522	}
523
524	sub object_thawer_load {
525	my ($filename) = @_;
526
527	local $/;
528
529	my $av;
530
531	#TODO: use sysread etc.
532	if (open my $data, "<:raw:perlio", $filename) {
533	$data = <$data>;
534	if (open my $pst, "<:raw:perlio", "$filename.pst") {
535	$av = eval { (Storable::thaw <$pst>)->{objs} };
536	}
537	return ($data, $av);
538	}
539
540	()
541	}
542
543	cf::object->attach (
544	prio => -1000000,	713	prio => -1000000,
		714	on_instantiate => sub {
		715	my ($obj, $data) = @_;
		716
		717	$data = from_json $data;
		718
		719	for (@$data) {
		720	my ($name, $args) = @$_;
		721
		722	$obj->attach ($name, %{$args \|\| {} });
		723	}
		724	},
		725	on_reattach => \&reattach,
545	on_clone => sub {	726	on_clone => sub {
546	my ($src, $dst) = @_;	727	my ($src, $dst) = @_;
547		728
548	@{$dst->registry} = @{$src->registry};	729	@{$dst->registry} = @{$src->registry};
549		730
…		…
551		732
552	%{$dst->{_attachment}} = %{$src->{_attachment}}	733	%{$dst->{_attachment}} = %{$src->{_attachment}}
553	if exists $src->{_attachment};	734	if exists $src->{_attachment};
554	},	735	},
555	);	736	);
		737
		738	sub object_freezer_save {
		739	my ($filename, $rdata, $objs) = @_;
		740
		741	sync_job {
		742	if (length $$rdata) {
		743	warn sprintf "saving %s (%d,%d)\n",
		744	$filename, length $$rdata, scalar @$objs;
		745
		746	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {
		747	chmod SAVE_MODE, $fh;
		748	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
		749	aio_fsync $fh;
		750	close $fh;
		751
		752	if (@$objs) {
		753	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {
		754	chmod SAVE_MODE, $fh;
		755	my $data = Storable::nfreeze { version => 1, objs => $objs };
		756	aio_write $fh, 0, (length $data), $data, 0;
		757	aio_fsync $fh;
		758	close $fh;
		759	aio_rename "$filename.pst~", "$filename.pst";
		760	}
		761	} else {
		762	aio_unlink "$filename.pst";
		763	}
		764
		765	aio_rename "$filename~", $filename;
		766	} else {
		767	warn "FATAL: $filename~: $!\n";
		768	}
		769	} else {
		770	aio_unlink $filename;
		771	aio_unlink "$filename.pst";
		772	}
		773	}
		774	}
		775
		776	sub object_freezer_as_string {
		777	my ($rdata, $objs) = @_;
		778
		779	use Data::Dumper;
		780
		781	$$rdata . Dumper $objs
		782	}
		783
		784	sub object_thawer_load {
		785	my ($filename) = @_;
		786
		787	my ($data, $av);
		788
		789	(aio_load $filename, $data) >= 0
		790	or return;
		791
		792	unless (aio_stat "$filename.pst") {
		793	(aio_load "$filename.pst", $av) >= 0
		794	or return;
		795	$av = eval { (Storable::thaw <$av>)->{objs} };
		796	}
		797
		798	return ($data, $av);
		799	}
556		800
557	#############################################################################	801	#############################################################################
558	# command handling &c	802	# command handling &c
559		803
560	=item cf::register_command $name => \&callback($ob,$args);	804	=item cf::register_command $name => \&callback($ob,$args);
…		…
886		1130
887	if (@{ $ns->{query_queue} } == @$queue) {	1131	if (@{ $ns->{query_queue} } == @$queue) {
888	if (@$queue) {	1132	if (@$queue) {
889	$ns->send_packet ($ns->{query_queue}[0][0]);	1133	$ns->send_packet ($ns->{query_queue}[0][0]);
890	} else {	1134	} else {
891	$ns->state (ST_PLAYING);	1135	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
892	}	1136	}
893	}	1137	}
894	},	1138	},
895	);	1139	);
896		1140
…		…
908	my $coro; $coro = async {	1152	my $coro; $coro = async {
909	eval {	1153	eval {
910	$cb->();	1154	$cb->();
911	};	1155	};
912	warn $@ if $@;	1156	warn $@ if $@;
913	warn "cancel myself\n";#d#	1157	};
		1158
		1159	$coro->on_destroy (sub {
914	delete $self->{_coro}{$coro+0};	1160	delete $self->{_coro}{$coro+0};
915	};	1161	});
916		1162
917	$self->{_coro}{$coro+0} = $coro;	1163	$self->{_coro}{$coro+0} = $coro;
		1164
		1165	$coro
918	}	1166	}
919		1167
920	cf::client->attach (	1168	cf::client->attach (
921	on_destroy => sub {	1169	on_destroy => sub {
922	my ($ns) = @_;	1170	my ($ns) = @_;
923		1171
924	warn "cancel $_" for values %{ $ns->{_coro} \|\| {} };#d#
925	$_->cancel for values %{ $ns->{_coro} \|\| {} };	1172	$_->cancel for values %{ (delete $ns->{_coro}) \|\| {} };
926	},	1173	},
927	);	1174	);
928		1175
929	=back	1176	=back
930		1177
…		…
1155	local $/;	1402	local $/;
1156	*CFG = YAML::Syck::Load <$fh>;	1403	*CFG = YAML::Syck::Load <$fh>;
1157	}	1404	}
1158		1405
1159	sub main {	1406	sub main {
		1407	# we must not ever block the main coroutine
		1408	local $Coro::idle = sub {
		1409	Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#
		1410	(Coro::unblock_sub {
		1411	Event::one_event;
		1412	})->();
		1413	};
		1414
1160	cfg_load;	1415	cfg_load;
1161	db_load;	1416	db_load;
1162	load_extensions;	1417	load_extensions;
1163	Event::loop;	1418	Event::loop;
1164	}	1419	}
1165		1420
1166	#############################################################################	1421	#############################################################################
1167	# initialisation	1422	# initialisation
1168		1423
1169	sub _perl_reload(&) {	1424	sub perl_reload() {
1170	my ($msg) = @_;	1425	# can/must only be called in main
		1426	if ($Coro::current != $Coro::main) {
		1427	warn "can only reload from main coroutine\n";
		1428	return;
		1429	}
1171		1430
1172	$msg->("reloading...");	1431	warn "reloading...";
		1432
		1433	local $FREEZE = 1;
		1434	cf::emergency_save;
1173		1435
1174	eval {	1436	eval {
		1437	# if anything goes wrong in here, we should simply crash as we already saved
		1438
1175	# cancel all watchers	1439	# cancel all watchers
1176	for (Event::all_watchers) {	1440	for (Event::all_watchers) {
1177	$_->cancel if $_->data & WF_AUTOCANCEL;	1441	$_->cancel if $_->data & WF_AUTOCANCEL;
1178	}	1442	}
1179		1443
		1444	# cancel all extension coros
		1445	$_->cancel for values %EXT_CORO;
		1446	%EXT_CORO = ();
		1447
1180	# unload all extensions	1448	# unload all extensions
1181	for (@exts) {	1449	for (@exts) {
1182	$msg->("unloading <$_>");	1450	warn "unloading <$_>";
1183	unload_extension $_;	1451	unload_extension $_;
1184	}	1452	}
1185		1453
1186	# unload all modules loaded from $LIBDIR	1454	# unload all modules loaded from $LIBDIR
1187	while (my ($k, $v) = each %INC) {	1455	while (my ($k, $v) = each %INC) {
1188	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;	1456	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1189		1457
1190	$msg->("removing <$k>");	1458	warn "removing <$k>";
1191	delete $INC{$k};	1459	delete $INC{$k};
1192		1460
1193	$k =~ s/\.pm$//;	1461	$k =~ s/\.pm$//;
1194	$k =~ s/\//::/g;	1462	$k =~ s/\//::/g;
1195		1463
…		…
1200	Symbol::delete_package $k;	1468	Symbol::delete_package $k;
1201	}	1469	}
1202		1470
1203	# sync database to disk	1471	# sync database to disk
1204	cf::db_sync;	1472	cf::db_sync;
		1473	IO::AIO::flush;
1205		1474
1206	# get rid of safe::, as good as possible	1475	# get rid of safe::, as good as possible
1207	Symbol::delete_package "safe::$_"	1476	Symbol::delete_package "safe::$_"
1208	for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);	1477	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1209		1478
1210	# remove register_script_function callbacks	1479	# remove register_script_function callbacks
1211	# TODO	1480	# TODO
1212		1481
1213	# unload cf.pm "a bit"	1482	# unload cf.pm "a bit"
…		…
1216	# don't, removes xs symbols, too,	1485	# don't, removes xs symbols, too,
1217	# and global variables created in xs	1486	# and global variables created in xs
1218	#Symbol::delete_package __PACKAGE__;	1487	#Symbol::delete_package __PACKAGE__;
1219		1488
1220	# reload cf.pm	1489	# reload cf.pm
1221	$msg->("reloading cf.pm");	1490	warn "reloading cf.pm";
1222	require cf;	1491	require cf;
		1492	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1223		1493
1224	# load config and database again	1494	# load config and database again
1225	cf::cfg_load;	1495	cf::cfg_load;
1226	cf::db_load;	1496	cf::db_load;
1227		1497
1228	# load extensions	1498	# load extensions
1229	$msg->("load extensions");	1499	warn "load extensions";
1230	cf::load_extensions;	1500	cf::load_extensions;
1231		1501
1232	# reattach attachments to objects	1502	# reattach attachments to objects
1233	$msg->("reattach");	1503	warn "reattach";
1234	_global_reattach;	1504	_global_reattach;
1235	};	1505	};
1236	$msg->($@) if $@;
1237		1506
1238	$msg->("reloaded");	1507	if ($@) {
		1508	warn $@;
		1509	warn "error while reloading, exiting.";
		1510	exit 1;
		1511	}
		1512
		1513	warn "reloaded successfully";
1239	};	1514	};
1240		1515
1241	sub perl_reload() {	1516	#############################################################################
1242	_perl_reload {	1517
1243	warn $_[0];	1518	unless ($LINK_MAP) {
1244	print "$_[0]\n";	1519	$LINK_MAP = cf::map::new;
1245	};	1520
		1521	$LINK_MAP->width (41);
		1522	$LINK_MAP->height (41);
		1523	$LINK_MAP->alloc;
		1524	$LINK_MAP->path ("{link}");
		1525	$LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
		1526	$LINK_MAP->in_memory (MAP_IN_MEMORY);
1246	}	1527	}
1247		1528
1248	register "<global>", __PACKAGE__;	1529	register "<global>", __PACKAGE__;
1249		1530
1250	register_command "perl-reload" => sub {	1531	register_command "perl-reload" => sub {
1251	my ($who, $arg) = @_;	1532	my ($who, $arg) = @_;
1252		1533
1253	if ($who->flag (FLAG_WIZ)) {	1534	if ($who->flag (FLAG_WIZ)) {
		1535	$who->message ("start of reload.");
1254	_perl_reload {	1536	perl_reload;
1255	warn $_[0];	1537	$who->message ("end of reload.");
1256	$who->message ($_[0]);
1257	};
1258	}	1538	}
1259	};	1539	};
1260		1540
1261	unshift @INC, $LIBDIR;	1541	unshift @INC, $LIBDIR;
1262		1542
1263	$TICK_WATCHER = Event->timer (	1543	$TICK_WATCHER = Event->timer (
		1544	reentrant => 0,
1264	prio => 0,	1545	prio => 0,
1265	at => $NEXT_TICK \|\| 1,	1546	at => $NEXT_TICK \|\| $TICK,
1266	data => WF_AUTOCANCEL,	1547	data => WF_AUTOCANCEL,
1267	cb => sub {	1548	cb => sub {
		1549	unless ($FREEZE) {
1268	cf::server_tick; # one server iteration	1550	cf::server_tick; # one server iteration
		1551	$RUNTIME += $TICK;
		1552	}
1269		1553
1270	my $NOW = Event::time;
1271	$NEXT_TICK += $TICK;	1554	$NEXT_TICK += $TICK;
1272		1555
1273	# if we are delayed by four ticks or more, skip them all	1556	# if we are delayed by four ticks or more, skip them all
1274	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;	1557	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1275		1558
1276	$TICK_WATCHER->at ($NEXT_TICK);	1559	$TICK_WATCHER->at ($NEXT_TICK);
1277	$TICK_WATCHER->start;	1560	$TICK_WATCHER->start;
1278	},	1561	},
1279	);	1562	);
1280		1563
1281	IO::AIO::max_poll_time $TICK * 0.2;	1564	IO::AIO::max_poll_time $TICK * 0.2;
1282		1565
		1566	Event->io (
1283	Event->io (fd => IO::AIO::poll_fileno,	1567	fd => IO::AIO::poll_fileno,
1284	poll => 'r',	1568	poll => 'r',
1285	prio => 5,	1569	prio => 5,
1286	data => WF_AUTOCANCEL,	1570	data => WF_AUTOCANCEL,
1287	cb => \&IO::AIO::poll_cb);	1571	cb => \&IO::AIO::poll_cb,
		1572	);
		1573
		1574	Event->timer (
		1575	data => WF_AUTOCANCEL,
		1576	after => 0,
		1577	interval => 10,
		1578	cb => sub {
		1579	(Coro::unblock_sub {
		1580	write_runtime
		1581	or warn "ERROR: unable to write runtime file: $!";
		1582	})->();
		1583	},
		1584	);
1288		1585
1289	1	1586	1
1290		1587

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.96 by root, Fri Dec 22 06:02:29 2006 UTC vs. Revision 1.108 by root, Sun Dec 31 21:02:05 2006 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.96 by root, Fri Dec 22 06:02:29 2006 UTC vs.
Revision 1.108 by root, Sun Dec 31 21:02:05 2006 UTC