[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.61 by root, Sun Sep 3 22:45:56 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;	20	our %PROP_TYPE;
19	our %PROP_IDX;	21	our %PROP_IDX;
20	our $LIBDIR = maps_directory "perl";	22	our $LIBDIR = maps_directory "perl";
…		…
70		72
71	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';	73	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
72		74
73	# we bless all objects into (empty) derived classes to force a method lookup	75	# we bless all objects into (empty) derived classes to force a method lookup
74	# within the Safe compartment.	76	# within the Safe compartment.
75	for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {	77	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';	78	no strict 'refs';
77	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	79	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
78	}	80	}
79		81
80	$Event::DIED = sub {	82	$Event::DIED = sub {
…		…
103	}	105	}
104		106
105	#############################################################################	107	#############################################################################
106	# "new" plug-in system	108	# "new" plug-in system
107		109
		110	=head3 EVENTS AND OBJECT ATTACHMENTS
		111
		112	=over 4
		113
		114	=item $object->attach ($attachment, key => $value...)
		115
108	=item $object->attach ($attachment, ...)	116	=item $object->detach ($attachment)
109		117
110	Attach a pre-registered attachment to an object.	118	Attach/detach a pre-registered attachment to an object.
111		119
		120	=item $player->attach ($attachment, key => $value...)
		121
112	=item $player->attach ($attachment, ...)	122	=item $player->detach ($attachment)
113		123
114	Attach a pre-registered attachment to a player.	124	Attach/detach a pre-registered attachment to a player.
115		125
116	=item $map->attach ($attachment, ...) # not yet persistent	126	=item $map->attach ($attachment, key => $value...)
117		127
		128	=item $map->detach ($attachment)
		129
118	Attach a pre-registered attachment to a map.	130	Attach/detach a pre-registered attachment to a map.
		131
		132	=item $bool = $object->attached ($name)
		133
		134	=item $bool = $player->attached ($name)
		135
		136	=item $bool = $map->attached ($name)
		137
		138	Checks wether the named attachment is currently attached to the object.
119		139
120	=item cf::attach_global ...	140	=item cf::attach_global ...
121		141
122	Attach handlers for global events.	142	Attach handlers for global events.
123		143
…		…
150	package and register them. Only handlers for eevents supported by the	170	package and register them. Only handlers for eevents supported by the
151	object/class are recognised.	171	object/class are recognised.
152		172
153	=back	173	=back
154		174
155	=item cf::attach_to_type $object_type, ...	175	=item cf::attach_to_type $object_type, $subtype, ...
156		176
157	Attach handlers for a specific object type (e.g. TRANSPORT).	177	Attach handlers for a specific object type (e.g. TRANSPORT) and
		178	subtype. If C<$subtype> is zero or undef, matches all objects of the given
		179	type.
158		180
159	=item cf::attach_to_objects ...	181	=item cf::attach_to_objects ...
160		182
161	Attach handlers to all objects. Do not use this except for debugging or	183	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	184	very rare events, as handlers are (obviously) called for I<all> objects in
…		…
169	=item cf::attach_to_maps ...	191	=item cf::attach_to_maps ...
170		192
171	Attach handlers to all maps.	193	Attach handlers to all maps.
172		194
173	=item cf:register_attachment $name, ...	195	=item cf:register_attachment $name, ...
		196
		197	Register an attachment by name through which objects can refer to this
		198	attachment.
		199
		200	=item cf:register_player_attachment $name, ...
		201
		202	Register an attachment by name through which players can refer to this
		203	attachment.
		204
		205	=item cf:register_map_attachment $name, ...
		206
		207	Register an attachment by name through which maps can refer to this
		208	attachment.
174		209
175	=cut	210	=cut
176		211
177	# the following variables are defined in .xs and must not be re-created	212	# the following variables are defined in .xs and must not be re-created
178	our @CB_GLOBAL = (); # registry for all global events	213	our @CB_GLOBAL = (); # registry for all global events
…		…
241		276
242	\%undo	277	\%undo
243	}	278	}
244		279
245	sub _attach_attachment {	280	sub _attach_attachment {
246	my ($klass, $obj, $name, @args) = q_;	281	my ($obj, $name, %arg) = @_;
		282
		283	return if exists $obj->{_attachment}{$name};
247		284
248	my $res;	285	my $res;
249		286
250	if (my $attach = $attachment{$name}) {	287	if (my $attach = $attachment{$name}) {
251	my $registry = $obj->registry;	288	my $registry = $obj->registry;
252		289
		290	for (@$attach) {
		291	my ($klass, @attach) = @$_;
253	$res = _attach @$registry, $klass, @$attach;	292	$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	}	293	}
263	}	294
		295	$obj->{$name} = \%arg;
264	} else {	296	} else {
265	warn "object uses attachment '$name' that is not available, postponing.\n";	297	warn "object uses attachment '$name' that is not available, postponing.\n";
266	}	298	}
267		299
268	push @{$obj->{_attachment}}, $name;	300	$obj->{_attachment}{$name} = undef;
269		301
270	$res->{attachment} = $name;	302	$res->{attachment} = $name;
271	$res	303	$res
272	}	304	}
273		305
274	sub cf::object::attach {	306	*cf::object::attach =
		307	*cf::player::attach =
		308	*cf::map::attach = sub {
275	my ($obj, $name, @args) = @_;	309	my ($obj, $name, %arg) = @_;
276		310
277	_attach_attachment KLASS_OBJECT, $obj, $name, @args;	311	_attach_attachment $obj, $name, %arg;
278	}	312	};
279		313
		314	# all those should be optimised
		315	*cf::object::detach =
280	sub cf::player::attach {	316	*cf::player::detach =
		317	*cf::map::detach = sub {
281	my ($obj, $name, @args) = @_;	318	my ($obj, $name) = @_;
282		319
283	_attach_attachment KLASS_PLAYER, $obj, $name, @args;	320	delete $obj->{_attachment}{$name};
284	}	321	reattach ($obj);
		322	};
285		323
286	sub cf::map::attach {	324	*cf::object::attached =
		325	*cf::player::attached =
		326	*cf::map::attached = sub {
287	my ($obj, $name, @args) = @_;	327	my ($obj, $name) = @_;
288		328
289	_attach_attachment KLASS_MAP, $obj, $name, @args;	329	exists $obj->{_attachment}{$name}
290	}	330	};
291		331
292	sub attach_global {	332	sub attach_global {
293	_attach @CB_GLOBAL, KLASS_GLOBAL, @_	333	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
294	}	334	}
295		335
296	sub attach_to_type {	336	sub attach_to_type {
297	my $type = shift;	337	my $type = shift;
		338	my $subtype = shift;
298		339
299	_attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_	340	_attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
300	}	341	}
301		342
302	sub attach_to_objects {	343	sub attach_to_objects {
303	_attach @CB_OBJECT, KLASS_OBJECT, @_	344	_attach @CB_OBJECT, KLASS_OBJECT, @_
304	}	345	}
…		…
312	}	353	}
313		354
314	sub register_attachment {	355	sub register_attachment {
315	my $name = shift;	356	my $name = shift;
316		357
		358	$attachment{$name} = [[KLASS_OBJECT, @_]];
		359	}
		360
		361	sub register_player_attachment {
		362	my $name = shift;
		363
		364	$attachment{$name} = [[KLASS_PLAYER, @_]];
		365	}
		366
		367	sub register_map_attachment {
		368	my $name = shift;
		369
317	$attachment{$name} = [@_];	370	$attachment{$name} = [[KLASS_MAP, @_]];
318	}	371	}
319		372
320	our $override;	373	our $override;
321	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	374	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
322		375
…		…
346	}	399	}
347		400
348	0	401	0
349	}	402	}
350		403
		404	=item $bool = cf::invoke EVENT_GLOBAL_XXX, ...
		405
		406	=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
		407
		408	=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
		409
		410	=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
		411
		412	Generate a global/object/player/map-specific event with the given arguments.
		413
		414	This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
		415	removed in future versions), and there is no public API to access override
		416	results (if you must, access C<@cf::invoke_results> directly).
		417
		418	=back
		419
		420	=head2 methods valid for all pointers
		421
		422	=over 4
		423
		424	=item $object->valid
		425
		426	=item $player->valid
		427
		428	=item $map->valid
		429
		430	Just because you have a perl object does not mean that the corresponding
		431	C-level object still exists. If you try to access an object that has no
		432	valid C counterpart anymore you get an exception at runtime. This method
		433	can be used to test for existence of the C object part without causing an
		434	exception.
		435
		436	=back
		437
		438	=cut
		439
		440	*cf::object::valid =
		441	*cf::player::valid =
		442	*cf::map::valid = \&cf::_valid;
		443
351	#############################################################################	444	#############################################################################
352	# object support	445	# object support
353		446
354	sub instantiate {	447	sub instantiate {
355	my ($obj, $data) = @_;	448	my ($obj, $data) = @_;
356		449
357	$data = from_json $data;	450	$data = from_json $data;
358		451
359	for (@$data) {	452	for (@$data) {
360	my ($name, $args) = @$_;	453	my ($name, $args) = @$_;
361	attach $obj, $name, @{$args \|\| [] };	454
		455	$obj->attach ($name, %{$args \|\| {} });
362	}	456	}
363	}	457	}
364		458
365	# basically do the same as instantiate, without calling instantiate	459	# basically do the same as instantiate, without calling instantiate
366	sub reattach {	460	sub reattach {
367	warn "reattach<@_>\n";#d#
368	my ($obj) = @_;	461	my ($obj) = @_;
369	my $registry = $obj->registry;	462	my $registry = $obj->registry;
370		463
		464	@$registry = ();
		465
		466	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };
		467
371	for my $name (@{ $obj->{_attachment} }) {	468	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {
372	if (my $attach = $attachment{$name}) {	469	if (my $attach = $attachment{$name}) {
		470	for (@$attach) {
		471	my ($klass, @attach) = @$_;
373	_attach @$registry, KLASS_OBJECT, @$attach;	472	_attach @$registry, $klass, @attach;
		473	}
374	} else {	474	} else {
375	warn "object uses attachment '$name' that is not available, postponing.\n";	475	warn "object uses attachment '$name' that is not available, postponing.\n";
376	}	476	}
377	}	477	}
378
379	warn "reattach<@_, $_>\n";
380	}	478	}
381		479
382	sub object_freezer_save {	480	sub object_freezer_save {
383	my ($filename, $objs) = @_;	481	my ($filename, $rdata, $objs) = @_;
384	warn "freeze $filename\n";#d#
385	use Data::Dumper; print Dumper $objs;
386		482
387	$filename .= ".pst";	483	if (length $$rdata) {
		484	warn sprintf "saving %s (%d,%d)\n",
		485	$filename, length $$rdata, scalar @$objs;
388		486
389	if (@$objs) {
390	open my $fh, ">:raw", "$filename~";	487	if (open my $fh, ">:raw", "$filename~") {
391	chmod $fh, SAVE_MODE;	488	chmod SAVE_MODE, $fh;
		489	syswrite $fh, $$rdata;
		490	close $fh;
		491
		492	if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
		493	chmod SAVE_MODE, $fh;
392	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };	494	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
393	close $fh;	495	close $fh;
		496	rename "$filename.pst~", "$filename.pst";
		497	} else {
		498	unlink "$filename.pst";
		499	}
		500
394	rename "$filename~", $filename;	501	rename "$filename~", $filename;
		502	} else {
		503	warn "FATAL: $filename~: $!\n";
		504	}
395	} else {	505	} else {
396	unlink $filename;	506	unlink $filename;
		507	unlink "$filename.pst";
397	}	508	}
398	}	509	}
399		510
400	sub object_thawer_load {	511	sub object_thawer_load {
401	my ($filename) = @_;	512	my ($filename) = @_;
402		513
403	warn "thaw $filename\n";#d#	514	local $/;
404		515
		516	my $av;
		517
		518	#TODO: use sysread etc.
		519	if (open my $data, "<:raw:perlio", $filename) {
		520	$data = <$data>;
405	open my $fh, "<:raw:perlio", "$filename.pst"	521	if (open my $pst, "<:raw:perlio", "$filename.pst") {
406	or return;	522	$av = eval { (Storable::thaw <$pst>)->{objs} };
		523	}
		524	return ($data, $av);
		525	}
407		526
408	eval { local $/; (Storable::thaw <$fh>)->{objs} }	527	()
409	}	528	}
410		529
411	attach_to_objects	530	attach_to_objects
412	prio => -1000000,	531	prio => -1000000,
413	on_clone => sub {	532	on_clone => sub {
414	my ($src, $dst) = @_;	533	my ($src, $dst) = @_;
415		534
416	@{$dst->registry} = @{$src->registry};	535	@{$dst->registry} = @{$src->registry};
417	warn "registry clone ", join ":", @{$src->registry};#d#
418		536
419	%$dst = %$src;	537	%$dst = %$src;
420		538
421	$dst->{_attachment} = [@{ $src->{_attachment} }]	539	%{$dst->{_attachment}} = %{$src->{_attachment}}
422	if exists $src->{_attachment};	540	if exists $src->{_attachment};
423
424	warn "clone<@_>\n";#d#
425	},	541	},
426	;	542	;
427		543
428	#############################################################################	544	#############################################################################
429	# old plug-in events	545	# old plug-in events
…		…
612	#Symbol::delete_package __PACKAGE__;	728	#Symbol::delete_package __PACKAGE__;
613		729
614	# 7. reload cf.pm	730	# 7. reload cf.pm
615	$msg->("reloading cf.pm");	731	$msg->("reloading cf.pm");
616	require cf;	732	require cf;
		733
		734	$msg->("load extensions");
		735	cf::load_extensions;
617	};	736	};
618	$msg->($@) if $@;	737	$msg->($@) if $@;
619		738
620	$msg->("reloaded");	739	$msg->("reloaded");
621	};	740	};
…		…
669	my ($map) = @_;	788	my ($map) = @_;
670		789
671	my $path = $map->tmpname;	790	my $path = $map->tmpname;
672	defined $path or return;	791	defined $path or return;
673		792
674	unlink "$path.cfperl";
675	unlink "$path.pst";	793	unlink "$path.pst";
676	};	794	};
677		795
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::;	796	attach_to_maps prio => -10000, package => cf::mapsupport::;
697		797
698	#############################################################################	798	#############################################################################
699	# load/save perl data associated with player->ob objects	799	# load/save perl data associated with player->ob objects
700		800
701	sub all_objects(@) {	801	sub all_objects(@) {
702	@_, map all_objects ($_->inv), @_	802	@_, map all_objects ($_->inv), @_
703	}	803	}
704		804
		805	# TODO: compatibility cruft, remove when no longer needed
705	attach_to_players	806	attach_to_players
706	on_load => sub {	807	on_load => sub {
707	my ($pl, $path) = @_;	808	my ($pl, $path) = @_;
708		809
709	for my $o (all_objects $pl->ob) {	810	for my $o (all_objects $pl->ob) {
…		…
830		931
831	#############################################################################	932	#############################################################################
832	# the server's main()	933	# the server's main()
833		934
834	sub main {	935	sub main {
		936	load_extensions;
835	Event::loop;	937	Event::loop;
836	}	938	}
837		939
838	#############################################################################	940	#############################################################################
839	# initialisation	941	# initialisation
840		942
841	register "<global>", __PACKAGE__;	943	register "<global>", __PACKAGE__;
842		944
843	unshift @INC, $LIBDIR;	945	unshift @INC, $LIBDIR;
844
845	load_extensions;
846		946
847	$TICK_WATCHER = Event->timer (	947	$TICK_WATCHER = Event->timer (
848	prio => 1,	948	prio => 1,
849	at => $NEXT_TICK \|\| 1,	949	at => $NEXT_TICK \|\| 1,
850	cb => sub {	950	cb => sub {
…		…
859	$TICK_WATCHER->at ($NEXT_TICK);	959	$TICK_WATCHER->at ($NEXT_TICK);
860	$TICK_WATCHER->start;	960	$TICK_WATCHER->start;
861	},	961	},
862	);	962	);
863		963
		964	_reload_2;
		965
864	1	966	1
865		967

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.61 by root, Sun Sep 3 22:45:56 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.61 by root, Sun Sep 3 22:45:56 2006 UTC