--- deliantra/server/lib/cf.pm 2006/08/25 15:31:44 1.42 +++ deliantra/server/lib/cf.pm 2006/08/27 16:15:12 1.46 @@ -15,7 +15,6 @@ our %COMMAND = (); our @EVENT; -our @PLUGIN_EVENT; our %PROP_TYPE; our %PROP_IDX; our $LIBDIR = maps_directory "perl"; @@ -25,8 +24,6 @@ our $NEXT_TICK; BEGIN { - @PLUGIN_EVENT = map lc, @PLUGIN_EVENT; - *CORE::GLOBAL::warn = sub { my $msg = join "", @_; $msg .= "\n" @@ -71,14 +68,11 @@ prop_gen MAP_PROP => "cf::map"; prop_gen ARCH_PROP => "cf::arch"; -# guessed hierarchies - @safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; -@safe::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object'; # we bless all objects into (empty) derived classes to force a method lookup # within the Safe compartment. -for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) { +for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch)) { no strict 'refs'; @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; } @@ -94,33 +88,101 @@ my %extcmd; ############################################################################# +# utility functions + +use JSON::Syck (); # TODO# replace by JSON::PC once working + +sub from_json($) { + $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs + JSON::Syck::Load $_[0] +} + +sub to_json($) { + $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs + JSON::Syck::Dump $_[0] +} + +############################################################################# # "new" plug-in system -=item cf::object::attach ... # NYI +=item $object->attach ($attachment, ...) + +Attach a pre-registered attachment to an object. + +=item $player->attach ($attachment, ...) + +Attach a pre-registered attachment to a player. + +=item $map->attach ($attachment, ...) # not yet persistent + +Attach a pre-registered attachment to a map. =item cf::attach_global ... -=item cf::attach_to_type ... +Attach handlers for global events. + +This and all following C-functions expect any number of the +following handler/hook descriptions: + +=over 4 + +=item prio => $number + +Set the priority for all following handlers/hooks (unless overwritten +by another C setting). Lower priority handlers get executed +earlier. The default priority is C<0>, and many built-in handlers are +registered at priority C<-1000>, so lower priorities should not be used +unless you know what you are doing. + +=item on_I => \&cb + +Call the given code reference whenever the named event happens (event is +something like C, C, C and so on, and which +handlers are recognised generally depends on the type of object these +handlers attach to). + +See F for the full list of events supported, and their +class. + +=item package => package:: + +Look for sub functions of the name C<< on_I >> in the given +package and register them. Only handlers for eevents supported by the +object/class are recognised. + +=back + +=item cf::attach_to_type $object_type, ... + +Attach handlers for a specific object type (e.g. TRANSPORT). =item cf::attach_to_objects ... +Attach handlers to all objects. Do not use this except for debugging or +very rare events, as handlers are (obviously) called for I objects in +the game. + =item cf::attach_to_players ... +Attach handlers to all players. + =item cf::attach_to_maps ... - prio => $number, # lower is earlier - on_xxx => \&cb, - package => package::, +Attach handlers to all maps. + +=item cf:register_attachment $name, ... =cut # the following variables are defined in .xs and must not be re-created our @CB_GLOBAL = (); # registry for all global events -our @CB_OBJECT = (); +our @CB_OBJECT = (); # all objects (should not be used except in emergency) our @CB_PLAYER = (); our @CB_TYPE = (); # registry for type (cf-object class) based events our @CB_MAP = (); +my %attachment; + sub _attach_cb($\%$$$) { my ($registry, $undo, $event, $prio, $cb) = @_; @@ -138,8 +200,8 @@ # attach handles attaching event callbacks # the only thing the caller has to do is pass the correct # registry (== where the callback attaches to). -sub _attach(\@$\@) { - my ($registry, $klass, $arg) = @_; +sub _attach(\@$@) { + my ($registry, $klass, @arg) = @_; my $prio = 0; @@ -150,14 +212,14 @@ my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; - while (@$arg) { - my $type = shift @$arg; + while (@arg) { + my $type = shift @arg; if ($type eq "prio") { - $prio = shift @$arg; + $prio = shift @arg; } elsif ($type eq "package") { - my $pkg = shift @$arg; + my $pkg = shift @arg; while (my ($name, $id) = each %cb_id) { if (my $cb = $pkg->can ($name)) { @@ -166,13 +228,13 @@ } } elsif (exists $cb_id{$type}) { - _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg; + _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg; } elsif (ref $type) { warn "attaching objects not supported, ignoring.\n"; } else { - shift @$arg; + shift @arg; warn "attach argument '$type' not supported, ignoring.\n"; } } @@ -180,8 +242,51 @@ \%undo } +sub _attach_attachment { + my ($klass, $obj, $name, @args) = q_; + + my $res; + + if (my $attach = $attachment{$name}) { + my $registry = $obj->registry; + + $res = _attach @$registry, $klass, @$attach; + + if (my $cb = delete $registry->[EVENT_OBJECT_INSTANTIATE]) { + for (@$cb) { + eval { $_->[1]->($obj, @args); }; + if ($@) { + warn "$@"; + warn "... while processing '$name' instantiate with args <@args>.\n"; + } + } + } + } else { + warn "object uses attachment '$name' that is not available, postponing.\n"; + } + + push @{$obj->{_attachment}}, $name; + + $res->{attachment} = $name; + $res +} + sub cf::object::attach { - die; + my ($obj, $name, @args) = @_; + + _attach_attachment KLASS_OBJECT, $obj, $name, @args; +} + +sub cf::player::attach { + my ($obj, $name, @args) = @_; + + _attach_attachment KLASS_PLAYER, $obj, $name, @args; +} + +sub cf::map::attach { + my ($obj, $name, @args) = @_; + + _attach_attachment KLASS_MAP, $obj, $name, @args; } sub attach_global { @@ -190,6 +295,7 @@ sub attach_to_type { my $type = shift; + _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ } @@ -205,16 +311,26 @@ _attach @CB_MAP, KLASS_MAP, @_ } +sub register_attachment { + my $name = shift; + + $attachment{$name} = [@_]; +} + our $override; +our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? -sub override() { - $override = 1 +sub override { + $override = 1; + @invoke_results = (); } -sub invoke { +sub do_invoke { my $event = shift; my $callbacks = shift; + @invoke_results = (); + local $override; for (@$callbacks) { @@ -233,6 +349,83 @@ } ############################################################################# +# object support + +sub instantiate { + my ($obj, $data) = @_; + + $data = from_json $data; + + for (@$data) { + my ($name, $args) = @$_; + attach $obj, $name, @{$args || [] }; + } +} + +# basically do the same as instantiate, without calling instantiate +sub reattach { + warn "reattach<@_>\n";#d# + my ($obj) = @_; + my $registry = $obj->registry; + + for my $name (@{ $obj->{_attachment} }) { + if (my $attach = $attachment{$name}) { + _attach @$registry, KLASS_OBJECT, @$attach; + } else { + warn "object uses attachment '$name' that is not available, postponing.\n"; + } + } + + warn "reattach<@_, $_>\n"; +} + +sub object_freezer_save { + my ($filename, $objs) = @_; + warn "freeze $filename\n";#d# + use Data::Dumper; print Dumper $objs; + + $filename .= ".pst"; + + if (@$objs) { + open my $fh, ">:raw", "$filename~"; + chmod $fh, SAVE_MODE; + syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; + close $fh; + rename "$filename~", $filename; + } else { + unlink $filename; + } +} + +sub object_thawer_load { + my ($filename) = @_; + + warn "thaw $filename\n";#d# + + open my $fh, "<:raw:perlio", "$filename.pst" + or return; + + eval { local $/; (Storable::thaw <$fh>)->{objs} } +} + +attach_to_objects + prio => -1000000, + on_clone => sub { + my ($src, $dst) = @_; + + @{$dst->registry} = @{$src->registry}; + warn "registry clone ", join ":", @{$src->registry};#d# + + %$dst = %$src; + + $dst->{_attachment} = [@{ $src->{_attachment} }] + if exists $src->{_attachment}; + + warn "clone<@_>\n";#d# + }, +; + +############################################################################# # old plug-in events sub inject_event { @@ -286,12 +479,7 @@ sub register { my ($base, $pkg) = @_; - for my $idx (0 .. $#PLUGIN_EVENT) { - if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) { - #warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n"; - $hook[$idx]{$base} = $ref; - } - } + #TODO } sub load_extension { @@ -332,9 +520,10 @@ warn "removing extension $pkg\n"; # remove hooks - for my $idx (0 .. $#PLUGIN_EVENT) { - delete $hook[$idx]{$pkg}; - } + #TODO +# for my $idx (0 .. $#PLUGIN_EVENT) { +# delete $hook[$idx]{$pkg}; +# } # remove commands for my $name (keys %command) { @@ -354,7 +543,7 @@ delete $extcmd{$name}; } - if (my $cb = $pkg->can ("on_unload")) { + if (my $cb = $pkg->can ("unload")) { eval { $cb->($pkg); 1 @@ -410,7 +599,7 @@ # 4. get rid of safe::, as good as possible Symbol::delete_package "safe::$_" - for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); + for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region); # 5. remove register_script_function callbacks # TODO @@ -450,41 +639,28 @@ }; ############################################################################# -# utility functions - -use JSON::Syck (); # TODO# replace by JSON::PC once working - -sub from_json($) { - $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs - JSON::Syck::Load $_[0] -} - -sub to_json($) { - $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs - JSON::Syck::Dump $_[0] -} - -############################################################################# # extcmd framework, basically convert ext # into pkg::->on_extcmd_arg1 (...) while shortcutting a few -sub on_extcmd { - my ($pl, $buf) = @_; +attach_to_players + on_extcmd => sub { + my ($pl, $buf) = @_; - my $msg = eval { from_json $buf }; + my $msg = eval { from_json $buf }; - if (ref $msg) { - if (my $cb = $extcmd{$msg->{msgtype}}) { - if (my %reply = $cb->[0]->($pl, $msg)) { - $pl->ext_reply ($msg->{msgid}, %reply); + if (ref $msg) { + if (my $cb = $extcmd{$msg->{msgtype}}) { + if (my %reply = $cb->[0]->($pl, $msg)) { + $pl->ext_reply ($msg->{msgid}, %reply); + } } + } else { + warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; } - } else { - warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; - } - 1 -} + cf::override; + }, +; ############################################################################# # load/save/clean perl data associated with a map @@ -496,6 +672,7 @@ defined $path or return; unlink "$path.cfperl"; + unlink "$path.pst"; }; *cf::mapsupport::on_swapin = @@ -516,33 +693,6 @@ $map->_set_obs ($data->{obs}); }; -*cf::mapsupport::on_swapout = sub { - my ($map) = @_; - - my $path = $map->tmpname; - $path = $map->path unless defined $path; - - my $obs = $map->_get_obs; - - if (defined $obs) { - open my $fh, ">:raw", "$path.cfperl" - or die "$path.cfperl: $!"; - - stat $path; - - print $fh Storable::nfreeze { - size => (stat _)[7], - time => (stat _)[9], - version => 1, - obs => $obs, - }; - - chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g* - } else { - unlink "$path.cfperl"; - } -}; - attach_to_maps prio => -10000, package => cf::mapsupport::; ############################################################################# @@ -564,12 +714,6 @@ } } }, - on_save => sub { - my ($pl, $path) = @_; - - $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) - for grep %$_, all_objects $pl->ob; - }, ; #############################################################################