[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.70 by root, Sun Oct 1 10:55:37 2006 UTC

…		…
11	use Event;	11	use Event;
12	$Event::Eval = 1; # no idea why this is required, but it is	12	$Event::Eval = 1; # no idea why this is required, but it is
13		13
14	use strict;	14	use strict;
15		15
		16	_init_vars;
		17
16	our %COMMAND = ();	18	our %COMMAND = ();
17	our @EVENT;	19	our @EVENT;
18	our %PROP_TYPE;
19	our %PROP_IDX;
20	our $LIBDIR = maps_directory "perl";	20	our $LIBDIR = maps_directory "perl";
21		21
22	our $TICK = MAX_TIME * 1e-6;	22	our $TICK = MAX_TIME * 1e-6;
23	our $TICK_WATCHER;	23	our $TICK_WATCHER;
24	our $NEXT_TICK;	24	our $NEXT_TICK;
		25
		26	our %CFG;
		27
		28	#############################################################################
		29
		30	=head2 GLOBAL VARIABLES
		31
		32	=over 4
		33
		34	=item $cf::LIBDIR
		35
		36	The perl library directory, where extensions and cf-specific modules can
		37	be found. It will be added to C<@INC> automatically.
		38
		39	=item $cf::TICK
		40
		41	The interval between server ticks, in seconds.
		42
		43	=item %cf::CFG
		44
		45	Configuration for the server, loaded from C</etc/crossfire/config>, or
		46	from wherever your confdir points to.
		47
		48	=back
		49
		50	=cut
25		51
26	BEGIN {	52	BEGIN {
27	*CORE::GLOBAL::warn = sub {	53	*CORE::GLOBAL::warn = sub {
28	my $msg = join "", @_;	54	my $msg = join "", @_;
29	$msg .= "\n"	55	$msg .= "\n"
…		…
32	print STDERR "cfperl: $msg";	58	print STDERR "cfperl: $msg";
33	LOG llevError, "cfperl: $msg";	59	LOG llevError, "cfperl: $msg";
34	};	60	};
35	}	61	}
36		62
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';	63	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
72		64
73	# we bless all objects into (empty) derived classes to force a method lookup	65	# we bless all objects into (empty) derived classes to force a method lookup
74	# within the Safe compartment.	66	# within the Safe compartment.
75	for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {	67	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';	68	no strict 'refs';
77	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	69	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
78	}	70	}
79		71
80	$Event::DIED = sub {	72	$Event::DIED = sub {
…		…
85	my @exts;	77	my @exts;
86	my @hook;	78	my @hook;
87	my %command;	79	my %command;
88	my %extcmd;	80	my %extcmd;
89		81
90	#############################################################################	82	=head2 UTILITY FUNCTIONS
91	# utility functions	83
		84	=over 4
		85
		86	=cut
92		87
93	use JSON::Syck (); # TODO# replace by JSON::PC once working	88	use JSON::Syck (); # TODO# replace by JSON::PC once working
		89
		90	=item $ref = cf::from_json $json
		91
		92	Converts a JSON string into the corresponding perl data structure.
		93
		94	=cut
94		95
95	sub from_json($) {	96	sub from_json($) {
96	$JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs	97	$JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
97	JSON::Syck::Load $_[0]	98	JSON::Syck::Load $_[0]
98	}	99	}
99		100
		101	=item $json = cf::to_json $ref
		102
		103	Converts a perl data structure into its JSON representation.
		104
		105	=cut
		106
100	sub to_json($) {	107	sub to_json($) {
101	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs	108	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
102	JSON::Syck::Dump $_[0]	109	JSON::Syck::Dump $_[0]
103	}	110	}
104		111
105	#############################################################################	112	=back
106	# "new" plug-in system
107		113
		114	#############################################################################
		115
		116	=head2 EVENTS AND OBJECT ATTACHMENTS
		117
		118	=over 4
		119
		120	=item $object->attach ($attachment, key => $value...)
		121
108	=item $object->attach ($attachment, ...)	122	=item $object->detach ($attachment)
109		123
110	Attach a pre-registered attachment to an object.	124	Attach/detach a pre-registered attachment to an object.
111		125
		126	=item $player->attach ($attachment, key => $value...)
		127
112	=item $player->attach ($attachment, ...)	128	=item $player->detach ($attachment)
113		129
114	Attach a pre-registered attachment to a player.	130	Attach/detach a pre-registered attachment to a player.
115		131
116	=item $map->attach ($attachment, ...) # not yet persistent	132	=item $map->attach ($attachment, key => $value...)
117		133
		134	=item $map->detach ($attachment)
		135
118	Attach a pre-registered attachment to a map.	136	Attach/detach a pre-registered attachment to a map.
		137
		138	=item $bool = $object->attached ($name)
		139
		140	=item $bool = $player->attached ($name)
		141
		142	=item $bool = $map->attached ($name)
		143
		144	Checks wether the named attachment is currently attached to the object.
119		145
120	=item cf::attach_global ...	146	=item cf::attach_global ...
121		147
122	Attach handlers for global events.	148	Attach handlers for global events.
123		149
…		…
150	package and register them. Only handlers for eevents supported by the	176	package and register them. Only handlers for eevents supported by the
151	object/class are recognised.	177	object/class are recognised.
152		178
153	=back	179	=back
154		180
155	=item cf::attach_to_type $object_type, ...	181	=item cf::attach_to_type $object_type, $subtype, ...
156		182
157	Attach handlers for a specific object type (e.g. TRANSPORT).	183	Attach handlers for a specific object type (e.g. TRANSPORT) and
		184	subtype. If C<$subtype> is zero or undef, matches all objects of the given
		185	type.
158		186
159	=item cf::attach_to_objects ...	187	=item cf::attach_to_objects ...
160		188
161	Attach handlers to all objects. Do not use this except for debugging or	189	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	190	very rare events, as handlers are (obviously) called for I<all> objects in
…		…
169	=item cf::attach_to_maps ...	197	=item cf::attach_to_maps ...
170		198
171	Attach handlers to all maps.	199	Attach handlers to all maps.
172		200
173	=item cf:register_attachment $name, ...	201	=item cf:register_attachment $name, ...
		202
		203	Register an attachment by name through which objects can refer to this
		204	attachment.
		205
		206	=item cf:register_player_attachment $name, ...
		207
		208	Register an attachment by name through which players can refer to this
		209	attachment.
		210
		211	=item cf:register_map_attachment $name, ...
		212
		213	Register an attachment by name through which maps can refer to this
		214	attachment.
174		215
175	=cut	216	=cut
176		217
177	# the following variables are defined in .xs and must not be re-created	218	# the following variables are defined in .xs and must not be re-created
178	our @CB_GLOBAL = (); # registry for all global events	219	our @CB_GLOBAL = (); # registry for all global events
…		…
241		282
242	\%undo	283	\%undo
243	}	284	}
244		285
245	sub _attach_attachment {	286	sub _attach_attachment {
246	my ($klass, $obj, $name, @args) = q_;	287	my ($obj, $name, %arg) = @_;
		288
		289	return if exists $obj->{_attachment}{$name};
247		290
248	my $res;	291	my $res;
249		292
250	if (my $attach = $attachment{$name}) {	293	if (my $attach = $attachment{$name}) {
251	my $registry = $obj->registry;	294	my $registry = $obj->registry;
252		295
		296	for (@$attach) {
		297	my ($klass, @attach) = @$_;
253	$res = _attach @$registry, $klass, @$attach;	298	$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	}	299	}
263	}	300
		301	$obj->{$name} = \%arg;
264	} else {	302	} else {
265	warn "object uses attachment '$name' that is not available, postponing.\n";	303	warn "object uses attachment '$name' that is not available, postponing.\n";
266	}	304	}
267		305
268	push @{$obj->{_attachment}}, $name;	306	$obj->{_attachment}{$name} = undef;
269		307
270	$res->{attachment} = $name;	308	$res->{attachment} = $name;
271	$res	309	$res
272	}	310	}
273		311
274	sub cf::object::attach {	312	*cf::object::attach =
		313	*cf::player::attach =
		314	*cf::map::attach = sub {
275	my ($obj, $name, @args) = @_;	315	my ($obj, $name, %arg) = @_;
276		316
277	_attach_attachment KLASS_OBJECT, $obj, $name, @args;	317	_attach_attachment $obj, $name, %arg;
278	}	318	};
279		319
		320	# all those should be optimised
		321	*cf::object::detach =
280	sub cf::player::attach {	322	*cf::player::detach =
		323	*cf::map::detach = sub {
281	my ($obj, $name, @args) = @_;	324	my ($obj, $name) = @_;
282		325
283	_attach_attachment KLASS_PLAYER, $obj, $name, @args;	326	delete $obj->{_attachment}{$name};
284	}	327	reattach ($obj);
		328	};
285		329
286	sub cf::map::attach {	330	*cf::object::attached =
		331	*cf::player::attached =
		332	*cf::map::attached = sub {
287	my ($obj, $name, @args) = @_;	333	my ($obj, $name) = @_;
288		334
289	_attach_attachment KLASS_MAP, $obj, $name, @args;	335	exists $obj->{_attachment}{$name}
290	}	336	};
291		337
292	sub attach_global {	338	sub attach_global {
293	_attach @CB_GLOBAL, KLASS_GLOBAL, @_	339	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
294	}	340	}
295		341
296	sub attach_to_type {	342	sub attach_to_type {
297	my $type = shift;	343	my $type = shift;
		344	my $subtype = shift;
298		345
299	_attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_	346	_attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
300	}	347	}
301		348
302	sub attach_to_objects {	349	sub attach_to_objects {
303	_attach @CB_OBJECT, KLASS_OBJECT, @_	350	_attach @CB_OBJECT, KLASS_OBJECT, @_
304	}	351	}
…		…
312	}	359	}
313		360
314	sub register_attachment {	361	sub register_attachment {
315	my $name = shift;	362	my $name = shift;
316		363
		364	$attachment{$name} = [[KLASS_OBJECT, @_]];
		365	}
		366
		367	sub register_player_attachment {
		368	my $name = shift;
		369
		370	$attachment{$name} = [[KLASS_PLAYER, @_]];
		371	}
		372
		373	sub register_map_attachment {
		374	my $name = shift;
		375
317	$attachment{$name} = [@_];	376	$attachment{$name} = [[KLASS_MAP, @_]];
318	}	377	}
319		378
320	our $override;	379	our $override;
321	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	380	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
322		381
…		…
336	for (@$callbacks) {	395	for (@$callbacks) {
337	eval { &{$_->[1]} };	396	eval { &{$_->[1]} };
338		397
339	if ($@) {	398	if ($@) {
340	warn "$@";	399	warn "$@";
341	warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n";	400	warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
342	override;	401	override;
343	}	402	}
344		403
345	return 1 if $override;	404	return 1 if $override;
346	}	405	}
347		406
348	0	407	0
349	}	408	}
		409
		410	=item $bool = cf::invoke EVENT_GLOBAL_XXX, ...
		411
		412	=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
		413
		414	=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
		415
		416	=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
		417
		418	Generate a global/object/player/map-specific event with the given arguments.
		419
		420	This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
		421	removed in future versions), and there is no public API to access override
		422	results (if you must, access C<@cf::invoke_results> directly).
		423
		424	=back
		425
		426	#############################################################################
		427
		428	=head2 METHODS VALID FOR ALL CORE OBJECTS
		429
		430	=over 4
		431
		432	=item $object->valid, $player->valid, $map->valid
		433
		434	Just because you have a perl object does not mean that the corresponding
		435	C-level object still exists. If you try to access an object that has no
		436	valid C counterpart anymore you get an exception at runtime. This method
		437	can be used to test for existence of the C object part without causing an
		438	exception.
		439
		440	=back
		441
		442	=cut
		443
		444	*cf::object::valid =
		445	*cf::player::valid =
		446	*cf::map::valid = \&cf::_valid;
350		447
351	#############################################################################	448	#############################################################################
352	# object support	449	# object support
353		450
354	sub instantiate {	451	sub instantiate {
…		…
356		453
357	$data = from_json $data;	454	$data = from_json $data;
358		455
359	for (@$data) {	456	for (@$data) {
360	my ($name, $args) = @$_;	457	my ($name, $args) = @$_;
361	attach $obj, $name, @{$args \|\| [] };	458
		459	$obj->attach ($name, %{$args \|\| {} });
362	}	460	}
363	}	461	}
364		462
365	# basically do the same as instantiate, without calling instantiate	463	# basically do the same as instantiate, without calling instantiate
366	sub reattach {	464	sub reattach {
367	warn "reattach<@_>\n";#d#
368	my ($obj) = @_;	465	my ($obj) = @_;
369	my $registry = $obj->registry;	466	my $registry = $obj->registry;
370		467
		468	@$registry = ();
		469
		470	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };
		471
371	for my $name (@{ $obj->{_attachment} }) {	472	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {
372	if (my $attach = $attachment{$name}) {	473	if (my $attach = $attachment{$name}) {
		474	for (@$attach) {
		475	my ($klass, @attach) = @$_;
373	_attach @$registry, KLASS_OBJECT, @$attach;	476	_attach @$registry, $klass, @attach;
		477	}
374	} else {	478	} else {
375	warn "object uses attachment '$name' that is not available, postponing.\n";	479	warn "object uses attachment '$name' that is not available, postponing.\n";
376	}	480	}
377	}	481	}
378
379	warn "reattach<@_, $_>\n";
380	}	482	}
381		483
382	sub object_freezer_save {	484	sub object_freezer_save {
383	my ($filename, $objs) = @_;	485	my ($filename, $rdata, $objs) = @_;
384	warn "freeze $filename\n";#d#
385	use Data::Dumper; print Dumper $objs;
386		486
387	$filename .= ".pst";	487	if (length $$rdata) {
		488	warn sprintf "saving %s (%d,%d)\n",
		489	$filename, length $$rdata, scalar @$objs;
388		490
389	if (@$objs) {
390	open my $fh, ">:raw", "$filename~";	491	if (open my $fh, ">:raw", "$filename~") {
391	chmod $fh, SAVE_MODE;	492	chmod SAVE_MODE, $fh;
		493	syswrite $fh, $$rdata;
		494	close $fh;
		495
		496	if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
		497	chmod SAVE_MODE, $fh;
392	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };	498	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
393	close $fh;	499	close $fh;
		500	rename "$filename.pst~", "$filename.pst";
		501	} else {
		502	unlink "$filename.pst";
		503	}
		504
394	rename "$filename~", $filename;	505	rename "$filename~", $filename;
		506	} else {
		507	warn "FATAL: $filename~: $!\n";
		508	}
395	} else {	509	} else {
396	unlink $filename;	510	unlink $filename;
		511	unlink "$filename.pst";
397	}	512	}
398	}	513	}
399		514
400	sub object_thawer_load {	515	sub object_thawer_load {
401	my ($filename) = @_;	516	my ($filename) = @_;
402		517
403	warn "thaw $filename\n";#d#	518	local $/;
404		519
		520	my $av;
		521
		522	#TODO: use sysread etc.
		523	if (open my $data, "<:raw:perlio", $filename) {
		524	$data = <$data>;
405	open my $fh, "<:raw:perlio", "$filename.pst"	525	if (open my $pst, "<:raw:perlio", "$filename.pst") {
406	or return;	526	$av = eval { (Storable::thaw <$pst>)->{objs} };
		527	}
		528	return ($data, $av);
		529	}
407		530
408	eval { local $/; (Storable::thaw <$fh>)->{objs} }	531	()
409	}	532	}
410		533
411	attach_to_objects	534	attach_to_objects
412	prio => -1000000,	535	prio => -1000000,
413	on_clone => sub {	536	on_clone => sub {
414	my ($src, $dst) = @_;	537	my ($src, $dst) = @_;
415		538
416	@{$dst->registry} = @{$src->registry};	539	@{$dst->registry} = @{$src->registry};
417	warn "registry clone ", join ":", @{$src->registry};#d#
418		540
419	%$dst = %$src;	541	%$dst = %$src;
420		542
421	$dst->{_attachment} = [@{ $src->{_attachment} }]	543	%{$dst->{_attachment}} = %{$src->{_attachment}}
422	if exists $src->{_attachment};	544	if exists $src->{_attachment};
423
424	warn "clone<@_>\n";#d#
425	},	545	},
426	;	546	;
427		547
428	#############################################################################	548	#############################################################################
429	# old plug-in events	549	# old plug-in events
…		…
562	load_extension $ext;	682	load_extension $ext;
563	1	683	1
564	} or warn "$ext not loaded: $@";	684	} or warn "$ext not loaded: $@";
565	}	685	}
566	}	686	}
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		687
641	#############################################################################	688	#############################################################################
642	# extcmd framework, basically convert ext <msg>	689	# extcmd framework, basically convert ext <msg>
643	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few	690	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
644		691
…		…
669	my ($map) = @_;	716	my ($map) = @_;
670		717
671	my $path = $map->tmpname;	718	my $path = $map->tmpname;
672	defined $path or return;	719	defined $path or return;
673		720
674	unlink "$path.cfperl";
675	unlink "$path.pst";	721	unlink "$path.pst";
676	};	722	};
677		723
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::;	724	attach_to_maps prio => -10000, package => cf::mapsupport::;
697		725
698	#############################################################################	726	#############################################################################
699	# load/save perl data associated with player->ob objects	727	# load/save perl data associated with player->ob objects
700		728
701	sub all_objects(@) {	729	sub all_objects(@) {
702	@_, map all_objects ($_->inv), @_	730	@_, map all_objects ($_->inv), @_
703	}	731	}
704		732
		733	# TODO: compatibility cruft, remove when no longer needed
705	attach_to_players	734	attach_to_players
706	on_load => sub {	735	on_load => sub {
707	my ($pl, $path) = @_;	736	my ($pl, $path) = @_;
708		737
709	for my $o (all_objects $pl->ob) {	738	for my $o (all_objects $pl->ob) {
…		…
715	}	744	}
716	},	745	},
717	;	746	;
718		747
719	#############################################################################	748	#############################################################################
720	# core extensions - in perl	749
		750	=head2 CORE EXTENSIONS
		751
		752	Functions and methods that extend core crossfire objects.
		753
		754	=over 4
721		755
722	=item cf::player::exists $login	756	=item cf::player::exists $login
723		757
724	Returns true when the given account exists.	758	Returns true when the given account exists.
725		759
…		…
765	$msg{msgid} = $id;	799	$msg{msgid} = $id;
766		800
767	$self->send ("ext " . to_json \%msg);	801	$self->send ("ext " . to_json \%msg);
768	}	802	}
769		803
		804	=back
		805
		806	=cut
		807
770	#############################################################################	808	#############################################################################
771	# map scripting support	809
		810	=head2 SAFE SCRIPTING
		811
		812	Functions that provide a safe environment to compile and execute
		813	snippets of perl code without them endangering the safety of the server
		814	itself. Looping constructs, I/O operators and other built-in functionality
		815	is not available in the safe scripting environment, and the number of
		816	functions and methods that cna be called is greatly reduced.
		817
		818	=cut
772		819
773	our $safe = new Safe "safe";	820	our $safe = new Safe "safe";
774	our $safe_hole = new Safe::Hole;	821	our $safe_hole = new Safe::Hole;
775		822
776	$SIG{FPE} = 'IGNORE';	823	$SIG{FPE} = 'IGNORE';
777		824
778	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	825	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
779		826
780	# here we export the classes and methods available to script code	827	# here we export the classes and methods available to script code
		828
		829	=pod
		830
		831	The following fucntions and emthods are available within a safe environment:
		832
		833	cf::object contr pay_amount pay_player
		834	cf::object::player player
		835	cf::player peaceful
		836
		837	=cut
781		838
782	for (	839	for (
783	["cf::object" => qw(contr pay_amount pay_player)],	840	["cf::object" => qw(contr pay_amount pay_player)],
784	["cf::object::player" => qw(player)],	841	["cf::object::player" => qw(player)],
785	["cf::player" => qw(peaceful)],	842	["cf::player" => qw(peaceful)],
…		…
788	my ($pkg, @funs) = @$_;	845	my ($pkg, @funs) = @$_;
789	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	846	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
790	for @funs;	847	for @funs;
791	}	848	}
792		849
		850	=over 4
		851
		852	=item @retval = safe_eval $code, [var => value, ...]
		853
		854	Compiled and executes the given perl code snippet. additional var/value
		855	pairs result in temporary local (my) scalar variables of the given name
		856	that are available in the code snippet. Example:
		857
		858	my $five = safe_eval '$first + $second', first => 1, second => 4;
		859
		860	=cut
		861
793	sub safe_eval($;@) {	862	sub safe_eval($;@) {
794	my ($code, %vars) = @_;	863	my ($code, %vars) = @_;
795		864
796	my $qcode = $code;	865	my $qcode = $code;
797	$qcode =~ s/"/‟/g; # not allowed in #line filenames	866	$qcode =~ s/"/‟/g; # not allowed in #line filenames
…		…
819	}	888	}
820		889
821	wantarray ? @res : $res[0]	890	wantarray ? @res : $res[0]
822	}	891	}
823		892
		893	=item cf::register_script_function $function => $cb
		894
		895	Register a function that can be called from within map/npc scripts. The
		896	function should be reasonably secure and should be put into a package name
		897	like the extension.
		898
		899	Example: register a function that gets called whenever a map script calls
		900	C<rent::overview>, as used by the C<rent> extension.
		901
		902	cf::register_script_function "rent::overview" => sub {
		903	...
		904	};
		905
		906	=cut
		907
824	sub register_script_function {	908	sub register_script_function {
825	my ($fun, $cb) = @_;	909	my ($fun, $cb) = @_;
826		910
827	no strict 'refs';	911	no strict 'refs';
828	*{"safe::$fun"} = $safe_hole->wrap ($cb);	912	*{"safe::$fun"} = $safe_hole->wrap ($cb);
829	}	913	}
830		914
		915	=back
		916
		917	#############################################################################
		918
		919	=head2 EXTENSION DATABASE SUPPORT
		920
		921	Crossfire maintains a very simple database for extension use. It can
		922	currently store anything that can be serialised using Storable, which
		923	excludes objects.
		924
		925	The parameter C<$family> should best start with the name of the extension
		926	using it, it should be unique.
		927
		928	=over 4
		929
		930	=item $hashref = cf::db_get $family
		931
		932	Return a hashref for use by the extension C<$family>, which can be
		933	modified. After modifications, you have to call C<cf::db_dirty> or
		934	C<cf::db_sync>.
		935
		936	=item $value = cf::db_get $family => $key
		937
		938	Returns a single value from the database
		939
		940	=item cf::db_put $family => $hashref
		941
		942	Stores the given family hashref into the database. Updates are delayed, if
		943	you want the data to be synced to disk immediately, use C<cf::db_sync>.
		944
		945	=item cf::db_put $family => $key => $value
		946
		947	Stores the given C<$value> in the family hash. Updates are delayed, if you
		948	want the data to be synced to disk immediately, use C<cf::db_sync>.
		949
		950	=item cf::db_dirty
		951
		952	Marks the database as dirty, to be updated at a later time.
		953
		954	=item cf::db_sync
		955
		956	Immediately write the database to disk I<if it is dirty>.
		957
		958	=cut
		959
		960	{
		961	my $db;
		962	my $path = cf::localdir . "/database.pst";
		963
		964	sub db_load() {
		965	warn "loading database $path\n";#d# remove later
		966	$db = stat $path ? Storable::retrieve $path : { };
		967	}
		968
		969	my $pid;
		970
		971	sub db_save() {
		972	warn "saving database $path\n";#d# remove later
		973	waitpid $pid, 0 if $pid;
		974	if (0 == ($pid = fork)) {
		975	$db->{_meta}{version} = 1;
		976	Storable::nstore $db, "$path~";
		977	rename "$path~", $path;
		978	cf::_exit 0 if defined $pid;
		979	}
		980	}
		981
		982	my $dirty;
		983
		984	sub db_sync() {
		985	db_save if $dirty;
		986	undef $dirty;
		987	}
		988
		989	my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub {
		990	db_sync;
		991	});
		992
		993	sub db_dirty() {
		994	$dirty = 1;
		995	$idle->start;
		996	}
		997
		998	sub db_get($;$) {
		999	@_ >= 2
		1000	? $db->{$_[0]}{$_[1]}
		1001	: ($db->{$_[0]} \|\|= { })
		1002	}
		1003
		1004	sub db_put($$;$) {
		1005	if (@_ >= 3) {
		1006	$db->{$_[0]}{$_[1]} = $_[2];
		1007	} else {
		1008	$db->{$_[0]} = $_[1];
		1009	}
		1010	db_dirty;
		1011	}
		1012
		1013	attach_global
		1014	prio => 10000,
		1015	on_cleanup => sub {
		1016	db_sync;
		1017	},
		1018	;
		1019	}
		1020
831	#############################################################################	1021	#############################################################################
832	# the server's main()	1022	# the server's main()
833		1023
834	sub main {	1024	sub main {
		1025	db_load;
		1026	load_extensions;
835	Event::loop;	1027	Event::loop;
836	}	1028	}
837		1029
838	#############################################################################	1030	#############################################################################
839	# initialisation	1031	# initialisation
840		1032
		1033	sub _perl_reload(&) {
		1034	my ($msg) = @_;
		1035
		1036	$msg->("reloading...");
		1037
		1038	eval {
		1039	# cancel all watchers
		1040	$_->cancel for Event::all_watchers;
		1041
		1042	# unload all extensions
		1043	for (@exts) {
		1044	$msg->("unloading <$_>");
		1045	unload_extension $_;
		1046	}
		1047
		1048	# unload all modules loaded from $LIBDIR
		1049	while (my ($k, $v) = each %INC) {
		1050	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
		1051
		1052	$msg->("removing <$k>");
		1053	delete $INC{$k};
		1054
		1055	$k =~ s/\.pm$//;
		1056	$k =~ s/\//::/g;
		1057
		1058	if (my $cb = $k->can ("unload_module")) {
		1059	$cb->();
		1060	}
		1061
		1062	Symbol::delete_package $k;
		1063	}
		1064
		1065	# sync database to disk
		1066	cf::db_sync;
		1067
		1068	# get rid of safe::, as good as possible
		1069	Symbol::delete_package "safe::$_"
		1070	for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
		1071
		1072	# remove register_script_function callbacks
		1073	# TODO
		1074
		1075	# unload cf.pm "a bit"
		1076	delete $INC{"cf.pm"};
		1077
		1078	# don't, removes xs symbols, too,
		1079	# and global variables created in xs
		1080	#Symbol::delete_package __PACKAGE__;
		1081
		1082	# reload cf.pm
		1083	$msg->("reloading cf.pm");
		1084	require cf;
		1085
		1086	# load database again
		1087	cf::db_load;
		1088
		1089	# load extensions
		1090	$msg->("load extensions");
		1091	cf::load_extensions;
		1092
		1093	# reattach attachments to objects
		1094	$msg->("reattach");
		1095	_global_reattach;
		1096	};
		1097	$msg->($@) if $@;
		1098
		1099	$msg->("reloaded");
		1100	};
		1101
		1102	sub perl_reload() {
		1103	_perl_reload {
		1104	warn $_[0];
		1105	print "$_[0]\n";
		1106	};
		1107	}
		1108
		1109	register_command "perl-reload", 0, sub {
		1110	my ($who, $arg) = @_;
		1111
		1112	if ($who->flag (FLAG_WIZ)) {
		1113	_perl_reload {
		1114	warn $_[0];
		1115	$who->message ($_[0]);
		1116	};
		1117	}
		1118	};
		1119
841	register "<global>", __PACKAGE__;	1120	register "<global>", __PACKAGE__;
842		1121
843	unshift @INC, $LIBDIR;	1122	unshift @INC, $LIBDIR;
844
845	load_extensions;
846		1123
847	$TICK_WATCHER = Event->timer (	1124	$TICK_WATCHER = Event->timer (
848	prio => 1,	1125	prio => 1,
849	at => $NEXT_TICK \|\| 1,	1126	at => $NEXT_TICK \|\| 1,
850	cb => sub {	1127	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.70 by root, Sun Oct 1 10:55:37 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.70 by root, Sun Oct 1 10:55:37 2006 UTC