[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.53 by root, Tue Aug 29 13:11:58 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	=item $object->detach ($attachment)
		113
		114	Attach/detach a pre-registered attachment to an object.
		115
		116	=item $player->attach ($attachment, key => $value...)
		117
		118	=item $player->detach ($attachment)
		119
		120	Attach/detach a pre-registered attachment to a player.
		121
		122	=item $map->attach ($attachment, key => $value...)
		123
		124	=item $map->detach ($attachment)
		125
		126	Attach/detach a pre-registered attachment to a map.
109		127
110	=item cf::attach_global ...	128	=item cf::attach_global ...
111		129
		130	Attach handlers for global events.
		131
		132	This and all following C<attach_*>-functions expect any number of the
		133	following handler/hook descriptions:
		134
		135	=over 4
		136
		137	=item prio => $number
		138
		139	Set the priority for all following handlers/hooks (unless overwritten
		140	by another C<prio> setting). Lower priority handlers get executed
		141	earlier. The default priority is C<0>, and many built-in handlers are
		142	registered at priority C<-1000>, so lower priorities should not be used
		143	unless you know what you are doing.
		144
		145	=item on_I<event> => \&cb
		146
		147	Call the given code reference whenever the named event happens (event is
		148	something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
		149	handlers are recognised generally depends on the type of object these
		150	handlers attach to).
		151
		152	See F<include/eventinc.h> for the full list of events supported, and their
		153	class.
		154
		155	=item package => package::
		156
		157	Look for sub functions of the name C<< on_I<event> >> in the given
		158	package and register them. Only handlers for eevents supported by the
		159	object/class are recognised.
		160
		161	=back
		162
112	=item cf::attach_to_type $object_type, ...	163	=item cf::attach_to_type $object_type, $subtype, ...
		164
		165	Attach handlers for a specific object type (e.g. TRANSPORT) and
		166	subtype. If C<$subtype> is zero or undef, matches all objects of the given
		167	type.
113		168
114	=item cf::attach_to_objects ...	169	=item cf::attach_to_objects ...
115		170
		171	Attach handlers to all objects. Do not use this except for debugging or
		172	very rare events, as handlers are (obviously) called for I<all> objects in
		173	the game.
		174
116	=item cf::attach_to_players ...	175	=item cf::attach_to_players ...
117		176
		177	Attach handlers to all players.
		178
118	=item cf::attach_to_maps ...	179	=item cf::attach_to_maps ...
119		180
		181	Attach handlers to all maps.
		182
120	=item cf:register_attachment $name, ...	183	=item cf:register_attachment $name, ...
121		184
122	prio => $number, # lower is earlier	185	Register an attachment by name through which objects can refer to this
123	on_xxx => \&cb,	186	attachment.
124	package => package::,	187
		188	=item cf:register_map_attachment $name, ...
		189
		190	Register an attachment by name through which maps can refer to this
		191	attachment.
125		192
126	=cut	193	=cut
127		194
128	# the following variables are defined in .xs and must not be re-created	195	# the following variables are defined in .xs and must not be re-created
129	our @CB_GLOBAL = (); # registry for all global events	196	our @CB_GLOBAL = (); # registry for all global events
…		…
191	}	258	}
192		259
193	\%undo	260	\%undo
194	}	261	}
195		262
		263	sub _attach_attachment {
		264	my ($obj, $name, %arg) = @_;
		265
		266	my $res;
		267
		268	if (my $attach = $attachment{$name}) {
		269	my $registry = $obj->registry;
		270
		271	for (@$attach) {
		272	my ($klass, @attach) = @$_;
		273	$res = _attach @$registry, $klass, @attach;
		274	}
		275
		276	$obj->{$name} = \%arg;
		277	} else {
		278	warn "object uses attachment '$name' that is not available, postponing.\n";
		279	}
		280
		281	$obj->{_attachment}{$name} = undef;
		282
		283	$res->{attachment} = $name;
		284	$res
		285	}
		286
196	sub cf::object::attach {	287	sub cf::object::attach {
		288	my ($obj, $name, %arg) = @_;
		289
		290	_attach_attachment $obj, $name, %arg;
		291	}
		292
		293	sub cf::player::attach {
		294	my ($obj, $name, %arg) = @_;
		295
		296	_attach_attachment $obj, $name, %arg;
		297	}
		298
		299	sub cf::map::attach {
		300	my ($obj, $name, %arg) = @_;
		301
		302	_attach_attachment $obj, $name, %arg;
		303	}
		304
		305	sub cf::object::detach {
		306	my ($obj, $name) = @_;
197	die;	307	die;#d#
		308	}
		309	sub cf::player::detach {
		310	my ($obj, $name) = @_;
		311	die;#d#
		312	}
		313	sub cf::map::detach {
		314	my ($obj, $name) = @_;
		315	die;#d#
198	}	316	}
199		317
200	sub attach_global {	318	sub attach_global {
201	_attach @CB_GLOBAL, KLASS_GLOBAL, @_	319	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
202	}	320	}
203		321
204	sub attach_to_type {	322	sub attach_to_type {
205	my $type = shift;	323	my $type = shift;
		324	my $subtype = shift;
206		325
207	_attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_	326	_attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
208	}	327	}
209		328
210	sub attach_to_objects {	329	sub attach_to_objects {
211	_attach @CB_OBJECT, KLASS_OBJECT, @_	330	_attach @CB_OBJECT, KLASS_OBJECT, @_
212	}	331	}
…		…
220	}	339	}
221		340
222	sub register_attachment {	341	sub register_attachment {
223	my $name = shift;	342	my $name = shift;
224		343
		344	$attachment{$name} = [[KLASS_OBJECT, @_]];
		345	}
		346
		347	sub register_map_attachment {
		348	my $name = shift;
		349
225	$attachment{$name} = [@_];	350	$attachment{$name} = [[KLASS_MAP, @_]];
226	}	351	}
227		352
228	our $override;	353	our $override;
229	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	354	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
230		355
…		…
259	#############################################################################	384	#############################################################################
260	# object support	385	# object support
261		386
262	sub instantiate {	387	sub instantiate {
263	my ($obj, $data) = @_;	388	my ($obj, $data) = @_;
264	my $registry = $obj->registry;
265		389
266	$data = from_json $data;	390	$data = from_json $data;
267		391
268	for (@$data) {	392	for (@$data) {
269	my ($pri, $name, @args) = @$_;	393	my ($name, $args) = @$_;
270		394
271	if (my $attach = $attachment{$name}) {	395	$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	}	396	}
289	}	397	}
290		398
291	# basically do the same as instantiate, without calling instantiate	399	# basically do the same as instantiate, without calling instantiate
292	sub reattach {	400	sub reattach {
293	my ($obj) = @_;	401	my ($obj) = @_;
294	my $registry = $obj->registry;	402	my $registry = $obj->registry;
295		403
296	warn "reattach<@_, $_>\n";	404	@$registry = ();
		405
		406	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };
		407
		408	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {
		409	if (my $attach = $attachment{$name}) {
		410	for (@$attach) {
		411	my ($klass, @attach) = @$_;
		412	_attach @$registry, $klass, @attach;
		413	}
		414	} else {
		415	warn "object uses attachment '$name' that is not available, postponing.\n";
		416	}
		417	}
		418	}
		419
		420	sub object_freezer_save {
		421	my ($filename, $objs) = @_;
		422
		423	if (@$objs) {
		424	open my $fh, ">:raw", "$filename.pst~";
		425	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
		426	close $fh;
		427	chmod SAVE_MODE, "$filename.pst~";
		428	rename "$filename.pst~", "$filename.pst";
		429	} else {
		430	unlink "$filename.pst";
		431	}
		432
		433	chmod SAVE_MODE, "$filename~";
		434	rename "$filename~", $filename;
		435	}
		436
		437	sub object_thawer_load {
		438	my ($filename) = @_;
		439
		440	open my $fh, "<:raw:perlio", "$filename.pst"
		441	or return;
		442
		443	eval { local $/; (Storable::thaw <$fh>)->{objs} }
297	}	444	}
298		445
299	attach_to_objects	446	attach_to_objects
300	prio => -1000000,	447	prio => -1000000,
301	on_clone => sub {	448	on_clone => sub {
302	my ($src, $dst) = @_;	449	my ($src, $dst) = @_;
303		450
304	@{$dst->registry} = @{$src->registry};	451	@{$dst->registry} = @{$src->registry};
305	warn "registry clone ", join ":", @{$src->registry};#d#
306		452
307	%$dst = %$src;	453	%$dst = %$src;
308		454
309	$dst->{_attachment} = [@{ $src->{_attachment} }]	455	%{$dst->{_attachment}} = %{$src->{_attachment}}
310	if exists $src->{_attachment};	456	if exists $src->{_attachment};
311
312	warn "clone<@_>\n";#d#
313	},	457	},
314	;	458	;
315		459
316	#############################################################################	460	#############################################################################
317	# old plug-in events	461	# old plug-in events
…		…
557	my ($map) = @_;	701	my ($map) = @_;
558		702
559	my $path = $map->tmpname;	703	my $path = $map->tmpname;
560	defined $path or return;	704	defined $path or return;
561		705
562	unlink "$path.cfperl";	706	unlink "$path.pst";
563	};	707	};
564		708
		709	# old style persistent data, TODO: remove #d#
565	*cf::mapsupport::on_swapin =	710	*cf::mapsupport::on_swapin =
566	*cf::mapsupport::on_load = sub {	711	*cf::mapsupport::on_load = sub {
567	my ($map) = @_;	712	my ($map) = @_;
568		713
569	my $path = $map->tmpname;	714	my $path = $map->tmpname;
…		…
576		721
577	$data->{version} <= 1	722	$data->{version} <= 1
578	or return; # too new	723	or return; # too new
579		724
580	$map->_set_obs ($data->{obs});	725	$map->_set_obs ($data->{obs});
581	};	726	$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	};	727	};
609		728
610	attach_to_maps prio => -10000, package => cf::mapsupport::;	729	attach_to_maps prio => -10000, package => cf::mapsupport::;
611		730
612	#############################################################################	731	#############################################################################
…		…
625	$o->set_ob_key_value ("_perl_data");	744	$o->set_ob_key_value ("_perl_data");
626		745
627	%$o = %{ Storable::thaw pack "H*", $value };	746	%$o = %{ Storable::thaw pack "H*", $value };
628	}	747	}
629	}	748	}
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	},	749	},
637	;	750	;
638		751
639	#############################################################################	752	#############################################################################
640	# core extensions - in perl	753	# core extensions - in perl
…		…
779	$TICK_WATCHER->at ($NEXT_TICK);	892	$TICK_WATCHER->at ($NEXT_TICK);
780	$TICK_WATCHER->start;	893	$TICK_WATCHER->start;
781	},	894	},
782	);	895	);
783		896
		897	_reload_2;
		898
784	1	899	1
785		900

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.53 by root, Tue Aug 29 13:11:58 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.53 by root, Tue Aug 29 13:11:58 2006 UTC