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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.54 by root, Tue Aug 29 14:49:28 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
…		…
288	*cf::player::attach =	323	*cf::player::attach =
289	*cf::map::attach = sub {	324	*cf::map::attach = sub {
290	my ($obj, $name, %arg) = @_;	325	my ($obj, $name, %arg) = @_;
291		326
292	_attach_attachment $obj, $name, %arg;	327	_attach_attachment $obj, $name, %arg;
293	}	328	};
294		329
295	# all those should be optimised	330	# all those should be optimised
296	*cf::object::detach =	331	*cf::object::detach =
297	*cf::player::detach =	332	*cf::player::detach =
298	*cf::map::detach = sub {	333	*cf::map::detach = sub {
299	my ($obj, $name) = @_;	334	my ($obj, $name) = @_;
300		335
301	delete $obj->{_attachment}{$name};	336	delete $obj->{_attachment}{$name};
302	reattach $obj;	337	reattach ($obj);
		338	};
		339
		340	*cf::object::attached =
		341	*cf::player::attached =
		342	*cf::map::attached = sub {
		343	my ($obj, $name) = @_;
		344
		345	exists $obj->{_attachment}{$name}
303	};	346	};
304		347
305	sub attach_global {	348	sub attach_global {
306	_attach @CB_GLOBAL, KLASS_GLOBAL, @_	349	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
307	}	350	}
…		…
329	my $name = shift;	372	my $name = shift;
330		373
331	$attachment{$name} = [[KLASS_OBJECT, @_]];	374	$attachment{$name} = [[KLASS_OBJECT, @_]];
332	}	375	}
333		376
		377	sub register_player_attachment {
		378	my $name = shift;
		379
		380	$attachment{$name} = [[KLASS_PLAYER, @_]];
		381	}
		382
334	sub register_map_attachment {	383	sub register_map_attachment {
335	my $name = shift;	384	my $name = shift;
336		385
337	$attachment{$name} = [[KLASS_MAP, @_]];	386	$attachment{$name} = [[KLASS_MAP, @_]];
338	}	387	}
…		…
356	for (@$callbacks) {	405	for (@$callbacks) {
357	eval { &{$_->[1]} };	406	eval { &{$_->[1]} };
358		407
359	if ($@) {	408	if ($@) {
360	warn "$@";	409	warn "$@";
361	warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n";	410	warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
362	override;	411	override;
363	}	412	}
364		413
365	return 1 if $override;	414	return 1 if $override;
366	}	415	}
367		416
368	0	417	0
369	}	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;
370		459
371	#############################################################################	460	#############################################################################
372	# object support	461	# object support
373		462
374	sub instantiate {	463	sub instantiate {
…		…
403	}	492	}
404	}	493	}
405	}	494	}
406		495
407	sub object_freezer_save {	496	sub object_freezer_save {
408	my ($filename, $objs) = @_;	497	my ($filename, $rdata, $objs) = @_;
409		498
410	if (@$objs) {	499	if (length $$rdata) {
		500	warn sprintf "saving %s (%d,%d)\n",
		501	$filename, length $$rdata, scalar @$objs;
		502
411	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;
412	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };	510	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
413	close $fh;	511	close $fh;
414	chmod SAVE_MODE, "$filename.pst~";
415	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	}
416	} else {	521	} else {
		522	unlink $filename;
417	unlink "$filename.pst";	523	unlink "$filename.pst";
418	}	524	}
419
420	chmod SAVE_MODE, "$filename~";
421	rename "$filename~", $filename;
422	}	525	}
423		526
424	sub object_thawer_load {	527	sub object_thawer_load {
425	my ($filename) = @_;	528	my ($filename) = @_;
426		529
		530	local $/;
		531
		532	my $av;
		533
		534	#TODO: use sysread etc.
		535	if (open my $data, "<:raw:perlio", $filename) {
		536	$data = <$data>;
427	open my $fh, "<:raw:perlio", "$filename.pst"	537	if (open my $pst, "<:raw:perlio", "$filename.pst") {
428	or return;	538	$av = eval { (Storable::thaw <$pst>)->{objs} };
		539	}
		540	return ($data, $av);
		541	}
429		542
430	eval { local $/; (Storable::thaw <$fh>)->{objs} }	543	()
431	}	544	}
432		545
433	attach_to_objects	546	attach_to_objects
434	prio => -1000000,	547	prio => -1000000,
435	on_clone => sub {	548	on_clone => sub {
…		…
581	load_extension $ext;	694	load_extension $ext;
582	1	695	1
583	} or warn "$ext not loaded: $@";	696	} or warn "$ext not loaded: $@";
584	}	697	}
585	}	698	}
586
587	sub _perl_reload(&) {
588	my ($msg) = @_;
589
590	$msg->("reloading...");
591
592	eval {
593	# 1. cancel all watchers
594	$_->cancel for Event::all_watchers;
595
596	# 2. unload all extensions
597	for (@exts) {
598	$msg->("unloading <$_>");
599	unload_extension $_;
600	}
601
602	# 3. unload all modules loaded from $LIBDIR
603	while (my ($k, $v) = each %INC) {
604	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
605
606	$msg->("removing <$k>");
607	delete $INC{$k};
608
609	$k =~ s/\.pm$//;
610	$k =~ s/\//::/g;
611
612	if (my $cb = $k->can ("unload_module")) {
613	$cb->();
614	}
615
616	Symbol::delete_package $k;
617	}
618
619	# 4. get rid of safe::, as good as possible
620	Symbol::delete_package "safe::$_"
621	for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
622
623	# 5. remove register_script_function callbacks
624	# TODO
625
626	# 6. unload cf.pm "a bit"
627	delete $INC{"cf.pm"};
628
629	# don't, removes xs symbols, too,
630	# and global variables created in xs
631	#Symbol::delete_package __PACKAGE__;
632
633	# 7. reload cf.pm
634	$msg->("reloading cf.pm");
635	require cf;
636	};
637	$msg->($@) if $@;
638
639	$msg->("reloaded");
640	};
641
642	sub perl_reload() {
643	_perl_reload {
644	warn $_[0];
645	print "$_[0]\n";
646	};
647	}
648
649	register_command "perl-reload", 0, sub {
650	my ($who, $arg) = @_;
651
652	if ($who->flag (FLAG_WIZ)) {
653	_perl_reload {
654	warn $_[0];
655	$who->message ($_[0]);
656	};
657	}
658	};
659		699
660	#############################################################################	700	#############################################################################
661	# extcmd framework, basically convert ext <msg>	701	# extcmd framework, basically convert ext <msg>
662	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few	702	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
663		703
…		…
691	defined $path or return;	731	defined $path or return;
692		732
693	unlink "$path.pst";	733	unlink "$path.pst";
694	};	734	};
695		735
696	# old style persistent data, TODO: remove #d#
697	*cf::mapsupport::on_swapin =
698	*cf::mapsupport::on_load = sub {
699	my ($map) = @_;
700
701	my $path = $map->tmpname;
702	$path = $map->path unless defined $path;
703
704	open my $fh, "<:raw", "$path.cfperl"
705	or return; # no perl data
706
707	my $data = Storable::thaw do { local $/; <$fh> };
708
709	$data->{version} <= 1
710	or return; # too new
711
712	$map->_set_obs ($data->{obs});
713	$map->invoke (EVENT_MAP_UPGRADE);
714	};
715
716	attach_to_maps prio => -10000, package => cf::mapsupport::;	736	attach_to_maps prio => -10000, package => cf::mapsupport::;
717		737
718	#############################################################################	738	#############################################################################
719	# load/save perl data associated with player->ob objects	739	# load/save perl data associated with player->ob objects
720		740
721	sub all_objects(@) {	741	sub all_objects(@) {
722	@_, map all_objects ($_->inv), @_	742	@_, map all_objects ($_->inv), @_
723	}	743	}
724		744
		745	# TODO: compatibility cruft, remove when no longer needed
725	attach_to_players	746	attach_to_players
726	on_load => sub {	747	on_load => sub {
727	my ($pl, $path) = @_;	748	my ($pl, $path) = @_;
728		749
729	for my $o (all_objects $pl->ob) {	750	for my $o (all_objects $pl->ob) {
…		…
735	}	756	}
736	},	757	},
737	;	758	;
738		759
739	#############################################################################	760	#############################################################################
740	# core extensions - in perl	761
		762	=head2 CORE EXTENSIONS
		763
		764	Functions and methods that extend core crossfire objects.
		765
		766	=over 4
741		767
742	=item cf::player::exists $login	768	=item cf::player::exists $login
743		769
744	Returns true when the given account exists.	770	Returns true when the given account exists.
745		771
…		…
748	sub cf::player::exists($) {	774	sub cf::player::exists($) {
749	cf::player::find $_[0]	775	cf::player::find $_[0]
750	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;
751	}	777	}
752		778
753	=item $player->reply ($npc, $msg[, $flags])	779	=item $object->reply ($npc, $msg[, $flags])
754		780
755	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>
756	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
757	dialogue with the given NPC character.	783	dialogue with the given NPC character.
758		784
…		…
785	$msg{msgid} = $id;	811	$msg{msgid} = $id;
786		812
787	$self->send ("ext " . to_json \%msg);	813	$self->send ("ext " . to_json \%msg);
788	}	814	}
789		815
		816	=back
		817
		818	=cut
		819
790	#############################################################################	820	#############################################################################
791	# 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
792		831
793	our $safe = new Safe "safe";	832	our $safe = new Safe "safe";
794	our $safe_hole = new Safe::Hole;	833	our $safe_hole = new Safe::Hole;
795		834
796	$SIG{FPE} = 'IGNORE';	835	$SIG{FPE} = 'IGNORE';
797		836
798	$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));
799		838
800	# 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
801		850
802	for (	851	for (
803	["cf::object" => qw(contr pay_amount pay_player)],	852	["cf::object" => qw(contr pay_amount pay_player)],
804	["cf::object::player" => qw(player)],	853	["cf::object::player" => qw(player)],
805	["cf::player" => qw(peaceful)],	854	["cf::player" => qw(peaceful)],
…		…
808	my ($pkg, @funs) = @$_;	857	my ($pkg, @funs) = @$_;
809	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	858	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
810	for @funs;	859	for @funs;
811	}	860	}
812		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
813	sub safe_eval($;@) {	874	sub safe_eval($;@) {
814	my ($code, %vars) = @_;	875	my ($code, %vars) = @_;
815		876
816	my $qcode = $code;	877	my $qcode = $code;
817	$qcode =~ s/"/‟/g; # not allowed in #line filenames	878	$qcode =~ s/"/‟/g; # not allowed in #line filenames
…		…
839	}	900	}
840		901
841	wantarray ? @res : $res[0]	902	wantarray ? @res : $res[0]
842	}	903	}
843		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
844	sub register_script_function {	920	sub register_script_function {
845	my ($fun, $cb) = @_;	921	my ($fun, $cb) = @_;
846		922
847	no strict 'refs';	923	no strict 'refs';
848	*{"safe::$fun"} = $safe_hole->wrap ($cb);	924	*{"safe::$fun"} = $safe_hole->wrap ($cb);
849	}	925	}
850		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
851	#############################################################################	1035	#############################################################################
852	# the server's main()	1036	# the server's main()
853		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
854	sub main {	1046	sub main {
		1047	cfg_load;
		1048	db_load;
		1049	load_extensions;
855	Event::loop;	1050	Event::loop;
856	}	1051	}
857		1052
858	#############################################################################	1053	#############################################################################
859	# initialisation	1054	# initialisation
860		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
861	register "<global>", __PACKAGE__;	1144	register "<global>", __PACKAGE__;
862		1145
863	unshift @INC, $LIBDIR;	1146	unshift @INC, $LIBDIR;
864
865	load_extensions;
866		1147
867	$TICK_WATCHER = Event->timer (	1148	$TICK_WATCHER = Event->timer (
868	prio => 1,	1149	prio => 1,
869	at => $NEXT_TICK \|\| 1,	1150	at => $NEXT_TICK \|\| 1,
870	cb => sub {	1151	cb => sub {
…		…
879	$TICK_WATCHER->at ($NEXT_TICK);	1160	$TICK_WATCHER->at ($NEXT_TICK);
880	$TICK_WATCHER->start;	1161	$TICK_WATCHER->start;
881	},	1162	},
882	);	1163	);
883		1164
884	_reload_2;
885
886	1	1165	1
887		1166

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.54 by root, Tue Aug 29 14:49:28 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.54 by root, Tue Aug 29 14:49:28 2006 UTC vs.
Revision 1.76 by root, Mon Oct 2 15:28:36 2006 UTC