--- deliantra/server/lib/cf.pm 2007/02/12 00:27:20 1.208 +++ deliantra/server/lib/cf.pm 2007/04/17 10:38:28 1.246 @@ -6,37 +6,44 @@ use Symbol; use List::Util; use Storable; +use Event; use Opcode; use Safe; use Safe::Hole; -use Coro 3.5 (); +use Coro 3.61 (); +use Coro::State; use Coro::Event; use Coro::Timer; use Coro::Signal; use Coro::Semaphore; use Coro::AIO; +use Coro::Storable; use BDB (); use Data::Dumper; use Digest::MD5; use Fcntl; -use IO::AIO 2.32 (); use YAML::Syck (); +use IO::AIO 2.32 (); use Time::HiRes; use Compress::LZF; +# configure various modules to our taste +# +$Storable::canonical = 1; # reduce rsync transfers +Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later -use Event; $Event::Eval = 1; # no idea why this is required, but it is - -sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload +$Event::Eval = 1; # no idea why this is required, but it is # 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_MAX); # run main coroutine ("the server") with very high priority +sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload + our %COMMAND = (); our %COMMAND_TIME = (); @@ -45,13 +52,14 @@ our %EXT_CORO = (); # coroutines bound to extensions our %EXT_MAP = (); # pluggable maps +our $RELOAD; # number of reloads so far our @EVENT; our $LIBDIR = datadir . "/ext"; -our $TICK = MAX_TIME * 1e-6; +our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) our $TICK_WATCHER; our $AIO_POLL_WATCHER; -our $WRITE_RUNTIME_WATCHER; +our $NEXT_RUNTIME_WRITE; # when should the runtime file be written our $NEXT_TICK; our $NOW; our $USE_FSYNC = 1; # use fsync to write maps - default off @@ -70,9 +78,6 @@ our $RANDOM_MAPS = cf::localdir . "/random"; our $BDB_ENV_DIR = cf::localdir . "/db"; -our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal; -our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal; - # used to convert map paths into valid unix filenames by replacing / by ∕ our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons @@ -130,12 +135,11 @@ Configuration for the server, loaded from C, or from wherever your confdir points to. -=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE +=item cf::wait_for_tick, cf::wait_for_tick_begin -These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) -or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick -processing has been done. Call C<< ->wait >> on them to maximise the -window of cpu time available, or simply to synchronise to the server tick. +These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only +returns directly I the tick processing (and consequently, can only wake one process +per tick), while cf::wait_for_tick wakes up all waiters after tick processing. =back @@ -204,30 +208,16 @@ } || "[unable to dump $_[0]: '$@']"; } -use JSON::Syck (); # TODO# replace by JSON::PC once working +use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working =item $ref = cf::from_json $json Converts a JSON string into the corresponding perl data structure. -=cut - -sub from_json($) { - $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs - JSON::Syck::Load $_[0] -} - =item $json = cf::to_json $ref Converts a perl data structure into its JSON representation. -=cut - -sub to_json($) { - $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs - JSON::Syck::Dump $_[0] -} - =item cf::lock_wait $string Wait until the given lock is available. See cf::lock_acquire. @@ -275,9 +265,7 @@ my $guard = Coro::guard { $TICK_WATCHER->start; - $WRITE_RUNTIME_WATCHER->start; }; - $WRITE_RUNTIME_WATCHER->stop; $TICK_WATCHER->stop; $guard } @@ -358,6 +346,8 @@ } sub write_runtime { + my $guard = cf::lock_acquire "write_runtime"; + my $runtime = cf::localdir . "/runtime"; my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 @@ -383,6 +373,17 @@ 1 } +=item cf::datalog type => key => value, ... + +Log a datalog packet of the given type with the given key-value pairs. + +=cut + +sub datalog($@) { + my ($type, %kv) = @_; + warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); +} + =back =cut @@ -789,12 +790,6 @@ aio_unlink $filename; aio_unlink "$filename.pst"; } - - #d##TODO# nuke non .map-files if exist - if ($filename =~ s/\.map$//) { - aio_unlink $filename; - aio_unlink "$filename.pst"; - } } } @@ -811,9 +806,6 @@ my ($data, $av); - #d#TODO remove .map if file does not exist - aio_stat $filename and $filename =~ s/\.map$//; - (aio_load $filename, $data) >= 0 or return; @@ -971,7 +963,7 @@ sub path($) { my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; - (playerdir $login) . "/$login.pl" + (playerdir $login) . "/playerdata" } sub find_active($) { @@ -994,6 +986,13 @@ my $guard = cf::lock_acquire "user_find:$login"; $cf::PLAYER{$_[0]} || do { + # rename old playerfiles to new ones + #TODO: remove when no longer required + aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; + aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; + aio_unlink +(playerdir $login) . "/$login.pl.pst"; + aio_unlink +(playerdir $login) . "/$login.pl"; + my $pl = load_pl path $login or return; $cf::PLAYER{$login} = $pl @@ -1041,6 +1040,8 @@ sub quit_character { my ($pl) = @_; + my $name = $pl->ob->name; + $pl->{deny_save} = 1; $pl->password ("*"); # this should lock out the player until we nuked the dir @@ -1054,9 +1055,29 @@ aio_rename $path, $temp; delete $cf::PLAYER{$pl->ob->name}; $pl->destroy; + + my $prefix = qr<^~\Q$name\E/>; + + # nuke player maps + $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP; + IO::AIO::aio_rmtree $temp; } +=item $pl->kick + +Kicks a player out of the game. This destroys the connection. + +=cut + +sub kick { + my ($pl, $kicker) = @_; + + $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker); + $pl->killer ("kicked"); + $pl->ns->destroy; +} + =item cf::player::list_logins Returns am arrayref of all valid playernames in the system, can take a @@ -1110,13 +1131,13 @@ \@paths } -=item $player->ext_reply ($msgid, $msgtype, %msg) +=item $player->ext_reply ($msgid, %msg) Sends an ext reply to the player. =cut -sub ext_reply($$$%) { +sub ext_reply($$%) { my ($self, $id, %msg) = @_; $msg{msgid} = $id; @@ -1124,10 +1145,48 @@ $self->send ("ext " . cf::to_json \%msg); } -package cf; +=item $player->ext_event ($type, %msg) -=back +Sends an ext event to the client. +=cut + +sub ext_event($$%) { + my ($self, $type, %msg) = @_; + + $self->ns->ext_event ($type, %msg); +} + +=head3 cf::region + +=over 4 + +=cut + +package cf::region; + +=item cf::region::find_by_path $path + +Tries to decuce the probable region for a map knowing only its path. + +=cut + +sub find_by_path($) { + my ($path) = @_; + + my ($match, $specificity); + + for my $region (list) { + if ($region->match && $path =~ $region->match) { + ($match, $specificity) = ($region, $region->specificity) + if $region->specificity > $specificity; + } + } + + $match +} + +=back =head3 cf::map @@ -1309,11 +1368,6 @@ utf8::encode (my $save = $self->save_path); IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst"; - - #d#TODO remove .map and also nuke - $save =~ s/\.map// or return;#d# - IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;#d# - IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";#d# } sub load_header_from($) { @@ -1373,6 +1427,9 @@ $self->prepare_orig; } + $self->default_region (cf::region::find_by_path $self->{path}) + unless $self->default_region; + 1 } @@ -1424,6 +1481,7 @@ $self->alloc; $self->pre_load; + Coro::cede; $self->_load_objects ($self->{load_path}, 1) or return; @@ -1440,9 +1498,9 @@ } Coro::cede; - # now do the right thing for maps $self->link_multipart_objects; + Coro::cede; unless ($self->{deny_activate}) { $self->decay_objects; @@ -1454,9 +1512,11 @@ unless $self->difficulty; Coro::cede; $self->activate; + Coro::cede; } $self->post_load; + Coro::cede; $self->in_memory (cf::MAP_IN_MEMORY); } @@ -1611,9 +1671,18 @@ warn "resetting map ", $self->path;#d# + $self->in_memory (cf::MAP_SWAPPED); + + # need to save uniques path + unless ($self->{deny_save}) { + my $uniq = $self->uniq_path; utf8::encode $uniq; + + $self->_save_objects ($uniq, cf::IO_UNIQUES) + if $uniq; + } + delete $cf::MAP{$self->path}; - $self->in_memory (cf::MAP_SWAPPED); $self->clear; $_->clear_links_to ($self) for values %cf::MAP; @@ -1813,6 +1882,8 @@ return unless $self->contr->active; $self->activate_recursive; + + local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext $self->enter_map ($map, $x, $y); } @@ -1835,12 +1906,12 @@ if ($pl->ob->{_link_pos}) { $pl->ob->enter_link; (async { - # we need this sleep as the login has a concurrent enter_exit running - # and this sleep increases chances of the player not ending up in scorn $pl->ob->reply (undef, "There was an internal problem at your last logout, " . "the server will try to bring you to your intended destination in a second.", cf::NDI_RED); + # we need this sleep as the login has a concurrent enter_exit running + # and this sleep increases chances of the player not ending up in scorn Coro::Timer::sleep 1; $pl->ob->leave_link; })->prio (2); @@ -1933,6 +2004,8 @@ if ($exit->slaying eq "/!") { #TODO: this should de-fi-ni-te-ly not be a sync-job + # the problem is that $exit might not survive long enough + # so it needs to be done right now, right here cf::sync_job { prepare_random_map $exit }; } @@ -1950,9 +2023,9 @@ 1; }) { $self->message ("Something went wrong deep within the crossfire server. " - . "I'll try to bring you back to the map you were before. " - . "Please report this to the dungeon master!", - cf::NDI_UNIQUE | cf::NDI_RED); + . "I'll try to bring you back to the map you were before. " + . "Please report this to the dungeon master!", + cf::NDI_UNIQUE | cf::NDI_RED); warn "ERROR in enter_exit: $@"; $self->leave_link; @@ -1975,9 +2048,21 @@ my ($self, $text, $flags) = @_; utf8::encode $text; - $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); + $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); } +=item $client->ext_event ($type, %msg) + +Sends an exti event to the client. + +=cut + +sub cf::client::ext_event($$%) { + my ($self, $type, %msg) = @_; + + $msg{msgtype} = "event_$type"; + $self->send_packet ("ext " . cf::to_json \%msg); +} =item $success = $client->query ($flags, "text", \&cb) @@ -2084,7 +2169,7 @@ =pod -The following fucntions and emthods are available within a safe environment: +The following functions and methods are available within a safe environment: cf::object contr pay_amount pay_player map cf::object::player player @@ -2199,7 +2284,7 @@ our $DB; -sub db_load() { +sub db_init { unless ($DB) { $DB = BDB::db_create $DB_ENV; @@ -2249,9 +2334,91 @@ ############################################################################# # the server's init and main functions -sub load_resources { - load_regions sprintf "%s/%s/regions", cf::datadir, cf::mapdir - or die "unable to load regions file\n";#d# +sub load_facedata($) { + my ($path) = @_; + + warn "loading facedata from $path\n"; + + my $facedata; + 0 < aio_load $path, $facedata + or die "$path: $!"; + + $facedata = Coro::Storable::thaw $facedata; + + $facedata->{version} == 2 + or cf::cleanup "$path: version mismatch, cannot proceed."; + + { + my $faces = $facedata->{faceinfo}; + + while (my ($face, $info) = each %$faces) { + my $idx = (cf::face::find $face) || cf::face::alloc $face; + cf::face::set $idx, $info->{visibility}, $info->{magicmap}; + cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; + cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; + Coro::cede; + } + + while (my ($face, $info) = each %$faces) { + next unless $info->{smooth}; + my $idx = cf::face::find $face + or next; + if (my $smooth = cf::face::find $info->{smooth}) { + cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; + } else { + warn "smooth face '$info->{smooth}' not found for face '$face'"; + } + Coro::cede; + } + } + + { + my $anims = $facedata->{animinfo}; + + while (my ($anim, $info) = each %$anims) { + cf::anim::set $anim, $info->{frames}, $info->{facings}; + Coro::cede; + } + + cf::anim::invalidate_all; # d'oh + } + + 1 +} + +sub reload_facedata { + load_facedata sprintf "%s/facedata", cf::datadir + or die "unable to load facedata\n"; +} + +sub reload_regions { + load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir + or die "unable to load regions file\n"; +} + +sub reload_archetypes { + load_archetype_file sprintf "%s/archetypes", cf::datadir + or die "unable to load archetypes\n"; +} + +sub reload_treasures { + load_treasure_file sprintf "%s/treasures", cf::datadir + or die "unable to load treasurelists\n"; +} + +sub reload_resources { + warn "reloading resource files...\n"; + + reload_regions; + reload_facedata; + reload_archetypes; + reload_treasures; + + warn "finished reloading resource files\n"; +} + +sub init { + reload_resources; } sub cfg_load { @@ -2275,10 +2442,6 @@ } } -sub init { - load_resources; -} - sub main { # we must not ever block the main coroutine local $Coro::idle = sub { @@ -2289,7 +2452,7 @@ }; cfg_load; - db_load; + db_init; load_extensions; $TICK_WATCHER->start; @@ -2347,7 +2510,14 @@ warn "leave emergency perl save\n"; } -sub reload() { +sub post_cleanup { + my ($make_core) = @_; + + warn Carp::longmess "post_cleanup backtrace" + if $make_core; +} + +sub do_reload_perl() { # can/must only be called in main if ($Coro::current != $Coro::main) { warn "can only reload from main coroutine"; @@ -2356,12 +2526,16 @@ warn "reloading..."; - warn "cancelling server ticker"; - $TICK_WATCHER->cancel; + warn "entering sync_job"; - cf::emergency_save; + cf::sync_job { + cf::write_runtime; # external watchdog should not bark + cf::emergency_save; + cf::write_runtime; # external watchdog should not bark + + warn "syncing database to disk"; + BDB::db_env_txn_checkpoint $DB_ENV; - eval { # if anything goes wrong in here, we should simply crash as we already saved warn "cancelling all WF_AUTOCANCEL watchers"; @@ -2369,9 +2543,6 @@ $_->cancel if $_->data & WF_AUTOCANCEL; } - warn "syncing database to disk"; - BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; - warn "flushing outstanding aio requests"; for (;;) { BDB::flush; @@ -2381,6 +2552,8 @@ warn "iterate..."; } + ++$RELOAD; + warn "cancelling all extension coros"; $_->cancel for values %EXT_CORO; %EXT_CORO = (); @@ -2442,53 +2615,52 @@ warn "loading config and database again"; cf::cfg_load; - cf::db_load; warn "loading extensions"; cf::load_extensions; warn "reattaching attachments to objects/players"; - _global_reattach; + _global_reattach; # objects, sockets warn "reattaching attachments to maps"; reattach $_ for values %MAP; + warn "reattaching attachments to players"; + reattach $_ for values %PLAYER; - warn "loading reloadable resources"; - load_resources; - - warn "restarting server ticker"; - - $TICK_WATCHER->start; - }; + warn "leaving sync_job"; - if ($@) { + 1 + } or do { warn $@; warn "error while reloading, exiting."; exit 1; - } + }; warn "reloaded"; }; our $RELOAD_WATCHER; # used only during reload +sub reload_perl() { + # doing reload synchronously and two reloads happen back-to-back, + # coro crashes during coro_state_free->destroy here. + + $RELOAD_WATCHER ||= Event->timer ( + reentrant => 0, + after => 0, + data => WF_AUTOCANCEL, + cb => sub { + do_reload_perl; + undef $RELOAD_WATCHER; + }, + ); +} + register_command "reload" => sub { my ($who, $arg) = @_; if ($who->flag (FLAG_WIZ)) { $who->message ("reloading server."); - - # doing reload synchronously and two reloads happen back-to-back, - # coro crashes during coro_state_free->destroy here. - - $RELOAD_WATCHER ||= Event->timer ( - reentrant => 0, - after => 0, - data => WF_AUTOCANCEL, - cb => sub { - reload; - undef $RELOAD_WATCHER; - }, - ); + async { reload_perl }; } }; @@ -2496,6 +2668,27 @@ my $bug_warning = 0; +our @WAIT_FOR_TICK; +our @WAIT_FOR_TICK_BEGIN; + +sub wait_for_tick { + return unless $TICK_WATCHER->is_active; + return if $Coro::current == $Coro::main; + + my $signal = new Coro::Signal; + push @WAIT_FOR_TICK, $signal; + $signal->wait; +} + +sub wait_for_tick_begin { + return unless $TICK_WATCHER->is_active; + return if $Coro::current == $Coro::main; + + my $signal = new Coro::Signal; + push @WAIT_FOR_TICK_BEGIN, $signal; + $signal->wait; +} + $TICK_WATCHER = Event->timer ( reentrant => 0, parked => 1, @@ -2512,15 +2705,18 @@ $NOW = Event::time; cf::server_tick; # one server iteration + $RUNTIME += $TICK; $NEXT_TICK += $TICK; - $WAIT_FOR_TICK->broadcast; - $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; + if ($NOW >= $NEXT_RUNTIME_WRITE) { + $NEXT_RUNTIME_WRITE = $NOW + 10; + Coro::async_pool { + write_runtime + or warn "ERROR: unable to write runtime file: $!"; + }; + } - Event::sweep; - Coro::cede_notself; - # my $AFTER = Event::time; # warn $AFTER - $NOW;#d# @@ -2529,6 +2725,15 @@ $TICK_WATCHER->at ($NEXT_TICK); $TICK_WATCHER->start; + + if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { + $sig->send; + } + while (my $sig = shift @WAIT_FOR_TICK) { + $sig->send; + } + + _post_tick; }, ); @@ -2589,26 +2794,14 @@ IO::AIO::max_poll_time $TICK * 0.1; $AIO_POLL_WATCHER = Event->io ( reentrant => 0, + data => WF_AUTOCANCEL, fd => IO::AIO::poll_fileno, poll => 'r', prio => 6, - data => WF_AUTOCANCEL, cb => \&IO::AIO::poll_cb, ); } -$WRITE_RUNTIME_WATCHER = Event->timer ( - reentrant => 0, - data => WF_AUTOCANCEL, - after => 1, - interval => 10, - prio => 6, # keep it lowest so it acts like a watchdog - cb => Coro::unblock_sub { - write_runtime - or warn "ERROR: unable to write runtime file: $!"; - }, -); - END { cf::emergency_save } 1