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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.45 by root, Sat Aug 26 23:36:32 2006 UTC vs.
Revision 1.52 by root, Mon Aug 28 16:52:51 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
108	=item cf::object::attach ... # NYI	110	=item $object->attach ($attachment, key => $value...)
		111
		112	Attach a pre-registered attachment to an object.
		113
		114	=item $player->attach ($attachment, key => $value...)
		115
		116	Attach a pre-registered attachment to a player.
		117
		118	=item $map->attach ($attachment, key => $value...) # not yet persistent
		119
		120	Attach a pre-registered attachment to a map.
109		121
110	=item cf::attach_global ...	122	=item cf::attach_global ...
111		123
		124	Attach handlers for global events.
		125
		126	This and all following C<attach_*>-functions expect any number of the
		127	following handler/hook descriptions:
		128
		129	=over 4
		130
		131	=item prio => $number
		132
		133	Set the priority for all following handlers/hooks (unless overwritten
		134	by another C<prio> setting). Lower priority handlers get executed
		135	earlier. The default priority is C<0>, and many built-in handlers are
		136	registered at priority C<-1000>, so lower priorities should not be used
		137	unless you know what you are doing.
		138
		139	=item on_I<event> => \&cb
		140
		141	Call the given code reference whenever the named event happens (event is
		142	something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
		143	handlers are recognised generally depends on the type of object these
		144	handlers attach to).
		145
		146	See F<include/eventinc.h> for the full list of events supported, and their
		147	class.
		148
		149	=item package => package::
		150
		151	Look for sub functions of the name C<< on_I<event> >> in the given
		152	package and register them. Only handlers for eevents supported by the
		153	object/class are recognised.
		154
		155	=back
		156
112	=item cf::attach_to_type $object_type, ...	157	=item cf::attach_to_type $object_type, $subtype, ...
		158
		159	Attach handlers for a specific object type (e.g. TRANSPORT) and
		160	subtype. If C<$subtype> is zero or undef, matches all objects of the given
		161	type.
113		162
114	=item cf::attach_to_objects ...	163	=item cf::attach_to_objects ...
115		164
		165	Attach handlers to all objects. Do not use this except for debugging or
		166	very rare events, as handlers are (obviously) called for I<all> objects in
		167	the game.
		168
116	=item cf::attach_to_players ...	169	=item cf::attach_to_players ...
117		170
		171	Attach handlers to all players.
		172
118	=item cf::attach_to_maps ...	173	=item cf::attach_to_maps ...
119		174
		175	Attach handlers to all maps.
		176
120	=item cf:register_attachment $name, ...	177	=item cf:register_attachment $name, ...
121		178
122	prio => $number, # lower is earlier	179	Register an attachment by name through which objects can refer to this
123	on_xxx => \&cb,	180	attachment.
124	package => package::,	181
		182	=item cf:register_map_attachment $name, ...
		183
		184	Register an attachment by name through which maps can refer to this
		185	attachment.
125		186
126	=cut	187	=cut
127		188
128	# the following variables are defined in .xs and must not be re-created	189	# the following variables are defined in .xs and must not be re-created
129	our @CB_GLOBAL = (); # registry for all global events	190	our @CB_GLOBAL = (); # registry for all global events
…		…
191	}	252	}
192		253
193	\%undo	254	\%undo
194	}	255	}
195		256
		257	sub _attach_attachment {
		258	my ($obj, $name, %arg) = @_;
		259
		260	my $res;
		261
		262	if (my $attach = $attachment{$name}) {
		263	my $registry = $obj->registry;
		264
		265	for (@$attach) {
		266	my ($klass, @attach) = @$_;
		267	$res = _attach @$registry, $klass, @attach;
		268	}
		269
		270	$obj->{$name} = \%arg;
		271	} else {
		272	warn "object uses attachment '$name' that is not available, postponing.\n";
		273	}
		274
		275	$obj->{_attachment}{$name} = undef;
		276
		277	$res->{attachment} = $name;
		278	$res
		279	}
		280
196	sub cf::object::attach {	281	sub cf::object::attach {
197	die;	282	my ($obj, $name, %arg) = @_;
		283
		284	_attach_attachment $obj, $name, %arg;
		285	}
		286
		287	sub cf::player::attach {
		288	my ($obj, $name, %arg) = @_;
		289
		290	_attach_attachment $obj, $name, %arg;
		291	}
		292
		293	sub cf::map::attach {
		294	my ($obj, $name, %arg) = @_;
		295
		296	_attach_attachment $obj, $name, %arg;
198	}	297	}
199		298
200	sub attach_global {	299	sub attach_global {
201	_attach @CB_GLOBAL, KLASS_GLOBAL, @_	300	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
202	}	301	}
203		302
204	sub attach_to_type {	303	sub attach_to_type {
205	my $type = shift;	304	my $type = shift;
		305	my $subtype = shift;
206		306
207	_attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_	307	_attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
208	}	308	}
209		309
210	sub attach_to_objects {	310	sub attach_to_objects {
211	_attach @CB_OBJECT, KLASS_OBJECT, @_	311	_attach @CB_OBJECT, KLASS_OBJECT, @_
212	}	312	}
…		…
220	}	320	}
221		321
222	sub register_attachment {	322	sub register_attachment {
223	my $name = shift;	323	my $name = shift;
224		324
		325	$attachment{$name} = [[KLASS_OBJECT, @_]];
		326	}
		327
		328	sub register_map_attachment {
		329	my $name = shift;
		330
225	$attachment{$name} = [@_];	331	$attachment{$name} = [[KLASS_MAP, @_]];
226	}	332	}
227		333
228	our $override;	334	our $override;
229	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	335	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
230		336
…		…
259	#############################################################################	365	#############################################################################
260	# object support	366	# object support
261		367
262	sub instantiate {	368	sub instantiate {
263	my ($obj, $data) = @_;	369	my ($obj, $data) = @_;
264	my $registry = $obj->registry;
265		370
266	$data = from_json $data;	371	$data = from_json $data;
267		372
268	for (@$data) {	373	for (@$data) {
269	my ($pri, $name, @args) = @$_;	374	my ($name, $args) = @$_;
270		375
271	if (my $attach = $attachment{$name}) {	376	$obj->attach ($name, %{$args \|\| {} });
272	_attach @$registry, KLASS_OBJECT, @$attach;
273
274	if (my $cb = delete $registry->[EVENT_OBJECT_INSTANTIATE]) {
275	for (@$cb) {
276	eval { $_->[1]->($obj, @args); };
277	if ($@) {
278	warn "$@";
279	warn "... while processing '$name' instantiate with args <@args>\n";
280	}
281	}
282	}
283	} else {
284	warn "object uses attachment $name that is not available, postponing.\n";
285	}
286
287	push @{$obj->{_attachment}}, $name;
288	}	377	}
289	}	378	}
290		379
291	# basically do the same as instantiate, without calling instantiate	380	# basically do the same as instantiate, without calling instantiate
292	sub reattach {	381	sub reattach {
293	my ($obj) = @_;	382	my ($obj) = @_;
294	my $registry = $obj->registry;	383	my $registry = $obj->registry;
295		384
296	warn "reattach<@_, $_>\n";	385	@$registry = ();
		386
		387	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };
		388
		389	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {
		390	if (my $attach = $attachment{$name}) {
		391	for (@$attach) {
		392	my ($klass, @attach) = @$_;
		393	_attach @$registry, $klass, @attach;
		394	}
		395	} else {
		396	warn "object uses attachment '$name' that is not available, postponing.\n";
		397	}
		398	}
		399	}
		400
		401	sub object_freezer_save {
		402	my ($filename, $objs) = @_;
		403
		404	if (@$objs) {
		405	open my $fh, ">:raw", "$filename.pst~";
		406	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
		407	close $fh;
		408	chmod SAVE_MODE, "$filename.pst~";
		409	rename "$filename.pst~", "$filename.pst";
		410	} else {
		411	unlink "$filename.pst";
		412	}
		413
		414	chmod SAVE_MODE, "$filename~";
		415	rename "$filename~", $filename;
		416	}
		417
		418	sub object_thawer_load {
		419	my ($filename) = @_;
		420
		421	open my $fh, "<:raw:perlio", "$filename.pst"
		422	or return;
		423
		424	eval { local $/; (Storable::thaw <$fh>)->{objs} }
297	}	425	}
298		426
299	attach_to_objects	427	attach_to_objects
300	prio => -1000000,	428	prio => -1000000,
301	on_clone => sub {	429	on_clone => sub {
302	my ($src, $dst) = @_;	430	my ($src, $dst) = @_;
303		431
304	@{$dst->registry} = @{$src->registry};	432	@{$dst->registry} = @{$src->registry};
305	warn "registry clone ", join ":", @{$src->registry};#d#
306		433
307	%$dst = %$src;	434	%$dst = %$src;
308		435
309	$dst->{_attachment} = [@{ $src->{_attachment} }]	436	%{$dst->{_attachment}} = %{$src->{_attachment}}
310	if exists $src->{_attachment};	437	if exists $src->{_attachment};
311
312	warn "clone<@_>\n";#d#
313	},	438	},
314	;	439	;
315		440
316	#############################################################################	441	#############################################################################
317	# old plug-in events	442	# old plug-in events
…		…
557	my ($map) = @_;	682	my ($map) = @_;
558		683
559	my $path = $map->tmpname;	684	my $path = $map->tmpname;
560	defined $path or return;	685	defined $path or return;
561		686
562	unlink "$path.cfperl";	687	unlink "$path.pst";
563	};	688	};
564		689
		690	# old style persistent data, TODO: remove #d#
565	*cf::mapsupport::on_swapin =	691	*cf::mapsupport::on_swapin =
566	*cf::mapsupport::on_load = sub {	692	*cf::mapsupport::on_load = sub {
567	my ($map) = @_;	693	my ($map) = @_;
568		694
569	my $path = $map->tmpname;	695	my $path = $map->tmpname;
…		…
576		702
577	$data->{version} <= 1	703	$data->{version} <= 1
578	or return; # too new	704	or return; # too new
579		705
580	$map->_set_obs ($data->{obs});	706	$map->_set_obs ($data->{obs});
581	};	707	$map->invoke (EVENT_MAP_UPGRADE);
582
583	*cf::mapsupport::on_swapout = sub {
584	my ($map) = @_;
585
586	my $path = $map->tmpname;
587	$path = $map->path unless defined $path;
588
589	my $obs = $map->_get_obs;
590
591	if (defined $obs) {
592	open my $fh, ">:raw", "$path.cfperl"
593	or die "$path.cfperl: $!";
594
595	stat $path;
596
597	print $fh Storable::nfreeze {
598	size => (stat _)[7],
599	time => (stat _)[9],
600	version => 1,
601	obs => $obs,
602	};
603
604	chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible g
605	} else {
606	unlink "$path.cfperl";
607	}
608	};	708	};
609		709
610	attach_to_maps prio => -10000, package => cf::mapsupport::;	710	attach_to_maps prio => -10000, package => cf::mapsupport::;
611		711
612	#############################################################################	712	#############################################################################
…		…
625	$o->set_ob_key_value ("_perl_data");	725	$o->set_ob_key_value ("_perl_data");
626		726
627	%$o = %{ Storable::thaw pack "H*", $value };	727	%$o = %{ Storable::thaw pack "H*", $value };
628	}	728	}
629	}	729	}
630	},
631	on_save => sub {
632	my ($pl, $path) = @_;
633
634	$_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
635	for grep %$_, all_objects $pl->ob;
636	},	730	},
637	;	731	;
638		732
639	#############################################################################	733	#############################################################################
640	# core extensions - in perl	734	# core extensions - in perl
…		…
779	$TICK_WATCHER->at ($NEXT_TICK);	873	$TICK_WATCHER->at ($NEXT_TICK);
780	$TICK_WATCHER->start;	874	$TICK_WATCHER->start;
781	},	875	},
782	);	876	);
783		877
		878	_reload_2;
		879
784	1	880	1
785		881

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.45 by root, Sat Aug 26 23:36:32 2006 UTC vs. Revision 1.52 by root, Mon Aug 28 16:52:51 2006 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.45 by root, Sat Aug 26 23:36:32 2006 UTC vs.
Revision 1.52 by root, Mon Aug 28 16:52:51 2006 UTC