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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.47 by root, Sun Aug 27 13:02:04 2006 UTC vs.
Revision 1.62 by root, Fri Sep 8 16:51:44 2006 UTC

…		…
15		15
16	_reload_1;	16	_reload_1;
17		17
18	our %COMMAND = ();	18	our %COMMAND = ();
19	our @EVENT;	19	our @EVENT;
20	our %PROP_TYPE;
21	our %PROP_IDX;
22	our $LIBDIR = maps_directory "perl";	20	our $LIBDIR = maps_directory "perl";
23		21
24	our $TICK = MAX_TIME * 1e-6;	22	our $TICK = MAX_TIME * 1e-6;
25	our $TICK_WATCHER;	23	our $TICK_WATCHER;
26	our $NEXT_TICK;	24	our $NEXT_TICK;
…		…
34	print STDERR "cfperl: $msg";	32	print STDERR "cfperl: $msg";
35	LOG llevError, "cfperl: $msg";	33	LOG llevError, "cfperl: $msg";
36	};	34	};
37	}	35	}
38		36
39	my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply!
40
41	# generate property mutators
42	sub prop_gen {
43	my ($prefix, $class) = @_;
44
45	no strict 'refs';
46
47	for my $prop (keys %PROP_TYPE) {
48	$prop =~ /^\Q$prefix\E_(.*$)/ or next;
49	my $sub = lc $1;
50
51	my $type = $PROP_TYPE{$prop};
52	my $idx = $PROP_IDX {$prop};
53
54	{"$class\::get_$sub"} = {"$class\::$sub"} = sub {
55	$_[0]->get_property ($type, $idx)
56	};
57
58	*{"$class\::set_$sub"} = sub {
59	$_[0]->set_property ($type, $idx, $_[1]);
60	} unless $ignore_set{$prop};
61	}
62	}
63
64	# auto-generate most of the API
65
66	prop_gen OBJECT_PROP => "cf::object";
67	# CFAPI_OBJECT_ANIMATION?
68	prop_gen PLAYER_PROP => "cf::object::player";
69
70	prop_gen MAP_PROP => "cf::map";
71	prop_gen ARCH_PROP => "cf::arch";
72
73	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';	37	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
74		38
75	# 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
76	# within the Safe compartment.	40	# within the Safe compartment.
77	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)) {
78	no strict 'refs';	42	no strict 'refs';
79	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	43	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
80	}	44	}
81		45
82	$Event::DIED = sub {	46	$Event::DIED = sub {
…		…
105	}	69	}
106		70
107	#############################################################################	71	#############################################################################
108	# "new" plug-in system	72	# "new" plug-in system
109		73
		74	=head3 EVENTS AND OBJECT ATTACHMENTS
		75
		76	=over 4
		77
		78	=item $object->attach ($attachment, key => $value...)
		79
110	=item $object->attach ($attachment, ...)	80	=item $object->detach ($attachment)
111		81
112	Attach a pre-registered attachment to an object.	82	Attach/detach a pre-registered attachment to an object.
113		83
		84	=item $player->attach ($attachment, key => $value...)
		85
114	=item $player->attach ($attachment, ...)	86	=item $player->detach ($attachment)
115		87
116	Attach a pre-registered attachment to a player.	88	Attach/detach a pre-registered attachment to a player.
117		89
118	=item $map->attach ($attachment, ...) # not yet persistent	90	=item $map->attach ($attachment, key => $value...)
119		91
		92	=item $map->detach ($attachment)
		93
120	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.
121		103
122	=item cf::attach_global ...	104	=item cf::attach_global ...
123		105
124	Attach handlers for global events.	106	Attach handlers for global events.
125		107
…		…
173	=item cf::attach_to_maps ...	155	=item cf::attach_to_maps ...
174		156
175	Attach handlers to all maps.	157	Attach handlers to all maps.
176		158
177	=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.
178		173
179	=cut	174	=cut
180		175
181	# 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
182	our @CB_GLOBAL = (); # registry for all global events	177	our @CB_GLOBAL = (); # registry for all global events
…		…
245		240
246	\%undo	241	\%undo
247	}	242	}
248		243
249	sub _attach_attachment {	244	sub _attach_attachment {
250	my ($obj, $name, @args) = @_;	245	my ($obj, $name, %arg) = @_;
		246
		247	return if exists $obj->{_attachment}{$name};
251		248
252	my $res;	249	my $res;
253		250
254	if (my $attach = $attachment{$name}) {	251	if (my $attach = $attachment{$name}) {
255	my $registry = $obj->registry;	252	my $registry = $obj->registry;
…		…
257	for (@$attach) {	254	for (@$attach) {
258	my ($klass, @attach) = @$_;	255	my ($klass, @attach) = @$_;
259	$res = _attach @$registry, $klass, @attach;	256	$res = _attach @$registry, $klass, @attach;
260	}	257	}
261		258
262	if (my $cb = delete $registry->[EVENT_OBJECT_INSTANTIATE]) {	259	$obj->{$name} = \%arg;
263	for (@$cb) {
264	eval { $_->[1]->($obj, @args); };
265	if ($@) {
266	warn "$@";
267	warn "... while processing '$name' instantiate with args <@args>.\n";
268	}
269	}
270	}
271	} else {	260	} else {
272	warn "object uses attachment '$name' that is not available, postponing.\n";	261	warn "object uses attachment '$name' that is not available, postponing.\n";
273	}	262	}
274		263
275	push @{$obj->{_attachment}}, $name;	264	$obj->{_attachment}{$name} = undef;
276		265
277	$res->{attachment} = $name;	266	$res->{attachment} = $name;
278	$res	267	$res
279	}	268	}
280		269
281	sub cf::object::attach {	270	*cf::object::attach =
		271	*cf::player::attach =
		272	*cf::map::attach = sub {
282	my ($obj, $name, @args) = @_;	273	my ($obj, $name, %arg) = @_;
283		274
284	_attach_attachment $obj, $name, @args;	275	_attach_attachment $obj, $name, %arg;
285	}	276	};
286		277
		278	# all those should be optimised
		279	*cf::object::detach =
287	sub cf::player::attach {	280	*cf::player::detach =
		281	*cf::map::detach = sub {
288	my ($obj, $name, @args) = @_;	282	my ($obj, $name) = @_;
289		283
290	_attach_attachment KLASS_PLAYER, $obj, $name, @args;	284	delete $obj->{_attachment}{$name};
291	}	285	reattach ($obj);
		286	};
292		287
293	sub cf::map::attach {	288	*cf::object::attached =
		289	*cf::player::attached =
		290	*cf::map::attached = sub {
294	my ($obj, $name, @args) = @_;	291	my ($obj, $name) = @_;
295		292
296	_attach_attachment KLASS_MAP, $obj, $name, @args;	293	exists $obj->{_attachment}{$name}
297	}	294	};
298		295
299	sub attach_global {	296	sub attach_global {
300	_attach @CB_GLOBAL, KLASS_GLOBAL, @_	297	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
301	}	298	}
302		299
…		…
321		318
322	sub register_attachment {	319	sub register_attachment {
323	my $name = shift;	320	my $name = shift;
324		321
325	$attachment{$name} = [[KLASS_OBJECT, @_]];	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
		334	$attachment{$name} = [[KLASS_MAP, @_]];
326	}	335	}
327		336
328	our $override;	337	our $override;
329	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?
330		339
…		…
354	}	363	}
355		364
356	0	365	0
357	}	366	}
358		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
359	#############################################################################	408	#############################################################################
360	# object support	409	# object support
361		410
362	sub instantiate {	411	sub instantiate {
363	my ($obj, $data) = @_;	412	my ($obj, $data) = @_;
364		413
365	$data = from_json $data;	414	$data = from_json $data;
366		415
367	for (@$data) {	416	for (@$data) {
368	my ($name, $args) = @$_;	417	my ($name, $args) = @$_;
369	attach $obj, $name, @{$args \|\| [] };	418
		419	$obj->attach ($name, %{$args \|\| {} });
370	}	420	}
371	}	421	}
372		422
373	# basically do the same as instantiate, without calling instantiate	423	# basically do the same as instantiate, without calling instantiate
374	sub reattach {	424	sub reattach {
375	my ($obj) = @_;	425	my ($obj) = @_;
376	my $registry = $obj->registry;	426	my $registry = $obj->registry;
377		427
378	@$registry = ();	428	@$registry = ();
379		429
		430	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };
		431
380	for my $name (@{ $obj->{_attachment} }) {	432	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {
381	if (my $attach = $attachment{$name}) {	433	if (my $attach = $attachment{$name}) {
382	for (@$attach) {	434	for (@$attach) {
383	my ($klass, @attach) = @$_;	435	my ($klass, @attach) = @$_;
384	_attach @$registry, $klass, @attach;	436	_attach @$registry, $klass, @attach;
385	}	437	}
…		…
388	}	440	}
389	}	441	}
390	}	442	}
391		443
392	sub object_freezer_save {	444	sub object_freezer_save {
393	my ($filename, $objs) = @_;	445	my ($filename, $rdata, $objs) = @_;
394		446
395	$filename .= ".pst";	447	if (length $$rdata) {
		448	warn sprintf "saving %s (%d,%d)\n",
		449	$filename, length $$rdata, scalar @$objs;
396		450
397	if (@$objs) {
398	open my $fh, ">:raw", "$filename~";	451	if (open my $fh, ">:raw", "$filename~") {
399	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;
400	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };	458	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
401	close $fh;	459	close $fh;
		460	rename "$filename.pst~", "$filename.pst";
		461	} else {
		462	unlink "$filename.pst";
		463	}
		464
402	rename "$filename~", $filename;	465	rename "$filename~", $filename;
		466	} else {
		467	warn "FATAL: $filename~: $!\n";
		468	}
403	} else {	469	} else {
404	unlink $filename;	470	unlink $filename;
		471	unlink "$filename.pst";
405	}	472	}
406	}	473	}
407		474
408	sub object_thawer_load {	475	sub object_thawer_load {
409	my ($filename) = @_;	476	my ($filename) = @_;
410		477
		478	local $/;
		479
		480	my $av;
		481
		482	#TODO: use sysread etc.
		483	if (open my $data, "<:raw:perlio", $filename) {
		484	$data = <$data>;
411	open my $fh, "<:raw:perlio", "$filename.pst"	485	if (open my $pst, "<:raw:perlio", "$filename.pst") {
412	or return;	486	$av = eval { (Storable::thaw <$pst>)->{objs} };
		487	}
		488	return ($data, $av);
		489	}
413		490
414	eval { local $/; (Storable::thaw <$fh>)->{objs} }	491	()
415	}	492	}
416		493
417	attach_to_objects	494	attach_to_objects
418	prio => -1000000,	495	prio => -1000000,
419	on_clone => sub {	496	on_clone => sub {
…		…
421		498
422	@{$dst->registry} = @{$src->registry};	499	@{$dst->registry} = @{$src->registry};
423		500
424	%$dst = %$src;	501	%$dst = %$src;
425		502
426	$dst->{_attachment} = [@{ $src->{_attachment} }]	503	%{$dst->{_attachment}} = %{$src->{_attachment}}
427	if exists $src->{_attachment};	504	if exists $src->{_attachment};
428	},	505	},
429	;	506	;
430		507
431	#############################################################################	508	#############################################################################
…		…
615	#Symbol::delete_package __PACKAGE__;	692	#Symbol::delete_package __PACKAGE__;
616		693
617	# 7. reload cf.pm	694	# 7. reload cf.pm
618	$msg->("reloading cf.pm");	695	$msg->("reloading cf.pm");
619	require cf;	696	require cf;
		697
		698	$msg->("load extensions");
		699	cf::load_extensions;
620	};	700	};
621	$msg->($@) if $@;	701	$msg->($@) if $@;
622		702
623	$msg->("reloaded");	703	$msg->("reloaded");
624	};	704	};
…		…
672	my ($map) = @_;	752	my ($map) = @_;
673		753
674	my $path = $map->tmpname;	754	my $path = $map->tmpname;
675	defined $path or return;	755	defined $path or return;
676		756
677	unlink "$path.cfperl";
678	unlink "$path.pst";	757	unlink "$path.pst";
679	};	758	};
680		759
681	*cf::mapsupport::on_swapin =
682	*cf::mapsupport::on_load = sub {
683	my ($map) = @_;
684
685	my $path = $map->tmpname;
686	$path = $map->path unless defined $path;
687
688	open my $fh, "<:raw", "$path.cfperl"
689	or return; # no perl data
690
691	my $data = Storable::thaw do { local $/; <$fh> };
692
693	$data->{version} <= 1
694	or return; # too new
695
696	$map->_set_obs ($data->{obs});
697	};
698
699	attach_to_maps prio => -10000, package => cf::mapsupport::;	760	attach_to_maps prio => -10000, package => cf::mapsupport::;
700		761
701	#############################################################################	762	#############################################################################
702	# load/save perl data associated with player->ob objects	763	# load/save perl data associated with player->ob objects
703		764
704	sub all_objects(@) {	765	sub all_objects(@) {
705	@_, map all_objects ($_->inv), @_	766	@_, map all_objects ($_->inv), @_
706	}	767	}
707		768
		769	# TODO: compatibility cruft, remove when no longer needed
708	attach_to_players	770	attach_to_players
709	on_load => sub {	771	on_load => sub {
710	my ($pl, $path) = @_;	772	my ($pl, $path) = @_;
711		773
712	for my $o (all_objects $pl->ob) {	774	for my $o (all_objects $pl->ob) {
…		…
833		895
834	#############################################################################	896	#############################################################################
835	# the server's main()	897	# the server's main()
836		898
837	sub main {	899	sub main {
		900	load_extensions;
838	Event::loop;	901	Event::loop;
839	}	902	}
840		903
841	#############################################################################	904	#############################################################################
842	# initialisation	905	# initialisation
843		906
844	register "<global>", __PACKAGE__;	907	register "<global>", __PACKAGE__;
845		908
846	unshift @INC, $LIBDIR;	909	unshift @INC, $LIBDIR;
847
848	load_extensions;
849		910
850	$TICK_WATCHER = Event->timer (	911	$TICK_WATCHER = Event->timer (
851	prio => 1,	912	prio => 1,
852	at => $NEXT_TICK \|\| 1,	913	at => $NEXT_TICK \|\| 1,
853	cb => sub {	914	cb => sub {

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.47 by root, Sun Aug 27 13:02:04 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.47 by root, Sun Aug 27 13:02:04 2006 UTC vs.
Revision 1.62 by root, Fri Sep 8 16:51:44 2006 UTC