--- deliantra/server/lib/cf.pm 2006/12/22 06:03:20 1.97 +++ deliantra/server/lib/cf.pm 2006/12/30 16:56:16 1.104 @@ -10,13 +10,13 @@ use Safe; use Safe::Hole; -use Coro; +use Coro 3.3; use Coro::Event; use Coro::Timer; use Coro::Signal; use Coro::Semaphore; -use IO::AIO; +use IO::AIO 2.3; use YAML::Syck (); use Time::HiRes; @@ -25,7 +25,7 @@ # work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? $YAML::Syck::ImplicitUnicode = 1; -$Coro::main->prio (Coro::PRIO_MIN); +$Coro::main->prio (2); # run main coroutine ("the server") with very high priority sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload @@ -33,18 +33,39 @@ our %COMMAND_TIME = (); our %EXTCMD = (); -_init_vars; - our @EVENT; our $LIBDIR = datadir . "/ext"; our $TICK = MAX_TIME * 1e-6; our $TICK_WATCHER; our $NEXT_TICK; +our $NOW; our %CFG; our $UPTIME; $UPTIME ||= time; +our $RUNTIME; + +our %MAP; # all maps +our $LINK_MAP; # the special {link} map +our $FREEZE; + +binmode STDOUT; +binmode STDERR; + +# read virtual server time, if available +unless ($RUNTIME || !-e cf::localdir . "/runtime") { + open my $fh, "<", cf::localdir . "/runtime" + or die "unable to read runtime file: $!"; + $RUNTIME = <$fh> + 0.; +} + +mkdir cf::localdir; +mkdir cf::localdir . "/" . cf::playerdir; +mkdir cf::localdir . "/" . cf::tmpdir; +mkdir cf::localdir . "/" . cf::uniquedir; + +our %EXT_CORO; ############################################################################# @@ -56,11 +77,20 @@ The timestamp of the server start (so not actually an uptime). +=item $cf::RUNTIME + +The time this server has run, starts at 0 and is increased by $cf::TICK on +every server tick. + =item $cf::LIBDIR The perl library directory, where extensions and cf-specific modules can be found. It will be added to C<@INC> automatically. +=item $cf::NOW + +The time of the last (current) server tick. + =item $cf::TICK The interval between server ticks, in seconds. @@ -77,10 +107,11 @@ BEGIN { *CORE::GLOBAL::warn = sub { my $msg = join "", @_; + utf8::encode $msg; + $msg .= "\n" unless $msg =~ /\n$/; - print STDERR "cfperl: $msg"; LOG llevError, "cfperl: $msg"; }; } @@ -95,7 +126,7 @@ # we bless all objects into (empty) derived classes to force a method lookup # within the Safe compartment. for my $pkg (qw( - cf::global + cf::global cf::attachable cf::object cf::object::player cf::client cf::player cf::arch cf::living @@ -143,6 +174,31 @@ JSON::Syck::Dump $_[0] } +=item $coro = cf::coro { BLOCK } + +Creates and returns a new coro. This coro is automcatially being canceled +when the extension calling this is being unloaded. + +=cut + +sub coro(&) { + my $cb = shift; + + my $coro; $coro = async { + eval { + $cb->(); + }; + warn $@ if $@; + }; + + $coro->on_destroy (sub { + delete $EXT_CORO{$coro+0}; + }); + $EXT_CORO{$coro+0} = $coro; + + $coro +} + =back =cut @@ -271,12 +327,13 @@ =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 = (); # all objects (should not be used except in emergency) -our @CB_PLAYER = (); -our @CB_CLIENT = (); -our @CB_TYPE = (); # registry for type (cf-object class) based events -our @CB_MAP = (); +our @CB_GLOBAL = (); # registry for all global events +our @CB_ATTACHABLE = (); # registry for all attachables +our @CB_OBJECT = (); # all objects (should not be used except in emergency) +our @CB_PLAYER = (); +our @CB_CLIENT = (); +our @CB_TYPE = (); # registry for type (cf-object class) based events +our @CB_MAP = (); my %attachment; @@ -292,6 +349,9 @@ @{$registry->[$event] || []}, $cb; } +# hack +my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP; + # attach handles attaching event callbacks # the only thing the caller has to do is pass the correct # registry (== where the callback attaches to). @@ -302,6 +362,11 @@ my $prio = 0; my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; + #TODO: get rid of this hack + if ($attachable_klass{$klass}) { + %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT); + } + while (@arg) { my $type = shift @arg; @@ -386,7 +451,7 @@ exists $obj->{_attachment}{$name} } -for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) { +for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) { eval "#line " . __LINE__ . " 'cf.pm' sub cf::\L$klass\E::_attach_registry { (\\\@CB_$klass, KLASS_$klass) @@ -449,21 +514,10 @@ ############################################################################# # object support -sub instantiate { - my ($obj, $data) = @_; - - $data = from_json $data; - - for (@$data) { - my ($name, $args) = @$_; - - $obj->attach ($name, %{$args || {} }); - } -} - -# basically do the same as instantiate, without calling instantiate sub reattach { + # basically do the same as instantiate, without calling instantiate my ($obj) = @_; + my $registry = $obj->registry; @$registry = (); @@ -482,6 +536,32 @@ } } +cf::attachable->attach ( + prio => -1000000, + on_instantiate => sub { + my ($obj, $data) = @_; + + $data = from_json $data; + + for (@$data) { + my ($name, $args) = @$_; + + $obj->attach ($name, %{$args || {} }); + } + }, + on_reattach => \&reattach, + on_clone => sub { + my ($src, $dst) = @_; + + @{$dst->registry} = @{$src->registry}; + + %$dst = %$src; + + %{$dst->{_attachment}} = %{$src->{_attachment}} + if exists $src->{_attachment}; + }, +); + sub object_freezer_save { my ($filename, $rdata, $objs) = @_; @@ -540,20 +620,6 @@ () } -cf::object->attach ( - prio => -1000000, - on_clone => sub { - my ($src, $dst) = @_; - - @{$dst->registry} = @{$src->registry}; - - %$dst = %$src; - - %{$dst->{_attachment}} = %{$src->{_attachment}} - if exists $src->{_attachment}; - }, -); - ############################################################################# # command handling &c @@ -888,7 +954,7 @@ if (@$queue) { $ns->send_packet ($ns->{query_queue}[0][0]); } else { - $ns->state (ST_PLAYING); + $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; } } }, @@ -910,10 +976,15 @@ $cb->(); }; warn $@ if $@; - delete $self->{_coro}{$coro+0}; }; + $coro->on_destroy (sub { + delete $self->{_coro}{$coro+0}; + }); + $self->{_coro}{$coro+0} = $coro; + + $coro } cf::client->attach ( @@ -1164,20 +1235,26 @@ ############################################################################# # initialisation -sub _perl_reload(&) { - my ($msg) = @_; - - $msg->("reloading..."); +sub _perl_reload() { + warn "reloading..."; eval { + local $FREEZE = 1; + + cf::emergency_save; + # cancel all watchers for (Event::all_watchers) { $_->cancel if $_->data & WF_AUTOCANCEL; } + # cancel all extension coros + $_->cancel for values %EXT_CORO; + %EXT_CORO = (); + # unload all extensions for (@exts) { - $msg->("unloading <$_>"); + warn "unloading <$_>"; unload_extension $_; } @@ -1185,7 +1262,7 @@ while (my ($k, $v) = each %INC) { next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; - $msg->("removing <$k>"); + warn "removing <$k>"; delete $INC{$k}; $k =~ s/\.pm$//; @@ -1200,10 +1277,11 @@ # sync database to disk cf::db_sync; + IO::AIO::flush; # get rid of safe::, as good as possible Symbol::delete_package "safe::$_" - for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region); + for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); # remove register_script_function callbacks # TODO @@ -1216,31 +1294,29 @@ #Symbol::delete_package __PACKAGE__; # reload cf.pm - $msg->("reloading cf.pm"); + warn "reloading cf.pm"; require cf; + cf::_connect_to_perl; # nominally unnecessary, but cannot hurt # load config and database again cf::cfg_load; cf::db_load; # load extensions - $msg->("load extensions"); + warn "load extensions"; cf::load_extensions; # reattach attachments to objects - $msg->("reattach"); + warn "reattach"; _global_reattach; }; - $msg->($@) if $@; + warn $@ if $@; - $msg->("reloaded"); + warn "reloaded"; }; sub perl_reload() { - _perl_reload { - warn $_[0]; - print "$_[0]\n"; - }; + _perl_reload; } register "", __PACKAGE__; @@ -1249,27 +1325,28 @@ my ($who, $arg) = @_; if ($who->flag (FLAG_WIZ)) { - _perl_reload { - warn $_[0]; - $who->message ($_[0]); - }; + $who->message ("reloading..."); + _perl_reload; } }; unshift @INC, $LIBDIR; $TICK_WATCHER = Event->timer ( - prio => 0, - at => $NEXT_TICK || 1, - data => WF_AUTOCANCEL, - cb => sub { - cf::server_tick; # one server iteration + reentrant => 0, + prio => 0, + at => $NEXT_TICK || $TICK, + data => WF_AUTOCANCEL, + cb => sub { + unless ($FREEZE) { + cf::server_tick; # one server iteration + $RUNTIME += $TICK; + } - my $NOW = Event::time; $NEXT_TICK += $TICK; # if we are delayed by four ticks or more, skip them all - $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; + $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; $TICK_WATCHER->at ($NEXT_TICK); $TICK_WATCHER->start; @@ -1284,5 +1361,14 @@ data => WF_AUTOCANCEL, cb => \&IO::AIO::poll_cb); +# we must not ever block the main coroutine +$Coro::idle = sub { + #Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d# + warn "FATAL: Coro::idle was called, major BUG\n"; + (Coro::unblock_sub { + Event::one_event; + })->(); +}; + 1