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

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.76 by root, Mon Oct 2 15:28:36 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.76 by root, Mon Oct 2 15:28:36 2006 UTC