--- deliantra/server/lib/cf.pm 2006/08/28 14:05:24 1.51 +++ deliantra/server/lib/cf.pm 2006/08/30 08:28:33 1.56 @@ -107,17 +107,35 @@ ############################################################################# # "new" plug-in system +=head3 EVENTS AND OBJECT ATTACHMENTS + +=over 4 + =item $object->attach ($attachment, key => $value...) -Attach a pre-registered attachment to an object. +=item $object->detach ($attachment) + +Attach/detach a pre-registered attachment to an object. =item $player->attach ($attachment, key => $value...) -Attach a pre-registered attachment to a player. +=item $player->detach ($attachment) + +Attach/detach a pre-registered attachment to a player. + +=item $map->attach ($attachment, key => $value...) + +=item $map->detach ($attachment) -=item $map->attach ($attachment, key => $value...) # not yet persistent +Attach/detach a pre-registered attachment to a map. -Attach a pre-registered attachment to a map. +=item $bool = $object->attached ($name) + +=item $bool = $player->attached ($name) + +=item $bool = $map->attached ($name) + +Checks wether the named attachment is currently attached to the object. =item cf::attach_global ... @@ -176,6 +194,19 @@ =item cf:register_attachment $name, ... +Register an attachment by name through which objects can refer to this +attachment. + +=item cf:register_player_attachment $name, ... + +Register an attachment by name through which players can refer to this +attachment. + +=item cf:register_map_attachment $name, ... + +Register an attachment by name through which maps can refer to this +attachment. + =cut # the following variables are defined in .xs and must not be re-created @@ -249,6 +280,8 @@ sub _attach_attachment { my ($obj, $name, %arg) = @_; + return if exists $obj->{_attachment}{$name}; + my $res; if (my $attach = $attachment{$name}) { @@ -270,23 +303,31 @@ $res } -sub cf::object::attach { +*cf::object::attach = +*cf::player::attach = +*cf::map::attach = sub { my ($obj, $name, %arg) = @_; _attach_attachment $obj, $name, %arg; -} +}; -sub cf::player::attach { - my ($obj, $name, %arg) = @_; +# all those should be optimised +*cf::object::detach = +*cf::player::detach = +*cf::map::detach = sub { + my ($obj, $name) = @_; - _attach_attachment KLASS_PLAYER, $obj, $name, %arg; -} + delete $obj->{_attachment}{$name}; + reattach ($obj); +}; -sub cf::map::attach { - my ($obj, $name, %arg) = @_; +*cf::object::attached = +*cf::player::attached = +*cf::map::attached = sub { + my ($obj, $name) = @_; - _attach_attachment KLASS_MAP, $obj, $name, %arg; -} + exists $obj->{_attachment}{$name} +}; sub attach_global { _attach @CB_GLOBAL, KLASS_GLOBAL, @_ @@ -317,6 +358,18 @@ $attachment{$name} = [[KLASS_OBJECT, @_]]; } +sub register_player_attachment { + my $name = shift; + + $attachment{$name} = [[KLASS_PLAYER, @_]]; +} + +sub register_map_attachment { + my $name = shift; + + $attachment{$name} = [[KLASS_MAP, @_]]; +} + our $override; our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? @@ -348,6 +401,46 @@ 0 } +=item $bool = cf::invoke EVENT_GLOBAL_XXX, ... + +=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...) + +=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...) + +=item $bool = $map->invoke (EVENT_MAP_XXX, ...) + +Generate a global/object/player/map-specific event with the given arguments. + +This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be +removed in future versions), and there is no public API to access override +results (if you must, access C<@cf::invoke_results> directly). + +=back + +=head2 methods valid for all pointers + +=over 4 + +=item $object->valid + +=item $player->valid + +=item $map->valid + +Just because you have a perl object does not mean that the corresponding +C-level object still exists. If you try to access an object that has no +valid C counterpart anymore you get an exception at runtime. This method +can be used to test for existence of the C object part without causing an +exception. + +=back + +=cut + +*cf::object::valid = +*cf::player::valid = +*cf::map::valid = \&cf::_valid; + ############################################################################# # object support @@ -674,13 +767,14 @@ }; # old style persistent data, TODO: remove #d# -*cf::mapsupport::on_swapin = -*cf::mapsupport::on_load = sub { +*cf::mapsupport::on_swapin = sub { my ($map) = @_; my $path = $map->tmpname; $path = $map->path unless defined $path; + warn "$path.cfperl\n";#d# + open my $fh, "<:raw", "$path.cfperl" or return; # no perl data