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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.46 by root, Sun Aug 27 16:15:12 2006 UTC vs.
Revision 1.75 by root, Mon Oct 2 00:22:01 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;
		19
		20	_init_vars;
15		21
16	our %COMMAND = ();	22	our %COMMAND = ();
17	our @EVENT;	23	our @EVENT;
18	our %PROP_TYPE;
19	our %PROP_IDX;
20	our $LIBDIR = maps_directory "perl";	24	our $LIBDIR = maps_directory "perl";
21		25
22	our $TICK = MAX_TIME * 1e-6;	26	our $TICK = MAX_TIME * 1e-6;
23	our $TICK_WATCHER;	27	our $TICK_WATCHER;
24	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
25		55
26	BEGIN {	56	BEGIN {
27	*CORE::GLOBAL::warn = sub {	57	*CORE::GLOBAL::warn = sub {
28	my $msg = join "", @_;	58	my $msg = join "", @_;
29	$msg .= "\n"	59	$msg .= "\n"
…		…
32	print STDERR "cfperl: $msg";	62	print STDERR "cfperl: $msg";
33	LOG llevError, "cfperl: $msg";	63	LOG llevError, "cfperl: $msg";
34	};	64	};
35	}	65	}
36		66
37	my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply!
38
39	# generate property mutators
40	sub prop_gen {
41	my ($prefix, $class) = @_;
42
43	no strict 'refs';
44
45	for my $prop (keys %PROP_TYPE) {
46	$prop =~ /^\Q$prefix\E_(.*$)/ or next;
47	my $sub = lc $1;
48
49	my $type = $PROP_TYPE{$prop};
50	my $idx = $PROP_IDX {$prop};
51
52	{"$class\::get_$sub"} = {"$class\::$sub"} = sub {
53	$_[0]->get_property ($type, $idx)
54	};
55
56	*{"$class\::set_$sub"} = sub {
57	$_[0]->set_property ($type, $idx, $_[1]);
58	} unless $ignore_set{$prop};
59	}
60	}
61
62	# auto-generate most of the API
63
64	prop_gen OBJECT_PROP => "cf::object";
65	# CFAPI_OBJECT_ANIMATION?
66	prop_gen PLAYER_PROP => "cf::object::player";
67
68	prop_gen MAP_PROP => "cf::map";
69	prop_gen ARCH_PROP => "cf::arch";
70
71	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';	67	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
72		68
73	# 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
74	# within the Safe compartment.	70	# within the Safe compartment.
75	for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {	71	for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) {
76	no strict 'refs';	72	no strict 'refs';
77	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	73	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
78	}	74	}
79		75
80	$Event::DIED = sub {	76	$Event::DIED = sub {
…		…
85	my @exts;	81	my @exts;
86	my @hook;	82	my @hook;
87	my %command;	83	my %command;
88	my %extcmd;	84	my %extcmd;
89		85
90	#############################################################################	86	=head2 UTILITY FUNCTIONS
91	# utility functions	87
		88	=over 4
		89
		90	=cut
92		91
93	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
94		99
95	sub from_json($) {	100	sub from_json($) {
96	$JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs	101	$JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
97	JSON::Syck::Load $_[0]	102	JSON::Syck::Load $_[0]
98	}	103	}
99		104
		105	=item $json = cf::to_json $ref
		106
		107	Converts a perl data structure into its JSON representation.
		108
		109	=cut
		110
100	sub to_json($) {	111	sub to_json($) {
101	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs	112	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
102	JSON::Syck::Dump $_[0]	113	JSON::Syck::Dump $_[0]
103	}	114	}
104		115
105	#############################################################################	116	=back
106	# "new" plug-in system
107		117
		118	=cut
		119
		120	#############################################################################
		121
		122	=head2 EVENTS AND OBJECT ATTACHMENTS
		123
		124	=over 4
		125
		126	=item $object->attach ($attachment, key => $value...)
		127
108	=item $object->attach ($attachment, ...)	128	=item $object->detach ($attachment)
109		129
110	Attach a pre-registered attachment to an object.	130	Attach/detach a pre-registered attachment to an object.
111		131
		132	=item $player->attach ($attachment, key => $value...)
		133
112	=item $player->attach ($attachment, ...)	134	=item $player->detach ($attachment)
113		135
114	Attach a pre-registered attachment to a player.	136	Attach/detach a pre-registered attachment to a player.
115		137
116	=item $map->attach ($attachment, ...) # not yet persistent	138	=item $map->attach ($attachment, key => $value...)
117		139
		140	=item $map->detach ($attachment)
		141
118	Attach 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.
119		151
120	=item cf::attach_global ...	152	=item cf::attach_global ...
121		153
122	Attach handlers for global events.	154	Attach handlers for global events.
123		155
…		…
150	package and register them. Only handlers for eevents supported by the	182	package and register them. Only handlers for eevents supported by the
151	object/class are recognised.	183	object/class are recognised.
152		184
153	=back	185	=back
154		186
155	=item cf::attach_to_type $object_type, ...	187	=item cf::attach_to_type $object_type, $subtype, ...
156		188
157	Attach handlers for a specific object type (e.g. TRANSPORT).	189	Attach handlers for a specific object type (e.g. TRANSPORT) and
		190	subtype. If C<$subtype> is zero or undef, matches all objects of the given
		191	type.
158		192
159	=item cf::attach_to_objects ...	193	=item cf::attach_to_objects ...
160		194
161	Attach handlers to all objects. Do not use this except for debugging or	195	Attach handlers to all objects. Do not use this except for debugging or
162	very rare events, as handlers are (obviously) called for I<all> objects in	196	very rare events, as handlers are (obviously) called for I<all> objects in
…		…
169	=item cf::attach_to_maps ...	203	=item cf::attach_to_maps ...
170		204
171	Attach handlers to all maps.	205	Attach handlers to all maps.
172		206
173	=item cf:register_attachment $name, ...	207	=item cf:register_attachment $name, ...
		208
		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
		215	attachment.
		216
		217	=item cf:register_map_attachment $name, ...
		218
		219	Register an attachment by name through which maps can refer to this
		220	attachment.
174		221
175	=cut	222	=cut
176		223
177	# the following variables are defined in .xs and must not be re-created	224	# the following variables are defined in .xs and must not be re-created
178	our @CB_GLOBAL = (); # registry for all global events	225	our @CB_GLOBAL = (); # registry for all global events
…		…
241		288
242	\%undo	289	\%undo
243	}	290	}
244		291
245	sub _attach_attachment {	292	sub _attach_attachment {
246	my ($klass, $obj, $name, @args) = q_;	293	my ($obj, $name, %arg) = @_;
		294
		295	return if exists $obj->{_attachment}{$name};
247		296
248	my $res;	297	my $res;
249		298
250	if (my $attach = $attachment{$name}) {	299	if (my $attach = $attachment{$name}) {
251	my $registry = $obj->registry;	300	my $registry = $obj->registry;
252		301
		302	for (@$attach) {
		303	my ($klass, @attach) = @$_;
253	$res = _attach @$registry, $klass, @$attach;	304	$res = _attach @$registry, $klass, @attach;
254
255	if (my $cb = delete $registry->[EVENT_OBJECT_INSTANTIATE]) {
256	for (@$cb) {
257	eval { $_->[1]->($obj, @args); };
258	if ($@) {
259	warn "$@";
260	warn "... while processing '$name' instantiate with args <@args>.\n";
261	}
262	}	305	}
263	}	306
		307	$obj->{$name} = \%arg;
264	} else {	308	} else {
265	warn "object uses attachment '$name' that is not available, postponing.\n";	309	warn "object uses attachment '$name' that is not available, postponing.\n";
266	}	310	}
267		311
268	push @{$obj->{_attachment}}, $name;	312	$obj->{_attachment}{$name} = undef;
269		313
270	$res->{attachment} = $name;	314	$res->{attachment} = $name;
271	$res	315	$res
272	}	316	}
273		317
274	sub cf::object::attach {	318	*cf::object::attach =
		319	*cf::player::attach =
		320	*cf::map::attach = sub {
275	my ($obj, $name, @args) = @_;	321	my ($obj, $name, %arg) = @_;
276		322
277	_attach_attachment KLASS_OBJECT, $obj, $name, @args;	323	_attach_attachment $obj, $name, %arg;
278	}	324	};
279		325
		326	# all those should be optimised
		327	*cf::object::detach =
280	sub cf::player::attach {	328	*cf::player::detach =
		329	*cf::map::detach = sub {
281	my ($obj, $name, @args) = @_;	330	my ($obj, $name) = @_;
282		331
283	_attach_attachment KLASS_PLAYER, $obj, $name, @args;	332	delete $obj->{_attachment}{$name};
284	}	333	reattach ($obj);
		334	};
285		335
286	sub cf::map::attach {	336	*cf::object::attached =
		337	*cf::player::attached =
		338	*cf::map::attached = sub {
287	my ($obj, $name, @args) = @_;	339	my ($obj, $name) = @_;
288		340
289	_attach_attachment KLASS_MAP, $obj, $name, @args;	341	exists $obj->{_attachment}{$name}
290	}	342	};
291		343
292	sub attach_global {	344	sub attach_global {
293	_attach @CB_GLOBAL, KLASS_GLOBAL, @_	345	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
294	}	346	}
295		347
296	sub attach_to_type {	348	sub attach_to_type {
297	my $type = shift;	349	my $type = shift;
		350	my $subtype = shift;
298		351
299	_attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_	352	_attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
300	}	353	}
301		354
302	sub attach_to_objects {	355	sub attach_to_objects {
303	_attach @CB_OBJECT, KLASS_OBJECT, @_	356	_attach @CB_OBJECT, KLASS_OBJECT, @_
304	}	357	}
…		…
312	}	365	}
313		366
314	sub register_attachment {	367	sub register_attachment {
315	my $name = shift;	368	my $name = shift;
316		369
		370	$attachment{$name} = [[KLASS_OBJECT, @_]];
		371	}
		372
		373	sub register_player_attachment {
		374	my $name = shift;
		375
		376	$attachment{$name} = [[KLASS_PLAYER, @_]];
		377	}
		378
		379	sub register_map_attachment {
		380	my $name = shift;
		381
317	$attachment{$name} = [@_];	382	$attachment{$name} = [[KLASS_MAP, @_]];
318	}	383	}
319		384
320	our $override;	385	our $override;
321	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	386	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
322		387
…		…
336	for (@$callbacks) {	401	for (@$callbacks) {
337	eval { &{$_->[1]} };	402	eval { &{$_->[1]} };
338		403
339	if ($@) {	404	if ($@) {
340	warn "$@";	405	warn "$@";
341	warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n";	406	warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
342	override;	407	override;
343	}	408	}
344		409
345	return 1 if $override;	410	return 1 if $override;
346	}	411	}
347		412
348	0	413	0
349	}	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;
350		455
351	#############################################################################	456	#############################################################################
352	# object support	457	# object support
353		458
354	sub instantiate {	459	sub instantiate {
…		…
356		461
357	$data = from_json $data;	462	$data = from_json $data;
358		463
359	for (@$data) {	464	for (@$data) {
360	my ($name, $args) = @$_;	465	my ($name, $args) = @$_;
361	attach $obj, $name, @{$args \|\| [] };	466
		467	$obj->attach ($name, %{$args \|\| {} });
362	}	468	}
363	}	469	}
364		470
365	# basically do the same as instantiate, without calling instantiate	471	# basically do the same as instantiate, without calling instantiate
366	sub reattach {	472	sub reattach {
367	warn "reattach<@_>\n";#d#
368	my ($obj) = @_;	473	my ($obj) = @_;
369	my $registry = $obj->registry;	474	my $registry = $obj->registry;
370		475
		476	@$registry = ();
		477
		478	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };
		479
371	for my $name (@{ $obj->{_attachment} }) {	480	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {
372	if (my $attach = $attachment{$name}) {	481	if (my $attach = $attachment{$name}) {
		482	for (@$attach) {
		483	my ($klass, @attach) = @$_;
373	_attach @$registry, KLASS_OBJECT, @$attach;	484	_attach @$registry, $klass, @attach;
		485	}
374	} else {	486	} else {
375	warn "object uses attachment '$name' that is not available, postponing.\n";	487	warn "object uses attachment '$name' that is not available, postponing.\n";
376	}	488	}
377	}	489	}
378
379	warn "reattach<@_, $_>\n";
380	}	490	}
381		491
382	sub object_freezer_save {	492	sub object_freezer_save {
383	my ($filename, $objs) = @_;	493	my ($filename, $rdata, $objs) = @_;
384	warn "freeze $filename\n";#d#
385	use Data::Dumper; print Dumper $objs;
386		494
387	$filename .= ".pst";	495	if (length $$rdata) {
		496	warn sprintf "saving %s (%d,%d)\n",
		497	$filename, length $$rdata, scalar @$objs;
388		498
389	if (@$objs) {
390	open my $fh, ">:raw", "$filename~";	499	if (open my $fh, ">:raw", "$filename~") {
391	chmod $fh, SAVE_MODE;	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;
392	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };	506	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
393	close $fh;	507	close $fh;
		508	rename "$filename.pst~", "$filename.pst";
		509	} else {
		510	unlink "$filename.pst";
		511	}
		512
394	rename "$filename~", $filename;	513	rename "$filename~", $filename;
		514	} else {
		515	warn "FATAL: $filename~: $!\n";
		516	}
395	} else {	517	} else {
396	unlink $filename;	518	unlink $filename;
		519	unlink "$filename.pst";
397	}	520	}
398	}	521	}
399		522
400	sub object_thawer_load {	523	sub object_thawer_load {
401	my ($filename) = @_;	524	my ($filename) = @_;
402		525
403	warn "thaw $filename\n";#d#	526	local $/;
404		527
		528	my $av;
		529
		530	#TODO: use sysread etc.
		531	if (open my $data, "<:raw:perlio", $filename) {
		532	$data = <$data>;
405	open my $fh, "<:raw:perlio", "$filename.pst"	533	if (open my $pst, "<:raw:perlio", "$filename.pst") {
406	or return;	534	$av = eval { (Storable::thaw <$pst>)->{objs} };
		535	}
		536	return ($data, $av);
		537	}
407		538
408	eval { local $/; (Storable::thaw <$fh>)->{objs} }	539	()
409	}	540	}
410		541
411	attach_to_objects	542	attach_to_objects
412	prio => -1000000,	543	prio => -1000000,
413	on_clone => sub {	544	on_clone => sub {
414	my ($src, $dst) = @_;	545	my ($src, $dst) = @_;
415		546
416	@{$dst->registry} = @{$src->registry};	547	@{$dst->registry} = @{$src->registry};
417	warn "registry clone ", join ":", @{$src->registry};#d#
418		548
419	%$dst = %$src;	549	%$dst = %$src;
420		550
421	$dst->{_attachment} = [@{ $src->{_attachment} }]	551	%{$dst->{_attachment}} = %{$src->{_attachment}}
422	if exists $src->{_attachment};	552	if exists $src->{_attachment};
423
424	warn "clone<@_>\n";#d#
425	},	553	},
426	;	554	;
427		555
428	#############################################################################	556	#############################################################################
429	# old plug-in events	557	# old plug-in events
…		…
562	load_extension $ext;	690	load_extension $ext;
563	1	691	1
564	} or warn "$ext not loaded: $@";	692	} or warn "$ext not loaded: $@";
565	}	693	}
566	}	694	}
567
568	sub _perl_reload(&) {
569	my ($msg) = @_;
570
571	$msg->("reloading...");
572
573	eval {
574	# 1. cancel all watchers
575	$_->cancel for Event::all_watchers;
576
577	# 2. unload all extensions
578	for (@exts) {
579	$msg->("unloading <$_>");
580	unload_extension $_;
581	}
582
583	# 3. unload all modules loaded from $LIBDIR
584	while (my ($k, $v) = each %INC) {
585	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
586
587	$msg->("removing <$k>");
588	delete $INC{$k};
589
590	$k =~ s/\.pm$//;
591	$k =~ s/\//::/g;
592
593	if (my $cb = $k->can ("unload_module")) {
594	$cb->();
595	}
596
597	Symbol::delete_package $k;
598	}
599
600	# 4. get rid of safe::, as good as possible
601	Symbol::delete_package "safe::$_"
602	for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
603
604	# 5. remove register_script_function callbacks
605	# TODO
606
607	# 6. unload cf.pm "a bit"
608	delete $INC{"cf.pm"};
609
610	# don't, removes xs symbols, too,
611	# and global variables created in xs
612	#Symbol::delete_package __PACKAGE__;
613
614	# 7. reload cf.pm
615	$msg->("reloading cf.pm");
616	require cf;
617	};
618	$msg->($@) if $@;
619
620	$msg->("reloaded");
621	};
622
623	sub perl_reload() {
624	_perl_reload {
625	warn $_[0];
626	print "$_[0]\n";
627	};
628	}
629
630	register_command "perl-reload", 0, sub {
631	my ($who, $arg) = @_;
632
633	if ($who->flag (FLAG_WIZ)) {
634	_perl_reload {
635	warn $_[0];
636	$who->message ($_[0]);
637	};
638	}
639	};
640		695
641	#############################################################################	696	#############################################################################
642	# extcmd framework, basically convert ext <msg>	697	# extcmd framework, basically convert ext <msg>
643	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few	698	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
644		699
…		…
669	my ($map) = @_;	724	my ($map) = @_;
670		725
671	my $path = $map->tmpname;	726	my $path = $map->tmpname;
672	defined $path or return;	727	defined $path or return;
673		728
674	unlink "$path.cfperl";
675	unlink "$path.pst";	729	unlink "$path.pst";
676	};	730	};
677		731
678	*cf::mapsupport::on_swapin =
679	*cf::mapsupport::on_load = sub {
680	my ($map) = @_;
681
682	my $path = $map->tmpname;
683	$path = $map->path unless defined $path;
684
685	open my $fh, "<:raw", "$path.cfperl"
686	or return; # no perl data
687
688	my $data = Storable::thaw do { local $/; <$fh> };
689
690	$data->{version} <= 1
691	or return; # too new
692
693	$map->_set_obs ($data->{obs});
694	};
695
696	attach_to_maps prio => -10000, package => cf::mapsupport::;	732	attach_to_maps prio => -10000, package => cf::mapsupport::;
697		733
698	#############################################################################	734	#############################################################################
699	# load/save perl data associated with player->ob objects	735	# load/save perl data associated with player->ob objects
700		736
701	sub all_objects(@) {	737	sub all_objects(@) {
702	@_, map all_objects ($_->inv), @_	738	@_, map all_objects ($_->inv), @_
703	}	739	}
704		740
		741	# TODO: compatibility cruft, remove when no longer needed
705	attach_to_players	742	attach_to_players
706	on_load => sub {	743	on_load => sub {
707	my ($pl, $path) = @_;	744	my ($pl, $path) = @_;
708		745
709	for my $o (all_objects $pl->ob) {	746	for my $o (all_objects $pl->ob) {
…		…
715	}	752	}
716	},	753	},
717	;	754	;
718		755
719	#############################################################################	756	#############################################################################
720	# core extensions - in perl	757
		758	=head2 CORE EXTENSIONS
		759
		760	Functions and methods that extend core crossfire objects.
		761
		762	=over 4
721		763
722	=item cf::player::exists $login	764	=item cf::player::exists $login
723		765
724	Returns true when the given account exists.	766	Returns true when the given account exists.
725		767
…		…
728	sub cf::player::exists($) {	770	sub cf::player::exists($) {
729	cf::player::find $_[0]	771	cf::player::find $_[0]
730	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;	772	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
731	}	773	}
732		774
733	=item $player->reply ($npc, $msg[, $flags])	775	=item $object->reply ($npc, $msg[, $flags])
734		776
735	Sends a message to the player, as if the npc C<$npc> replied. C<$npc>	777	Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
736	can be C<undef>. Does the right thing when the player is currently in a	778	can be C<undef>. Does the right thing when the player is currently in a
737	dialogue with the given NPC character.	779	dialogue with the given NPC character.
738		780
…		…
765	$msg{msgid} = $id;	807	$msg{msgid} = $id;
766		808
767	$self->send ("ext " . to_json \%msg);	809	$self->send ("ext " . to_json \%msg);
768	}	810	}
769		811
		812	=back
		813
		814	=cut
		815
770	#############################################################################	816	#############################################################################
771	# 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
772		827
773	our $safe = new Safe "safe";	828	our $safe = new Safe "safe";
774	our $safe_hole = new Safe::Hole;	829	our $safe_hole = new Safe::Hole;
775		830
776	$SIG{FPE} = 'IGNORE';	831	$SIG{FPE} = 'IGNORE';
777		832
778	$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));
779		834
780	# 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
781		846
782	for (	847	for (
783	["cf::object" => qw(contr pay_amount pay_player)],	848	["cf::object" => qw(contr pay_amount pay_player)],
784	["cf::object::player" => qw(player)],	849	["cf::object::player" => qw(player)],
785	["cf::player" => qw(peaceful)],	850	["cf::player" => qw(peaceful)],
…		…
788	my ($pkg, @funs) = @$_;	853	my ($pkg, @funs) = @$_;
789	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	854	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
790	for @funs;	855	for @funs;
791	}	856	}
792		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
793	sub safe_eval($;@) {	870	sub safe_eval($;@) {
794	my ($code, %vars) = @_;	871	my ($code, %vars) = @_;
795		872
796	my $qcode = $code;	873	my $qcode = $code;
797	$qcode =~ s/"/‟/g; # not allowed in #line filenames	874	$qcode =~ s/"/‟/g; # not allowed in #line filenames
…		…
819	}	896	}
820		897
821	wantarray ? @res : $res[0]	898	wantarray ? @res : $res[0]
822	}	899	}
823		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
824	sub register_script_function {	916	sub register_script_function {
825	my ($fun, $cb) = @_;	917	my ($fun, $cb) = @_;
826		918
827	no strict 'refs';	919	no strict 'refs';
828	*{"safe::$fun"} = $safe_hole->wrap ($cb);	920	*{"safe::$fun"} = $safe_hole->wrap ($cb);
829	}	921	}
830		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
831	#############################################################################	1031	#############################################################################
832	# the server's main()	1032	# the server's main()
833		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
834	sub main {	1042	sub main {
		1043	cfg_load;
		1044	db_load;
		1045	load_extensions;
835	Event::loop;	1046	Event::loop;
836	}	1047	}
837		1048
838	#############################################################################	1049	#############################################################################
839	# initialisation	1050	# initialisation
840		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
841	register "<global>", __PACKAGE__;	1140	register "<global>", __PACKAGE__;
842		1141
843	unshift @INC, $LIBDIR;	1142	unshift @INC, $LIBDIR;
844
845	load_extensions;
846		1143
847	$TICK_WATCHER = Event->timer (	1144	$TICK_WATCHER = Event->timer (
848	prio => 1,	1145	prio => 1,
849	at => $NEXT_TICK \|\| 1,	1146	at => $NEXT_TICK \|\| 1,
850	cb => sub {	1147	cb => sub {

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.46 by root, Sun Aug 27 16:15:12 2006 UTC vs. Revision 1.75 by root, Mon Oct 2 00:22:01 2006 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.46 by root, Sun Aug 27 16:15:12 2006 UTC vs.
Revision 1.75 by root, Mon Oct 2 00:22:01 2006 UTC