[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.59 by root, Wed Aug 30 16:30:37 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	=head3 EVENTS AND OBJECT ATTACHMENTS
		111
		112	=over 4
		113
		114	=item $object->attach ($attachment, key => $value...)
		115
		116	=item $object->detach ($attachment)
		117
		118	Attach/detach a pre-registered attachment to an object.
		119
		120	=item $player->attach ($attachment, key => $value...)
		121
		122	=item $player->detach ($attachment)
		123
		124	Attach/detach a pre-registered attachment to a player.
		125
		126	=item $map->attach ($attachment, key => $value...)
		127
		128	=item $map->detach ($attachment)
		129
		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.
109		139
110	=item cf::attach_global ...	140	=item cf::attach_global ...
111		141
		142	Attach handlers for global events.
		143
		144	This and all following C<attach_*>-functions expect any number of the
		145	following handler/hook descriptions:
		146
		147	=over 4
		148
		149	=item prio => $number
		150
		151	Set the priority for all following handlers/hooks (unless overwritten
		152	by another C<prio> setting). Lower priority handlers get executed
		153	earlier. The default priority is C<0>, and many built-in handlers are
		154	registered at priority C<-1000>, so lower priorities should not be used
		155	unless you know what you are doing.
		156
		157	=item on_I<event> => \&cb
		158
		159	Call the given code reference whenever the named event happens (event is
		160	something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
		161	handlers are recognised generally depends on the type of object these
		162	handlers attach to).
		163
		164	See F<include/eventinc.h> for the full list of events supported, and their
		165	class.
		166
		167	=item package => package::
		168
		169	Look for sub functions of the name C<< on_I<event> >> in the given
		170	package and register them. Only handlers for eevents supported by the
		171	object/class are recognised.
		172
		173	=back
		174
112	=item cf::attach_to_type $object_type, ...	175	=item cf::attach_to_type $object_type, $subtype, ...
		176
		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.
113		180
114	=item cf::attach_to_objects ...	181	=item cf::attach_to_objects ...
115		182
		183	Attach handlers to all objects. Do not use this except for debugging or
		184	very rare events, as handlers are (obviously) called for I<all> objects in
		185	the game.
		186
116	=item cf::attach_to_players ...	187	=item cf::attach_to_players ...
117		188
		189	Attach handlers to all players.
		190
118	=item cf::attach_to_maps ...	191	=item cf::attach_to_maps ...
119		192
		193	Attach handlers to all maps.
		194
120	=item cf:register_attachment $name, ...	195	=item cf:register_attachment $name, ...
121		196
122	prio => $number, # lower is earlier	197	Register an attachment by name through which objects can refer to this
123	on_xxx => \&cb,	198	attachment.
124	package => package::,	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.
125		209
126	=cut	210	=cut
127		211
128	# 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
129	our @CB_GLOBAL = (); # registry for all global events	213	our @CB_GLOBAL = (); # registry for all global events
…		…
191	}	275	}
192		276
193	\%undo	277	\%undo
194	}	278	}
195		279
		280	sub _attach_attachment {
		281	my ($obj, $name, %arg) = @_;
		282
		283	return if exists $obj->{_attachment}{$name};
		284
		285	my $res;
		286
		287	if (my $attach = $attachment{$name}) {
		288	my $registry = $obj->registry;
		289
		290	for (@$attach) {
		291	my ($klass, @attach) = @$_;
		292	$res = _attach @$registry, $klass, @attach;
		293	}
		294
		295	$obj->{$name} = \%arg;
		296	} else {
		297	warn "object uses attachment '$name' that is not available, postponing.\n";
		298	}
		299
		300	$obj->{_attachment}{$name} = undef;
		301
		302	$res->{attachment} = $name;
		303	$res
		304	}
		305
196	sub cf::object::attach {	306	*cf::object::attach =
197	die;	307	*cf::player::attach =
198	}	308	*cf::map::attach = sub {
		309	my ($obj, $name, %arg) = @_;
		310
		311	_attach_attachment $obj, $name, %arg;
		312	};
		313
		314	# all those should be optimised
		315	*cf::object::detach =
		316	*cf::player::detach =
		317	*cf::map::detach = sub {
		318	my ($obj, $name) = @_;
		319
		320	delete $obj->{_attachment}{$name};
		321	reattach ($obj);
		322	};
		323
		324	*cf::object::attached =
		325	*cf::player::attached =
		326	*cf::map::attached = sub {
		327	my ($obj, $name) = @_;
		328
		329	exists $obj->{_attachment}{$name}
		330	};
199		331
200	sub attach_global {	332	sub attach_global {
201	_attach @CB_GLOBAL, KLASS_GLOBAL, @_	333	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
202	}	334	}
203		335
204	sub attach_to_type {	336	sub attach_to_type {
205	my $type = shift;	337	my $type = shift;
		338	my $subtype = shift;
206		339
207	_attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_	340	_attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
208	}	341	}
209		342
210	sub attach_to_objects {	343	sub attach_to_objects {
211	_attach @CB_OBJECT, KLASS_OBJECT, @_	344	_attach @CB_OBJECT, KLASS_OBJECT, @_
212	}	345	}
…		…
220	}	353	}
221		354
222	sub register_attachment {	355	sub register_attachment {
223	my $name = shift;	356	my $name = shift;
224		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
225	$attachment{$name} = [@_];	370	$attachment{$name} = [[KLASS_MAP, @_]];
226	}	371	}
227		372
228	our $override;	373	our $override;
229	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?
230		375
…		…
254	}	399	}
255		400
256	0	401	0
257	}	402	}
258		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
259	#############################################################################	444	#############################################################################
260	# object support	445	# object support
261		446
262	sub instantiate {	447	sub instantiate {
263	my ($obj, $data) = @_;	448	my ($obj, $data) = @_;
264	my $registry = $obj->registry;
265		449
266	$data = from_json $data;	450	$data = from_json $data;
267		451
268	for (@$data) {	452	for (@$data) {
269	my ($pri, $name, @args) = @$_;	453	my ($name, $args) = @$_;
270		454
271	if (my $attach = $attachment{$name}) {	455	$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	}	456	}
289	}	457	}
290		458
291	# basically do the same as instantiate, without calling instantiate	459	# basically do the same as instantiate, without calling instantiate
292	sub reattach {	460	sub reattach {
293	my ($obj) = @_;	461	my ($obj) = @_;
294	my $registry = $obj->registry;	462	my $registry = $obj->registry;
295		463
296	warn "reattach<@_, $_>\n";	464	@$registry = ();
		465
		466	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };
		467
		468	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {
		469	if (my $attach = $attachment{$name}) {
		470	for (@$attach) {
		471	my ($klass, @attach) = @$_;
		472	_attach @$registry, $klass, @attach;
		473	}
		474	} else {
		475	warn "object uses attachment '$name' that is not available, postponing.\n";
		476	}
		477	}
		478	}
		479
		480	sub object_freezer_save {
		481	my ($filename, $rdata, $objs) = @_;
		482
		483	if (open my $fh, ">:raw", "$filename~") {
		484	chmod SAVE_MODE, $fh;
		485	syswrite $fh, $$rdata;
		486	close $fh;
		487
		488	if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
		489	chmod SAVE_MODE, $fh;
		490	syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
		491	close $fh;
		492	rename "$filename.pst~", "$filename.pst";
		493	} else {
		494	unlink "$filename.pst";
		495	}
		496
		497	rename "$filename~", $filename;
		498	} else {
		499	warn "FATAL: $filename~: $!\n";
		500	}
		501	}
		502
		503	sub object_thawer_load {
		504	my ($filename) = @_;
		505
		506	open my $fh, "<:raw:perlio", "$filename.pst"
		507	or return;
		508
		509	eval { local $/; (Storable::thaw <$fh>)->{objs} }
297	}	510	}
298		511
299	attach_to_objects	512	attach_to_objects
300	prio => -1000000,	513	prio => -1000000,
301	on_clone => sub {	514	on_clone => sub {
302	my ($src, $dst) = @_;	515	my ($src, $dst) = @_;
303		516
304	@{$dst->registry} = @{$src->registry};	517	@{$dst->registry} = @{$src->registry};
305	warn "registry clone ", join ":", @{$src->registry};#d#
306		518
307	%$dst = %$src;	519	%$dst = %$src;
308		520
309	$dst->{_attachment} = [@{ $src->{_attachment} }]	521	%{$dst->{_attachment}} = %{$src->{_attachment}}
310	if exists $src->{_attachment};	522	if exists $src->{_attachment};
311
312	warn "clone<@_>\n";#d#
313	},	523	},
314	;	524	;
315		525
316	#############################################################################	526	#############################################################################
317	# old plug-in events	527	# old plug-in events
…		…
557	my ($map) = @_;	767	my ($map) = @_;
558		768
559	my $path = $map->tmpname;	769	my $path = $map->tmpname;
560	defined $path or return;	770	defined $path or return;
561		771
562	unlink "$path.cfperl";	772	unlink "$path.pst";
563	};
564
565	*cf::mapsupport::on_swapin =
566	*cf::mapsupport::on_load = sub {
567	my ($map) = @_;
568
569	my $path = $map->tmpname;
570	$path = $map->path unless defined $path;
571
572	open my $fh, "<:raw", "$path.cfperl"
573	or return; # no perl data
574
575	my $data = Storable::thaw do { local $/; <$fh> };
576
577	$data->{version} <= 1
578	or return; # too new
579
580	$map->_set_obs ($data->{obs});
581	};
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	};	773	};
609		774
610	attach_to_maps prio => -10000, package => cf::mapsupport::;	775	attach_to_maps prio => -10000, package => cf::mapsupport::;
611		776
612	#############################################################################	777	#############################################################################
…		…
625	$o->set_ob_key_value ("_perl_data");	790	$o->set_ob_key_value ("_perl_data");
626		791
627	%$o = %{ Storable::thaw pack "H*", $value };	792	%$o = %{ Storable::thaw pack "H*", $value };
628	}	793	}
629	}	794	}
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	},	795	},
637	;	796	;
638		797
639	#############################################################################	798	#############################################################################
640	# core extensions - in perl	799	# core extensions - in perl
…		…
779	$TICK_WATCHER->at ($NEXT_TICK);	938	$TICK_WATCHER->at ($NEXT_TICK);
780	$TICK_WATCHER->start;	939	$TICK_WATCHER->start;
781	},	940	},
782	);	941	);
783		942
		943	_reload_2;
		944
784	1	945	1
785		946

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.59 by root, Wed Aug 30 16:30:37 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.59 by root, Wed Aug 30 16:30:37 2006 UTC