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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.53 by root, Tue Aug 29 13:11:58 2006 UTC vs.
Revision 1.74 by root, Sun Oct 1 15:59:29 2006 UTC

…		…
5	use Storable;	5	use Storable;
6	use Opcode;	6	use Opcode;
7	use Safe;	7	use Safe;
8	use Safe::Hole;	8	use Safe::Hole;
9		9
		10	use YAML::Syck ();
10	use Time::HiRes;	11	use Time::HiRes;
11	use Event;	12	use Event;
12	$Event::Eval = 1; # no idea why this is required, but it is	13	$Event::Eval = 1; # no idea why this is required, but it is
13		14
		15	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
		16	$YAML::Syck::ImplicitUnicode = 1;
		17
14	use strict;	18	use strict;
15		19
16	_reload_1;	20	_init_vars;
17		21
18	our %COMMAND = ();	22	our %COMMAND = ();
19	our @EVENT;	23	our @EVENT;
20	our %PROP_TYPE;
21	our %PROP_IDX;
22	our $LIBDIR = maps_directory "perl";	24	our $LIBDIR = maps_directory "perl";
23		25
24	our $TICK = MAX_TIME * 1e-6;	26	our $TICK = MAX_TIME * 1e-6;
25	our $TICK_WATCHER;	27	our $TICK_WATCHER;
26	our $NEXT_TICK;	28	our $NEXT_TICK;
		29
		30	our %CFG;
		31
		32	#############################################################################
		33
		34	=head2 GLOBAL VARIABLES
		35
		36	=over 4
		37
		38	=item $cf::LIBDIR
		39
		40	The perl library directory, where extensions and cf-specific modules can
		41	be found. It will be added to C<@INC> automatically.
		42
		43	=item $cf::TICK
		44
		45	The interval between server ticks, in seconds.
		46
		47	=item %cf::CFG
		48
		49	Configuration for the server, loaded from C</etc/crossfire/config>, or
		50	from wherever your confdir points to.
		51
		52	=back
		53
		54	=cut
27		55
28	BEGIN {	56	BEGIN {
29	*CORE::GLOBAL::warn = sub {	57	*CORE::GLOBAL::warn = sub {
30	my $msg = join "", @_;	58	my $msg = join "", @_;
31	$msg .= "\n"	59	$msg .= "\n"
…		…
34	print STDERR "cfperl: $msg";	62	print STDERR "cfperl: $msg";
35	LOG llevError, "cfperl: $msg";	63	LOG llevError, "cfperl: $msg";
36	};	64	};
37	}	65	}
38		66
39	my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply!
40
41	# generate property mutators
42	sub prop_gen {
43	my ($prefix, $class) = @_;
44
45	no strict 'refs';
46
47	for my $prop (keys %PROP_TYPE) {
48	$prop =~ /^\Q$prefix\E_(.*$)/ or next;
49	my $sub = lc $1;
50
51	my $type = $PROP_TYPE{$prop};
52	my $idx = $PROP_IDX {$prop};
53
54	{"$class\::get_$sub"} = {"$class\::$sub"} = sub {
55	$_[0]->get_property ($type, $idx)
56	};
57
58	*{"$class\::set_$sub"} = sub {
59	$_[0]->set_property ($type, $idx, $_[1]);
60	} unless $ignore_set{$prop};
61	}
62	}
63
64	# auto-generate most of the API
65
66	prop_gen OBJECT_PROP => "cf::object";
67	# CFAPI_OBJECT_ANIMATION?
68	prop_gen PLAYER_PROP => "cf::object::player";
69
70	prop_gen MAP_PROP => "cf::map";
71	prop_gen ARCH_PROP => "cf::arch";
72
73	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';	67	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
74		68
75	# we bless all objects into (empty) derived classes to force a method lookup	69	# we bless all objects into (empty) derived classes to force a method lookup
76	# within the Safe compartment.	70	# within the Safe compartment.
77	for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) {	71	for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) {
…		…
87	my @exts;	81	my @exts;
88	my @hook;	82	my @hook;
89	my %command;	83	my %command;
90	my %extcmd;	84	my %extcmd;
91		85
92	#############################################################################	86	=head2 UTILITY FUNCTIONS
93	# utility functions	87
		88	=over 4
		89
		90	=cut
94		91
95	use JSON::Syck (); # TODO# replace by JSON::PC once working	92	use JSON::Syck (); # TODO# replace by JSON::PC once working
		93
		94	=item $ref = cf::from_json $json
		95
		96	Converts a JSON string into the corresponding perl data structure.
		97
		98	=cut
96		99
97	sub from_json($) {	100	sub from_json($) {
98	$JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs	101	$JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
99	JSON::Syck::Load $_[0]	102	JSON::Syck::Load $_[0]
100	}	103	}
101		104
		105	=item $json = cf::to_json $ref
		106
		107	Converts a perl data structure into its JSON representation.
		108
		109	=cut
		110
102	sub to_json($) {	111	sub to_json($) {
103	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs	112	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
104	JSON::Syck::Dump $_[0]	113	JSON::Syck::Dump $_[0]
105	}	114	}
106		115
		116	=back
		117
		118	=cut
		119
107	#############################################################################	120	#############################################################################
108	# "new" plug-in system	121
		122	=head2 EVENTS AND OBJECT ATTACHMENTS
		123
		124	=over 4
109		125
110	=item $object->attach ($attachment, key => $value...)	126	=item $object->attach ($attachment, key => $value...)
111		127
112	=item $object->detach ($attachment)	128	=item $object->detach ($attachment)
113		129
…		…
122	=item $map->attach ($attachment, key => $value...)	138	=item $map->attach ($attachment, key => $value...)
123		139
124	=item $map->detach ($attachment)	140	=item $map->detach ($attachment)
125		141
126	Attach/detach a pre-registered attachment to a map.	142	Attach/detach a pre-registered attachment to a map.
		143
		144	=item $bool = $object->attached ($name)
		145
		146	=item $bool = $player->attached ($name)
		147
		148	=item $bool = $map->attached ($name)
		149
		150	Checks wether the named attachment is currently attached to the object.
127		151
128	=item cf::attach_global ...	152	=item cf::attach_global ...
129		153
130	Attach handlers for global events.	154	Attach handlers for global events.
131		155
…		…
181	Attach handlers to all maps.	205	Attach handlers to all maps.
182		206
183	=item cf:register_attachment $name, ...	207	=item cf:register_attachment $name, ...
184		208
185	Register an attachment by name through which objects can refer to this	209	Register an attachment by name through which objects can refer to this
		210	attachment.
		211
		212	=item cf:register_player_attachment $name, ...
		213
		214	Register an attachment by name through which players can refer to this
186	attachment.	215	attachment.
187		216
188	=item cf:register_map_attachment $name, ...	217	=item cf:register_map_attachment $name, ...
189		218
190	Register an attachment by name through which maps can refer to this	219	Register an attachment by name through which maps can refer to this
…		…
261	}	290	}
262		291
263	sub _attach_attachment {	292	sub _attach_attachment {
264	my ($obj, $name, %arg) = @_;	293	my ($obj, $name, %arg) = @_;
265		294
		295	return if exists $obj->{_attachment}{$name};
		296
266	my $res;	297	my $res;
267		298
268	if (my $attach = $attachment{$name}) {	299	if (my $attach = $attachment{$name}) {
269	my $registry = $obj->registry;	300	my $registry = $obj->registry;
270		301
…		…
282		313
283	$res->{attachment} = $name;	314	$res->{attachment} = $name;
284	$res	315	$res
285	}	316	}
286		317
287	sub cf::object::attach {	318	*cf::object::attach =
		319	*cf::player::attach =
		320	*cf::map::attach = sub {
288	my ($obj, $name, %arg) = @_;	321	my ($obj, $name, %arg) = @_;
289		322
290	_attach_attachment $obj, $name, %arg;	323	_attach_attachment $obj, $name, %arg;
291	}	324	};
292		325
293	sub cf::player::attach {	326	# all those should be optimised
294	my ($obj, $name, %arg) = @_;
295
296	_attach_attachment $obj, $name, %arg;
297	}
298
299	sub cf::map::attach {
300	my ($obj, $name, %arg) = @_;
301
302	_attach_attachment $obj, $name, %arg;
303	}
304
305	sub cf::object::detach {	327	*cf::object::detach =
		328	*cf::player::detach =
		329	*cf::map::detach = sub {
306	my ($obj, $name) = @_;	330	my ($obj, $name) = @_;
307	die;#d#	331
308	}	332	delete $obj->{_attachment}{$name};
309	sub cf::player::detach {	333	reattach ($obj);
		334	};
		335
		336	*cf::object::attached =
		337	*cf::player::attached =
		338	*cf::map::attached = sub {
310	my ($obj, $name) = @_;	339	my ($obj, $name) = @_;
311	die;#d#	340
312	}	341	exists $obj->{_attachment}{$name}
313	sub cf::map::detach {	342	};
314	my ($obj, $name) = @_;
315	die;#d#
316	}
317		343
318	sub attach_global {	344	sub attach_global {
319	_attach @CB_GLOBAL, KLASS_GLOBAL, @_	345	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
320	}	346	}
321		347
…		…
342	my $name = shift;	368	my $name = shift;
343		369
344	$attachment{$name} = [[KLASS_OBJECT, @_]];	370	$attachment{$name} = [[KLASS_OBJECT, @_]];
345	}	371	}
346		372
		373	sub register_player_attachment {
		374	my $name = shift;
		375
		376	$attachment{$name} = [[KLASS_PLAYER, @_]];
		377	}
		378
347	sub register_map_attachment {	379	sub register_map_attachment {
348	my $name = shift;	380	my $name = shift;
349		381
350	$attachment{$name} = [[KLASS_MAP, @_]];	382	$attachment{$name} = [[KLASS_MAP, @_]];
351	}	383	}
…		…
369	for (@$callbacks) {	401	for (@$callbacks) {
370	eval { &{$_->[1]} };	402	eval { &{$_->[1]} };
371		403
372	if ($@) {	404	if ($@) {
373	warn "$@";	405	warn "$@";
374	warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n";	406	warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
375	override;	407	override;
376	}	408	}
377		409
378	return 1 if $override;	410	return 1 if $override;
379	}	411	}
380		412
381	0	413	0
382	}	414	}
		415
		416	=item $bool = cf::invoke EVENT_GLOBAL_XXX, ...
		417
		418	=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
		419
		420	=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
		421
		422	=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
		423
		424	Generate a global/object/player/map-specific event with the given arguments.
		425
		426	This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
		427	removed in future versions), and there is no public API to access override
		428	results (if you must, access C<@cf::invoke_results> directly).
		429
		430	=back
		431
		432	=cut
		433
		434	#############################################################################
		435
		436	=head2 METHODS VALID FOR ALL CORE OBJECTS
		437
		438	=over 4
		439
		440	=item $object->valid, $player->valid, $map->valid
		441
		442	Just because you have a perl object does not mean that the corresponding
		443	C-level object still exists. If you try to access an object that has no
		444	valid C counterpart anymore you get an exception at runtime. This method
		445	can be used to test for existence of the C object part without causing an
		446	exception.
		447
		448	=back
		449
		450	=cut
		451
		452	*cf::object::valid =
		453	*cf::player::valid =
		454	*cf::map::valid = \&cf::_valid;
383		455
384	#############################################################################	456	#############################################################################
385	# object support	457	# object support
386		458
387	sub instantiate {	459	sub instantiate {
…		…
416	}	488	}
417	}	489	}
418	}	490	}
419		491
420	sub object_freezer_save {	492	sub object_freezer_save {
421	my ($filename, $objs) = @_;	493	my ($filename, $rdata, $objs) = @_;
422		494
423	if (@$objs) {	495	if (length $$rdata) {
		496	warn sprintf "saving %s (%d,%d)\n",
		497	$filename, length $$rdata, scalar @$objs;
		498
424	open my $fh, ">:raw", "$filename.pst~";	499	if (open my $fh, ">:raw", "$filename~") {
		500	chmod SAVE_MODE, $fh;
		501	syswrite $fh, $$rdata;
		502	close $fh;
		503
		504	if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
		505	chmod SAVE_MODE, $fh;
425	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };	506	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
426	close $fh;	507	close $fh;
427	chmod SAVE_MODE, "$filename.pst~";
428	rename "$filename.pst~", "$filename.pst";	508	rename "$filename.pst~", "$filename.pst";
		509	} else {
		510	unlink "$filename.pst";
		511	}
		512
		513	rename "$filename~", $filename;
		514	} else {
		515	warn "FATAL: $filename~: $!\n";
		516	}
429	} else {	517	} else {
		518	unlink $filename;
430	unlink "$filename.pst";	519	unlink "$filename.pst";
431	}	520	}
432
433	chmod SAVE_MODE, "$filename~";
434	rename "$filename~", $filename;
435	}	521	}
436		522
437	sub object_thawer_load {	523	sub object_thawer_load {
438	my ($filename) = @_;	524	my ($filename) = @_;
439		525
		526	local $/;
		527
		528	my $av;
		529
		530	#TODO: use sysread etc.
		531	if (open my $data, "<:raw:perlio", $filename) {
		532	$data = <$data>;
440	open my $fh, "<:raw:perlio", "$filename.pst"	533	if (open my $pst, "<:raw:perlio", "$filename.pst") {
441	or return;	534	$av = eval { (Storable::thaw <$pst>)->{objs} };
		535	}
		536	return ($data, $av);
		537	}
442		538
443	eval { local $/; (Storable::thaw <$fh>)->{objs} }	539	()
444	}	540	}
445		541
446	attach_to_objects	542	attach_to_objects
447	prio => -1000000,	543	prio => -1000000,
448	on_clone => sub {	544	on_clone => sub {
…		…
594	load_extension $ext;	690	load_extension $ext;
595	1	691	1
596	} or warn "$ext not loaded: $@";	692	} or warn "$ext not loaded: $@";
597	}	693	}
598	}	694	}
599
600	sub _perl_reload(&) {
601	my ($msg) = @_;
602
603	$msg->("reloading...");
604
605	eval {
606	# 1. cancel all watchers
607	$_->cancel for Event::all_watchers;
608
609	# 2. unload all extensions
610	for (@exts) {
611	$msg->("unloading <$_>");
612	unload_extension $_;
613	}
614
615	# 3. unload all modules loaded from $LIBDIR
616	while (my ($k, $v) = each %INC) {
617	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
618
619	$msg->("removing <$k>");
620	delete $INC{$k};
621
622	$k =~ s/\.pm$//;
623	$k =~ s/\//::/g;
624
625	if (my $cb = $k->can ("unload_module")) {
626	$cb->();
627	}
628
629	Symbol::delete_package $k;
630	}
631
632	# 4. get rid of safe::, as good as possible
633	Symbol::delete_package "safe::$_"
634	for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
635
636	# 5. remove register_script_function callbacks
637	# TODO
638
639	# 6. unload cf.pm "a bit"
640	delete $INC{"cf.pm"};
641
642	# don't, removes xs symbols, too,
643	# and global variables created in xs
644	#Symbol::delete_package __PACKAGE__;
645
646	# 7. reload cf.pm
647	$msg->("reloading cf.pm");
648	require cf;
649	};
650	$msg->($@) if $@;
651
652	$msg->("reloaded");
653	};
654
655	sub perl_reload() {
656	_perl_reload {
657	warn $_[0];
658	print "$_[0]\n";
659	};
660	}
661
662	register_command "perl-reload", 0, sub {
663	my ($who, $arg) = @_;
664
665	if ($who->flag (FLAG_WIZ)) {
666	_perl_reload {
667	warn $_[0];
668	$who->message ($_[0]);
669	};
670	}
671	};
672		695
673	#############################################################################	696	#############################################################################
674	# extcmd framework, basically convert ext <msg>	697	# extcmd framework, basically convert ext <msg>
675	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few	698	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
676		699
…		…
704	defined $path or return;	727	defined $path or return;
705		728
706	unlink "$path.pst";	729	unlink "$path.pst";
707	};	730	};
708		731
709	# old style persistent data, TODO: remove #d#
710	*cf::mapsupport::on_swapin =
711	*cf::mapsupport::on_load = sub {
712	my ($map) = @_;
713
714	my $path = $map->tmpname;
715	$path = $map->path unless defined $path;
716
717	open my $fh, "<:raw", "$path.cfperl"
718	or return; # no perl data
719
720	my $data = Storable::thaw do { local $/; <$fh> };
721
722	$data->{version} <= 1
723	or return; # too new
724
725	$map->_set_obs ($data->{obs});
726	$map->invoke (EVENT_MAP_UPGRADE);
727	};
728
729	attach_to_maps prio => -10000, package => cf::mapsupport::;	732	attach_to_maps prio => -10000, package => cf::mapsupport::;
730		733
731	#############################################################################	734	#############################################################################
732	# load/save perl data associated with player->ob objects	735	# load/save perl data associated with player->ob objects
733		736
734	sub all_objects(@) {	737	sub all_objects(@) {
735	@_, map all_objects ($_->inv), @_	738	@_, map all_objects ($_->inv), @_
736	}	739	}
737		740
		741	# TODO: compatibility cruft, remove when no longer needed
738	attach_to_players	742	attach_to_players
739	on_load => sub {	743	on_load => sub {
740	my ($pl, $path) = @_;	744	my ($pl, $path) = @_;
741		745
742	for my $o (all_objects $pl->ob) {	746	for my $o (all_objects $pl->ob) {
…		…
748	}	752	}
749	},	753	},
750	;	754	;
751		755
752	#############################################################################	756	#############################################################################
753	# core extensions - in perl	757
		758	=head2 CORE EXTENSIONS
		759
		760	Functions and methods that extend core crossfire objects.
		761
		762	=over 4
754		763
755	=item cf::player::exists $login	764	=item cf::player::exists $login
756		765
757	Returns true when the given account exists.	766	Returns true when the given account exists.
758		767
…		…
798	$msg{msgid} = $id;	807	$msg{msgid} = $id;
799		808
800	$self->send ("ext " . to_json \%msg);	809	$self->send ("ext " . to_json \%msg);
801	}	810	}
802		811
		812	=back
		813
		814	=cut
		815
803	#############################################################################	816	#############################################################################
804	# map scripting support	817
		818	=head2 SAFE SCRIPTING
		819
		820	Functions that provide a safe environment to compile and execute
		821	snippets of perl code without them endangering the safety of the server
		822	itself. Looping constructs, I/O operators and other built-in functionality
		823	is not available in the safe scripting environment, and the number of
		824	functions and methods that cna be called is greatly reduced.
		825
		826	=cut
805		827
806	our $safe = new Safe "safe";	828	our $safe = new Safe "safe";
807	our $safe_hole = new Safe::Hole;	829	our $safe_hole = new Safe::Hole;
808		830
809	$SIG{FPE} = 'IGNORE';	831	$SIG{FPE} = 'IGNORE';
810		832
811	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	833	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
812		834
813	# here we export the classes and methods available to script code	835	# here we export the classes and methods available to script code
		836
		837	=pod
		838
		839	The following fucntions and emthods are available within a safe environment:
		840
		841	cf::object contr pay_amount pay_player
		842	cf::object::player player
		843	cf::player peaceful
		844
		845	=cut
814		846
815	for (	847	for (
816	["cf::object" => qw(contr pay_amount pay_player)],	848	["cf::object" => qw(contr pay_amount pay_player)],
817	["cf::object::player" => qw(player)],	849	["cf::object::player" => qw(player)],
818	["cf::player" => qw(peaceful)],	850	["cf::player" => qw(peaceful)],
…		…
821	my ($pkg, @funs) = @$_;	853	my ($pkg, @funs) = @$_;
822	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	854	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
823	for @funs;	855	for @funs;
824	}	856	}
825		857
		858	=over 4
		859
		860	=item @retval = safe_eval $code, [var => value, ...]
		861
		862	Compiled and executes the given perl code snippet. additional var/value
		863	pairs result in temporary local (my) scalar variables of the given name
		864	that are available in the code snippet. Example:
		865
		866	my $five = safe_eval '$first + $second', first => 1, second => 4;
		867
		868	=cut
		869
826	sub safe_eval($;@) {	870	sub safe_eval($;@) {
827	my ($code, %vars) = @_;	871	my ($code, %vars) = @_;
828		872
829	my $qcode = $code;	873	my $qcode = $code;
830	$qcode =~ s/"/‟/g; # not allowed in #line filenames	874	$qcode =~ s/"/‟/g; # not allowed in #line filenames
…		…
852	}	896	}
853		897
854	wantarray ? @res : $res[0]	898	wantarray ? @res : $res[0]
855	}	899	}
856		900
		901	=item cf::register_script_function $function => $cb
		902
		903	Register a function that can be called from within map/npc scripts. The
		904	function should be reasonably secure and should be put into a package name
		905	like the extension.
		906
		907	Example: register a function that gets called whenever a map script calls
		908	C<rent::overview>, as used by the C<rent> extension.
		909
		910	cf::register_script_function "rent::overview" => sub {
		911	...
		912	};
		913
		914	=cut
		915
857	sub register_script_function {	916	sub register_script_function {
858	my ($fun, $cb) = @_;	917	my ($fun, $cb) = @_;
859		918
860	no strict 'refs';	919	no strict 'refs';
861	*{"safe::$fun"} = $safe_hole->wrap ($cb);	920	*{"safe::$fun"} = $safe_hole->wrap ($cb);
862	}	921	}
863		922
		923	=back
		924
		925	=cut
		926
		927	#############################################################################
		928
		929	=head2 EXTENSION DATABASE SUPPORT
		930
		931	Crossfire maintains a very simple database for extension use. It can
		932	currently store anything that can be serialised using Storable, which
		933	excludes objects.
		934
		935	The parameter C<$family> should best start with the name of the extension
		936	using it, it should be unique.
		937
		938	=over 4
		939
		940	=item $hashref = cf::db_get $family
		941
		942	Return a hashref for use by the extension C<$family>, which can be
		943	modified. After modifications, you have to call C<cf::db_dirty> or
		944	C<cf::db_sync>.
		945
		946	=item $value = cf::db_get $family => $key
		947
		948	Returns a single value from the database
		949
		950	=item cf::db_put $family => $hashref
		951
		952	Stores the given family hashref into the database. Updates are delayed, if
		953	you want the data to be synced to disk immediately, use C<cf::db_sync>.
		954
		955	=item cf::db_put $family => $key => $value
		956
		957	Stores the given C<$value> in the family hash. Updates are delayed, if you
		958	want the data to be synced to disk immediately, use C<cf::db_sync>.
		959
		960	=item cf::db_dirty
		961
		962	Marks the database as dirty, to be updated at a later time.
		963
		964	=item cf::db_sync
		965
		966	Immediately write the database to disk I<if it is dirty>.
		967
		968	=cut
		969
		970	{
		971	my $db;
		972	my $path = cf::localdir . "/database.pst";
		973
		974	sub db_load() {
		975	warn "loading database $path\n";#d# remove later
		976	$db = stat $path ? Storable::retrieve $path : { };
		977	}
		978
		979	my $pid;
		980
		981	sub db_save() {
		982	warn "saving database $path\n";#d# remove later
		983	waitpid $pid, 0 if $pid;
		984	if (0 == ($pid = fork)) {
		985	$db->{_meta}{version} = 1;
		986	Storable::nstore $db, "$path~";
		987	rename "$path~", $path;
		988	cf::_exit 0 if defined $pid;
		989	}
		990	}
		991
		992	my $dirty;
		993
		994	sub db_sync() {
		995	db_save if $dirty;
		996	undef $dirty;
		997	}
		998
		999	my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub {
		1000	db_sync;
		1001	});
		1002
		1003	sub db_dirty() {
		1004	$dirty = 1;
		1005	$idle->start;
		1006	}
		1007
		1008	sub db_get($;$) {
		1009	@_ >= 2
		1010	? $db->{$_[0]}{$_[1]}
		1011	: ($db->{$_[0]} \|\|= { })
		1012	}
		1013
		1014	sub db_put($$;$) {
		1015	if (@_ >= 3) {
		1016	$db->{$_[0]}{$_[1]} = $_[2];
		1017	} else {
		1018	$db->{$_[0]} = $_[1];
		1019	}
		1020	db_dirty;
		1021	}
		1022
		1023	attach_global
		1024	prio => 10000,
		1025	on_cleanup => sub {
		1026	db_sync;
		1027	},
		1028	;
		1029	}
		1030
864	#############################################################################	1031	#############################################################################
865	# the server's main()	1032	# the server's main()
866		1033
		1034	sub cfg_load {
		1035	open my $fh, "<:utf8", cf::confdir . "/config"
		1036	or return;
		1037
		1038	local $/;
		1039	*CFG = YAML::Syck::Load <$fh>;
		1040	}
		1041
867	sub main {	1042	sub main {
		1043	cfg_load;
		1044	db_load;
		1045	load_extensions;
868	Event::loop;	1046	Event::loop;
869	}	1047	}
870		1048
871	#############################################################################	1049	#############################################################################
872	# initialisation	1050	# initialisation
873		1051
		1052	sub _perl_reload(&) {
		1053	my ($msg) = @_;
		1054
		1055	$msg->("reloading...");
		1056
		1057	eval {
		1058	# cancel all watchers
		1059	$_->cancel for Event::all_watchers;
		1060
		1061	# unload all extensions
		1062	for (@exts) {
		1063	$msg->("unloading <$_>");
		1064	unload_extension $_;
		1065	}
		1066
		1067	# unload all modules loaded from $LIBDIR
		1068	while (my ($k, $v) = each %INC) {
		1069	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
		1070
		1071	$msg->("removing <$k>");
		1072	delete $INC{$k};
		1073
		1074	$k =~ s/\.pm$//;
		1075	$k =~ s/\//::/g;
		1076
		1077	if (my $cb = $k->can ("unload_module")) {
		1078	$cb->();
		1079	}
		1080
		1081	Symbol::delete_package $k;
		1082	}
		1083
		1084	# sync database to disk
		1085	cf::db_sync;
		1086
		1087	# get rid of safe::, as good as possible
		1088	Symbol::delete_package "safe::$_"
		1089	for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
		1090
		1091	# remove register_script_function callbacks
		1092	# TODO
		1093
		1094	# unload cf.pm "a bit"
		1095	delete $INC{"cf.pm"};
		1096
		1097	# don't, removes xs symbols, too,
		1098	# and global variables created in xs
		1099	#Symbol::delete_package __PACKAGE__;
		1100
		1101	# reload cf.pm
		1102	$msg->("reloading cf.pm");
		1103	require cf;
		1104
		1105	# load config and database again
		1106	cf::cfg_load;
		1107	cf::db_load;
		1108
		1109	# load extensions
		1110	$msg->("load extensions");
		1111	cf::load_extensions;
		1112
		1113	# reattach attachments to objects
		1114	$msg->("reattach");
		1115	_global_reattach;
		1116	};
		1117	$msg->($@) if $@;
		1118
		1119	$msg->("reloaded");
		1120	};
		1121
		1122	sub perl_reload() {
		1123	_perl_reload {
		1124	warn $_[0];
		1125	print "$_[0]\n";
		1126	};
		1127	}
		1128
		1129	register_command "perl-reload", 0, sub {
		1130	my ($who, $arg) = @_;
		1131
		1132	if ($who->flag (FLAG_WIZ)) {
		1133	_perl_reload {
		1134	warn $_[0];
		1135	$who->message ($_[0]);
		1136	};
		1137	}
		1138	};
		1139
874	register "<global>", __PACKAGE__;	1140	register "<global>", __PACKAGE__;
875		1141
876	unshift @INC, $LIBDIR;	1142	unshift @INC, $LIBDIR;
877
878	load_extensions;
879		1143
880	$TICK_WATCHER = Event->timer (	1144	$TICK_WATCHER = Event->timer (
881	prio => 1,	1145	prio => 1,
882	at => $NEXT_TICK \|\| 1,	1146	at => $NEXT_TICK \|\| 1,
883	cb => sub {	1147	cb => sub {
…		…
892	$TICK_WATCHER->at ($NEXT_TICK);	1156	$TICK_WATCHER->at ($NEXT_TICK);
893	$TICK_WATCHER->start;	1157	$TICK_WATCHER->start;
894	},	1158	},
895	);	1159	);
896		1160
897	_reload_2;
898
899	1	1161	1
900		1162

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.53 by root, Tue Aug 29 13:11:58 2006 UTC vs. Revision 1.74 by root, Sun Oct 1 15:59:29 2006 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.53 by root, Tue Aug 29 13:11:58 2006 UTC vs.
Revision 1.74 by root, Sun Oct 1 15:59:29 2006 UTC