[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.62 by root, Fri Sep 8 16:51:44 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	_reload_1;
		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;
…		…
32	print STDERR "cfperl: $msg";	32	print STDERR "cfperl: $msg";
33	LOG llevError, "cfperl: $msg";	33	LOG llevError, "cfperl: $msg";
34	};	34	};
35	}	35	}
36		36
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';	37	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
72		38
73	# we bless all objects into (empty) derived classes to force a method lookup	39	# we bless all objects into (empty) derived classes to force a method lookup
74	# within the Safe compartment.	40	# within the Safe compartment.
75	for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {	41	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';	42	no strict 'refs';
77	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	43	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
78	}	44	}
79		45
80	$Event::DIED = sub {	46	$Event::DIED = sub {
…		…
103	}	69	}
104		70
105	#############################################################################	71	#############################################################################
106	# "new" plug-in system	72	# "new" plug-in system
107		73
		74	=head3 EVENTS AND OBJECT ATTACHMENTS
		75
		76	=over 4
		77
		78	=item $object->attach ($attachment, key => $value...)
		79
108	=item $object->attach ($attachment, ...)	80	=item $object->detach ($attachment)
109		81
110	Attach a pre-registered attachment to an object.	82	Attach/detach a pre-registered attachment to an object.
111		83
		84	=item $player->attach ($attachment, key => $value...)
		85
112	=item $player->attach ($attachment, ...)	86	=item $player->detach ($attachment)
113		87
114	Attach a pre-registered attachment to a player.	88	Attach/detach a pre-registered attachment to a player.
115		89
116	=item $map->attach ($attachment, ...) # not yet persistent	90	=item $map->attach ($attachment, key => $value...)
117		91
		92	=item $map->detach ($attachment)
		93
118	Attach a pre-registered attachment to a map.	94	Attach/detach a pre-registered attachment to a map.
		95
		96	=item $bool = $object->attached ($name)
		97
		98	=item $bool = $player->attached ($name)
		99
		100	=item $bool = $map->attached ($name)
		101
		102	Checks wether the named attachment is currently attached to the object.
119		103
120	=item cf::attach_global ...	104	=item cf::attach_global ...
121		105
122	Attach handlers for global events.	106	Attach handlers for global events.
123		107
…		…
150	package and register them. Only handlers for eevents supported by the	134	package and register them. Only handlers for eevents supported by the
151	object/class are recognised.	135	object/class are recognised.
152		136
153	=back	137	=back
154		138
155	=item cf::attach_to_type $object_type, ...	139	=item cf::attach_to_type $object_type, $subtype, ...
156		140
157	Attach handlers for a specific object type (e.g. TRANSPORT).	141	Attach handlers for a specific object type (e.g. TRANSPORT) and
		142	subtype. If C<$subtype> is zero or undef, matches all objects of the given
		143	type.
158		144
159	=item cf::attach_to_objects ...	145	=item cf::attach_to_objects ...
160		146
161	Attach handlers to all objects. Do not use this except for debugging or	147	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	148	very rare events, as handlers are (obviously) called for I<all> objects in
…		…
169	=item cf::attach_to_maps ...	155	=item cf::attach_to_maps ...
170		156
171	Attach handlers to all maps.	157	Attach handlers to all maps.
172		158
173	=item cf:register_attachment $name, ...	159	=item cf:register_attachment $name, ...
		160
		161	Register an attachment by name through which objects can refer to this
		162	attachment.
		163
		164	=item cf:register_player_attachment $name, ...
		165
		166	Register an attachment by name through which players can refer to this
		167	attachment.
		168
		169	=item cf:register_map_attachment $name, ...
		170
		171	Register an attachment by name through which maps can refer to this
		172	attachment.
174		173
175	=cut	174	=cut
176		175
177	# the following variables are defined in .xs and must not be re-created	176	# the following variables are defined in .xs and must not be re-created
178	our @CB_GLOBAL = (); # registry for all global events	177	our @CB_GLOBAL = (); # registry for all global events
…		…
241		240
242	\%undo	241	\%undo
243	}	242	}
244		243
245	sub _attach_attachment {	244	sub _attach_attachment {
246	my ($klass, $obj, $name, @args) = q_;	245	my ($obj, $name, %arg) = @_;
		246
		247	return if exists $obj->{_attachment}{$name};
247		248
248	my $res;	249	my $res;
249		250
250	if (my $attach = $attachment{$name}) {	251	if (my $attach = $attachment{$name}) {
251	my $registry = $obj->registry;	252	my $registry = $obj->registry;
252		253
		254	for (@$attach) {
		255	my ($klass, @attach) = @$_;
253	$res = _attach @$registry, $klass, @$attach;	256	$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	}	257	}
263	}	258
		259	$obj->{$name} = \%arg;
264	} else {	260	} else {
265	warn "object uses attachment '$name' that is not available, postponing.\n";	261	warn "object uses attachment '$name' that is not available, postponing.\n";
266	}	262	}
267		263
268	push @{$obj->{_attachment}}, $name;	264	$obj->{_attachment}{$name} = undef;
269		265
270	$res->{attachment} = $name;	266	$res->{attachment} = $name;
271	$res	267	$res
272	}	268	}
273		269
274	sub cf::object::attach {	270	*cf::object::attach =
		271	*cf::player::attach =
		272	*cf::map::attach = sub {
275	my ($obj, $name, @args) = @_;	273	my ($obj, $name, %arg) = @_;
276		274
277	_attach_attachment KLASS_OBJECT, $obj, $name, @args;	275	_attach_attachment $obj, $name, %arg;
278	}	276	};
279		277
		278	# all those should be optimised
		279	*cf::object::detach =
280	sub cf::player::attach {	280	*cf::player::detach =
		281	*cf::map::detach = sub {
281	my ($obj, $name, @args) = @_;	282	my ($obj, $name) = @_;
282		283
283	_attach_attachment KLASS_PLAYER, $obj, $name, @args;	284	delete $obj->{_attachment}{$name};
284	}	285	reattach ($obj);
		286	};
285		287
286	sub cf::map::attach {	288	*cf::object::attached =
		289	*cf::player::attached =
		290	*cf::map::attached = sub {
287	my ($obj, $name, @args) = @_;	291	my ($obj, $name) = @_;
288		292
289	_attach_attachment KLASS_MAP, $obj, $name, @args;	293	exists $obj->{_attachment}{$name}
290	}	294	};
291		295
292	sub attach_global {	296	sub attach_global {
293	_attach @CB_GLOBAL, KLASS_GLOBAL, @_	297	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
294	}	298	}
295		299
296	sub attach_to_type {	300	sub attach_to_type {
297	my $type = shift;	301	my $type = shift;
		302	my $subtype = shift;
298		303
299	_attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_	304	_attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
300	}	305	}
301		306
302	sub attach_to_objects {	307	sub attach_to_objects {
303	_attach @CB_OBJECT, KLASS_OBJECT, @_	308	_attach @CB_OBJECT, KLASS_OBJECT, @_
304	}	309	}
…		…
312	}	317	}
313		318
314	sub register_attachment {	319	sub register_attachment {
315	my $name = shift;	320	my $name = shift;
316		321
		322	$attachment{$name} = [[KLASS_OBJECT, @_]];
		323	}
		324
		325	sub register_player_attachment {
		326	my $name = shift;
		327
		328	$attachment{$name} = [[KLASS_PLAYER, @_]];
		329	}
		330
		331	sub register_map_attachment {
		332	my $name = shift;
		333
317	$attachment{$name} = [@_];	334	$attachment{$name} = [[KLASS_MAP, @_]];
318	}	335	}
319		336
320	our $override;	337	our $override;
321	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	338	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
322		339
…		…
346	}	363	}
347		364
348	0	365	0
349	}	366	}
350		367
		368	=item $bool = cf::invoke EVENT_GLOBAL_XXX, ...
		369
		370	=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
		371
		372	=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
		373
		374	=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
		375
		376	Generate a global/object/player/map-specific event with the given arguments.
		377
		378	This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
		379	removed in future versions), and there is no public API to access override
		380	results (if you must, access C<@cf::invoke_results> directly).
		381
		382	=back
		383
		384	=head2 methods valid for all pointers
		385
		386	=over 4
		387
		388	=item $object->valid
		389
		390	=item $player->valid
		391
		392	=item $map->valid
		393
		394	Just because you have a perl object does not mean that the corresponding
		395	C-level object still exists. If you try to access an object that has no
		396	valid C counterpart anymore you get an exception at runtime. This method
		397	can be used to test for existence of the C object part without causing an
		398	exception.
		399
		400	=back
		401
		402	=cut
		403
		404	*cf::object::valid =
		405	*cf::player::valid =
		406	*cf::map::valid = \&cf::_valid;
		407
351	#############################################################################	408	#############################################################################
352	# object support	409	# object support
353		410
354	sub instantiate {	411	sub instantiate {
355	my ($obj, $data) = @_;	412	my ($obj, $data) = @_;
356		413
357	$data = from_json $data;	414	$data = from_json $data;
358		415
359	for (@$data) {	416	for (@$data) {
360	my ($name, $args) = @$_;	417	my ($name, $args) = @$_;
361	attach $obj, $name, @{$args \|\| [] };	418
		419	$obj->attach ($name, %{$args \|\| {} });
362	}	420	}
363	}	421	}
364		422
365	# basically do the same as instantiate, without calling instantiate	423	# basically do the same as instantiate, without calling instantiate
366	sub reattach {	424	sub reattach {
367	warn "reattach<@_>\n";#d#
368	my ($obj) = @_;	425	my ($obj) = @_;
369	my $registry = $obj->registry;	426	my $registry = $obj->registry;
370		427
		428	@$registry = ();
		429
		430	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };
		431
371	for my $name (@{ $obj->{_attachment} }) {	432	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {
372	if (my $attach = $attachment{$name}) {	433	if (my $attach = $attachment{$name}) {
		434	for (@$attach) {
		435	my ($klass, @attach) = @$_;
373	_attach @$registry, KLASS_OBJECT, @$attach;	436	_attach @$registry, $klass, @attach;
		437	}
374	} else {	438	} else {
375	warn "object uses attachment '$name' that is not available, postponing.\n";	439	warn "object uses attachment '$name' that is not available, postponing.\n";
376	}	440	}
377	}	441	}
378
379	warn "reattach<@_, $_>\n";
380	}	442	}
381		443
382	sub object_freezer_save {	444	sub object_freezer_save {
383	my ($filename, $objs) = @_;	445	my ($filename, $rdata, $objs) = @_;
384	warn "freeze $filename\n";#d#
385	use Data::Dumper; print Dumper $objs;
386		446
387	$filename .= ".pst";	447	if (length $$rdata) {
		448	warn sprintf "saving %s (%d,%d)\n",
		449	$filename, length $$rdata, scalar @$objs;
388		450
389	if (@$objs) {
390	open my $fh, ">:raw", "$filename~";	451	if (open my $fh, ">:raw", "$filename~") {
391	chmod $fh, SAVE_MODE;	452	chmod SAVE_MODE, $fh;
		453	syswrite $fh, $$rdata;
		454	close $fh;
		455
		456	if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
		457	chmod SAVE_MODE, $fh;
392	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };	458	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
393	close $fh;	459	close $fh;
		460	rename "$filename.pst~", "$filename.pst";
		461	} else {
		462	unlink "$filename.pst";
		463	}
		464
394	rename "$filename~", $filename;	465	rename "$filename~", $filename;
		466	} else {
		467	warn "FATAL: $filename~: $!\n";
		468	}
395	} else {	469	} else {
396	unlink $filename;	470	unlink $filename;
		471	unlink "$filename.pst";
397	}	472	}
398	}	473	}
399		474
400	sub object_thawer_load {	475	sub object_thawer_load {
401	my ($filename) = @_;	476	my ($filename) = @_;
402		477
403	warn "thaw $filename\n";#d#	478	local $/;
404		479
		480	my $av;
		481
		482	#TODO: use sysread etc.
		483	if (open my $data, "<:raw:perlio", $filename) {
		484	$data = <$data>;
405	open my $fh, "<:raw:perlio", "$filename.pst"	485	if (open my $pst, "<:raw:perlio", "$filename.pst") {
406	or return;	486	$av = eval { (Storable::thaw <$pst>)->{objs} };
		487	}
		488	return ($data, $av);
		489	}
407		490
408	eval { local $/; (Storable::thaw <$fh>)->{objs} }	491	()
409	}	492	}
410		493
411	attach_to_objects	494	attach_to_objects
412	prio => -1000000,	495	prio => -1000000,
413	on_clone => sub {	496	on_clone => sub {
414	my ($src, $dst) = @_;	497	my ($src, $dst) = @_;
415		498
416	@{$dst->registry} = @{$src->registry};	499	@{$dst->registry} = @{$src->registry};
417	warn "registry clone ", join ":", @{$src->registry};#d#
418		500
419	%$dst = %$src;	501	%$dst = %$src;
420		502
421	$dst->{_attachment} = [@{ $src->{_attachment} }]	503	%{$dst->{_attachment}} = %{$src->{_attachment}}
422	if exists $src->{_attachment};	504	if exists $src->{_attachment};
423
424	warn "clone<@_>\n";#d#
425	},	505	},
426	;	506	;
427		507
428	#############################################################################	508	#############################################################################
429	# old plug-in events	509	# old plug-in events
…		…
612	#Symbol::delete_package __PACKAGE__;	692	#Symbol::delete_package __PACKAGE__;
613		693
614	# 7. reload cf.pm	694	# 7. reload cf.pm
615	$msg->("reloading cf.pm");	695	$msg->("reloading cf.pm");
616	require cf;	696	require cf;
		697
		698	$msg->("load extensions");
		699	cf::load_extensions;
617	};	700	};
618	$msg->($@) if $@;	701	$msg->($@) if $@;
619		702
620	$msg->("reloaded");	703	$msg->("reloaded");
621	};	704	};
…		…
669	my ($map) = @_;	752	my ($map) = @_;
670		753
671	my $path = $map->tmpname;	754	my $path = $map->tmpname;
672	defined $path or return;	755	defined $path or return;
673		756
674	unlink "$path.cfperl";
675	unlink "$path.pst";	757	unlink "$path.pst";
676	};	758	};
677		759
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::;	760	attach_to_maps prio => -10000, package => cf::mapsupport::;
697		761
698	#############################################################################	762	#############################################################################
699	# load/save perl data associated with player->ob objects	763	# load/save perl data associated with player->ob objects
700		764
701	sub all_objects(@) {	765	sub all_objects(@) {
702	@_, map all_objects ($_->inv), @_	766	@_, map all_objects ($_->inv), @_
703	}	767	}
704		768
		769	# TODO: compatibility cruft, remove when no longer needed
705	attach_to_players	770	attach_to_players
706	on_load => sub {	771	on_load => sub {
707	my ($pl, $path) = @_;	772	my ($pl, $path) = @_;
708		773
709	for my $o (all_objects $pl->ob) {	774	for my $o (all_objects $pl->ob) {
…		…
830		895
831	#############################################################################	896	#############################################################################
832	# the server's main()	897	# the server's main()
833		898
834	sub main {	899	sub main {
		900	load_extensions;
835	Event::loop;	901	Event::loop;
836	}	902	}
837		903
838	#############################################################################	904	#############################################################################
839	# initialisation	905	# initialisation
840		906
841	register "<global>", __PACKAGE__;	907	register "<global>", __PACKAGE__;
842		908
843	unshift @INC, $LIBDIR;	909	unshift @INC, $LIBDIR;
844
845	load_extensions;
846		910
847	$TICK_WATCHER = Event->timer (	911	$TICK_WATCHER = Event->timer (
848	prio => 1,	912	prio => 1,
849	at => $NEXT_TICK \|\| 1,	913	at => $NEXT_TICK \|\| 1,
850	cb => sub {	914	cb => sub {
…		…
859	$TICK_WATCHER->at ($NEXT_TICK);	923	$TICK_WATCHER->at ($NEXT_TICK);
860	$TICK_WATCHER->start;	924	$TICK_WATCHER->start;
861	},	925	},
862	);	926	);
863		927
		928	_reload_2;
		929
864	1	930	1
865		931

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.62 by root, Fri Sep 8 16:51:44 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.62 by root, Fri Sep 8 16:51:44 2006 UTC