--- deliantra/server/lib/cf.pm 2006/07/21 00:51:39 1.27 +++ deliantra/server/lib/cf.pm 2006/08/24 17:29:30 1.38 @@ -7,6 +7,7 @@ use Safe; use Safe::Hole; +use Time::HiRes; use Event; $Event::Eval = 1; # no idea why this is required, but it is @@ -14,12 +15,17 @@ our %COMMAND; our @EVENT; +our @PLUGIN_EVENT; our %PROP_TYPE; our %PROP_IDX; our $LIBDIR = maps_directory "perl"; +our $TICK = MAX_TIME * 1e-6; +our $TICK_WATCHER; +our $NEXT_TICK; + BEGIN { - @EVENT = map lc, @EVENT; + @PLUGIN_EVENT = map lc, @PLUGIN_EVENT; *CORE::GLOBAL::warn = sub { my $msg = join "", @_; @@ -72,7 +78,7 @@ # we bless all objects into 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)) { +for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) { no strict 'refs'; @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; } @@ -138,9 +144,9 @@ sub register { my ($base, $pkg) = @_; - for my $idx (0 .. $#EVENT) { - if (my $ref = $pkg->can ("on_$EVENT[$idx]")) { - #warn "registering $EVENT[$idx] hook to '$pkg'\n"; + 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; } } @@ -183,12 +189,8 @@ warn "removing extension $pkg\n"; - if (my $cb = $pkg->can ("on_unload")) { - $cb->($pkg); - } - # remove hooks - for my $idx (0 .. $#EVENT) { + for my $idx (0 .. $#PLUGIN_EVENT) { delete $hook[$idx]{$pkg}; } @@ -210,6 +212,13 @@ delete $extcmd{$name}; } + if (my $cb = $pkg->can ("on_unload")) { + eval { + $cb->($pkg); + 1 + } or warn "$pkg unloaded, but with errors: $@"; + } + Symbol::delete_package $pkg; } @@ -225,78 +234,113 @@ } } -register_command "perl-reload", 0, sub { - my ($who, $arg) = @_; +sub _perl_reload(&) { + my ($msg) = @_; - if ($who->flag (FLAG_WIZ)) { - $who->message ("reloading..."); + $msg->("reloading..."); - warn "reloading...\n"; - eval { - # 1. cancel all watchers - $_->cancel for Event::all_watchers; + eval { + # 1. cancel all watchers + $_->cancel for Event::all_watchers; + + # 2. unload all extensions + for (@exts) { + $msg->("unloading <$_>"); + unload_extension $_; + } + + # 3. unload all modules loaded from $LIBDIR + while (my ($k, $v) = each %INC) { + next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; - # 2. unload all extensions - for (@exts) { - $who->message ("unloading <$_>"); - unload_extension $_; + $msg->("removing <$k>"); + delete $INC{$k}; + + $k =~ s/\.pm$//; + $k =~ s/\//::/g; + + if (my $cb = $k->can ("unload_module")) { + $cb->(); } - # 3. unload all modules loaded from $LIBDIR - while (my ($k, $v) = each %INC) { - next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; + Symbol::delete_package $k; + } - $who->message ("removing <$k>"); - delete $INC{$k}; + # 4. get rid of ext::, as good as possible + Symbol::delete_package "ext::$_" + for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); + + # 5. remove register_script_function callbacks + # TODO + + # 6. unload cf.pm "a bit" + delete $INC{"cf.pm"}; + + # don't, removes xs symbols, too + #Symbol::delete_package __PACKAGE__; + + # 7. reload cf.pm + $msg->("reloading cf.pm"); + require cf; + }; + $msg->($@) if $@; - $k =~ s/\.pm$//; - $k =~ s/\//::/g; + $msg->("reloaded"); +}; - if (my $cb = $k->can ("unload_module")) { - $cb->(); - } +sub perl_reload() { + _perl_reload { + warn $_[0]; + print "$_[0]\n"; + }; +} - Symbol::delete_package $k; - } +register_command "perl-reload", 0, sub { + my ($who, $arg) = @_; - # 4. get rid of ext::, as good as possible - Symbol::delete_package "ext::$_" - for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); - - # 5. remove register_script_function callbacks - # TODO - - # 6. unload cf.pm "a bit" - delete $INC{"cf.pm"}; - - # don't, removes xs symbols, too - #Symbol::delete_package __PACKAGE__; - - # 7. reload cf.pm - $who->message ("reloading cf.pm"); - require cf; + if ($who->flag (FLAG_WIZ)) { + _perl_reload { + warn $_[0]; + $who->message ($_[0]); }; - warn $@ if $@; - $who->message ($@) if $@; - warn "reloaded\n"; - - $who->message ("reloaded"); - } else { - $who->message ("Intruder Alert!"); } }; ############################################################################# -# extcmd framework, basically convert ext arg1 args +# 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) = @_; - my ($type) = $buf =~ s/^(\S+) // ? $1 : ""; + my $msg = eval { from_json $buf }; - $extcmd{$type}[0]->($pl, $buf) - if $extcmd{$type}; + 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"; + } + + 1 } ############################################################################# @@ -359,10 +403,14 @@ ############################################################################# # load/save perl data associated with player->ob objects +sub all_objects(@) { + @_, map all_objects ($_->inv), @_ +} + *on_player_load = sub { my ($ob, $path) = @_; - for my $o ($ob, $ob->inv) { + for my $o (all_objects $ob) { if (my $value = $o->get_ob_key_value ("_perl_data")) { $o->set_ob_key_value ("_perl_data"); @@ -375,7 +423,7 @@ my ($ob, $path) = @_; $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) - for grep %$_, $ob, $ob->inv; + for grep %$_, all_objects $ob; }; ############################################################################# @@ -392,6 +440,14 @@ or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; } +=item $player->reply ($npc, $msg[, $flags]) + +Sends a message to the player, as if the npc C<$npc> replied. C<$npc> +can be C. Does the right thing when the player is currently in a +dialogue with the given NPC character. + +=cut + # rough implementation of a future "reply" method that works # with dialog boxes. sub cf::object::player::reply($$$;$) { @@ -407,6 +463,20 @@ } } +=item $player->ext_reply ($msgid, $msgtype, %msg) + +Sends an ext reply to the player. + +=cut + +sub cf::player::ext_reply($$$%) { + my ($self, $id, %msg) = @_; + + $msg{msgid} = $id; + + $self->send ("ext " . to_json \%msg); +} + ############################################################################# # map scripting support @@ -463,6 +533,13 @@ } ############################################################################# +# the server's main() + +sub run { + Event::loop; +} + +############################################################################# # initialisation register "", __PACKAGE__; @@ -471,5 +548,22 @@ load_extensions; +$TICK_WATCHER = Event->timer ( + prio => 1, + at => $NEXT_TICK || 1, + cb => sub { + cf::server_tick; # one server iteration + + my $NOW = Event::time; + $NEXT_TICK += $TICK; + + # if we are delayed by four ticks, skip them all + $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; + + $TICK_WATCHER->at ($NEXT_TICK); + $TICK_WATCHER->start; + }, +); + 1