--- deliantra/server/lib/cf.pm 2006/12/23 05:25:35 1.99 +++ deliantra/server/lib/cf.pm 2006/12/31 17:17:23 1.105 @@ -10,13 +10,15 @@ use Safe; use Safe::Hole; -use Coro; +use Coro 3.3; use Coro::Event; use Coro::Timer; use Coro::Signal; use Coro::Semaphore; +use Coro::AIO; -use IO::AIO 2.3; +use Fcntl; +use IO::AIO 2.31 (); use YAML::Syck (); use Time::HiRes; @@ -25,7 +27,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 +35,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 +79,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 +109,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 +128,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 +176,61 @@ JSON::Syck::Dump $_[0] } +# main coro must never ever "block" except in Event +# sync_job ensures this by running the job in a coroutine +# and waiting in Event while the server is otherwise frozen +sub sync_job(&) { + my ($job) = @_; + + my $busy = 1; + my @res; + + local $FREEZE = 1; + + my $coro = Coro::async { + @res = eval { $job->() }; + warn $@ if $@; + undef $busy; + }; + + if ($Coro::current == $Coro::main) { + $coro->prio (Coro::PRIO_MAX); + while ($busy) { + Coro::cede_notself; + Event::one_event unless Coro::nready; + } + } else { + $coro->join; + } + + wantarray ? @res : $res[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 +359,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 +381,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 +394,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 +483,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 +546,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,34 +568,67 @@ } } +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) = @_; - if (length $$rdata) { - warn sprintf "saving %s (%d,%d)\n", - $filename, length $$rdata, scalar @$objs; - - if (open my $fh, ">:raw", "$filename~") { - chmod SAVE_MODE, $fh; - syswrite $fh, $$rdata; - close $fh; + sync_job { + if (length $$rdata) { + warn sprintf "saving %s (%d,%d)\n", + $filename, length $$rdata, scalar @$objs; - if (@$objs && open my $fh, ">:raw", "$filename.pst~") { + if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { chmod SAVE_MODE, $fh; - syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; + aio_write $fh, 0, (length $$rdata), $$rdata, 0; + aio_fsync $fh; close $fh; - rename "$filename.pst~", "$filename.pst"; + + if (@$objs) { + if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { + chmod SAVE_MODE, $fh; + my $data = Storable::nfreeze { version => 1, objs => $objs }; + aio_write $fh, 0, (length $data), $data, 0; + aio_fsync $fh; + close $fh; + aio_rename "$filename.pst~", "$filename.pst"; + } + } else { + aio_unlink "$filename.pst"; + } + + aio_rename "$filename~", $filename; } else { - unlink "$filename.pst"; + warn "FATAL: $filename~: $!\n"; } - - rename "$filename~", $filename; } else { - warn "FATAL: $filename~: $!\n"; + aio_unlink $filename; + aio_unlink "$filename.pst"; } - } else { - unlink $filename; - unlink "$filename.pst"; } } @@ -524,36 +643,20 @@ sub object_thawer_load { my ($filename) = @_; - local $/; + my ($data, $av); - my $av; + (aio_load $filename, $data) >= 0 + or return; - #TODO: use sysread etc. - if (open my $data, "<:raw:perlio", $filename) { - $data = <$data>; - if (open my $pst, "<:raw:perlio", "$filename.pst") { - $av = eval { (Storable::thaw <$pst>)->{objs} }; - } - return ($data, $av); + unless (aio_stat "$filename.pst") { + (aio_load "$filename.pst", $av) >= 0 + or return; + $av = eval { (Storable::thaw <$av>)->{objs} }; } - () + return ($data, $av); } -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 @@ -910,10 +1013,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 +1272,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 +1299,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 +1314,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 +1331,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 +1362,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 +1398,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