--- deliantra/server/lib/cf.pm 2006/09/12 22:43:31 1.66 +++ deliantra/server/lib/cf.pm 2006/11/05 11:13:01 1.77 @@ -7,10 +7,15 @@ use Safe; use Safe::Hole; +use IO::AIO (); +use YAML::Syck (); use Time::HiRes; use Event; $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; + use strict; _init_vars; @@ -23,6 +28,36 @@ our $TICK_WATCHER; our $NEXT_TICK; +our %CFG; + +our $uptime; + +$uptime ||= time; + +############################################################################# + +=head2 GLOBAL VARIABLES + +=over 4 + +=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::TICK + +The interval between server ticks, in seconds. + +=item %cf::CFG + +Configuration for the server, loaded from C, or +from wherever your confdir points to. + +=back + +=cut + BEGIN { *CORE::GLOBAL::warn = sub { my $msg = join "", @_; @@ -53,25 +88,43 @@ my %command; my %extcmd; -############################################################################# -# utility functions +=head2 UTILITY FUNCTIONS + +=over 4 + +=cut use JSON::Syck (); # 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] } +=back + +=cut + ############################################################################# -# "new" plug-in system -=head3 EVENTS AND OBJECT ATTACHMENTS +=head2 EVENTS AND OBJECT ATTACHMENTS =over 4 @@ -381,15 +434,15 @@ =back -=head2 methods valid for all pointers +=cut -=over 4 +############################################################################# -=item $object->valid +=head2 METHODS VALID FOR ALL CORE OBJECTS -=item $player->valid +=over 4 -=item $map->valid +=item $object->valid, $player->valid, $map->valid Just because you have a perl object does not mean that the corresponding C-level object still exists. If you try to access an object that has no @@ -706,7 +759,12 @@ ; ############################################################################# -# core extensions - in perl + +=head2 CORE EXTENSIONS + +Functions and methods that extend core crossfire objects. + +=over 4 =item cf::player::exists $login @@ -719,7 +777,7 @@ or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; } -=item $player->reply ($npc, $msg[, $flags]) +=item $object->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 @@ -756,8 +814,21 @@ $self->send ("ext " . to_json \%msg); } +=back + +=cut + ############################################################################# -# map scripting support + +=head2 SAFE SCRIPTING + +Functions that provide a safe environment to compile and execute +snippets of perl code without them endangering the safety of the server +itself. Looping constructs, I/O operators and other built-in functionality +is not available in the safe scripting environment, and the number of +functions and methods that cna be called is greatly reduced. + +=cut our $safe = new Safe "safe"; our $safe_hole = new Safe::Hole; @@ -768,6 +839,16 @@ # here we export the classes and methods available to script code +=pod + +The following fucntions and emthods are available within a safe environment: + + cf::object contr pay_amount pay_player + cf::object::player player + cf::player peaceful + +=cut + for ( ["cf::object" => qw(contr pay_amount pay_player)], ["cf::object::player" => qw(player)], @@ -779,6 +860,18 @@ for @funs; } +=over 4 + +=item @retval = safe_eval $code, [var => value, ...] + +Compiled and executes the given perl code snippet. additional var/value +pairs result in temporary local (my) scalar variables of the given name +that are available in the code snippet. Example: + + my $five = safe_eval '$first + $second', first => 1, second => 4; + +=cut + sub safe_eval($;@) { my ($code, %vars) = @_; @@ -810,6 +903,21 @@ wantarray ? @res : $res[0] } +=item cf::register_script_function $function => $cb + +Register a function that can be called from within map/npc scripts. The +function should be reasonably secure and should be put into a package name +like the extension. + +Example: register a function that gets called whenever a map script calls +C, as used by the C extension. + + cf::register_script_function "rent::overview" => sub { + ... + }; + +=cut + sub register_script_function { my ($fun, $cb) = @_; @@ -817,6 +925,10 @@ *{"safe::$fun"} = $safe_hole->wrap ($cb); } +=back + +=cut + ############################################################################# =head2 EXTENSION DATABASE SUPPORT @@ -874,7 +986,7 @@ sub db_save() { warn "saving database $path\n";#d# remove later waitpid $pid, 0 if $pid; - unless ($pid = fork) { + if (0 == ($pid = fork)) { $db->{_meta}{version} = 1; Storable::nstore $db, "$path~"; rename "$path~", $path; @@ -912,12 +1024,28 @@ } db_dirty; } + + attach_global + prio => 10000, + on_cleanup => sub { + db_sync; + }, + ; } ############################################################################# # the server's main() +sub cfg_load { + open my $fh, "<:utf8", cf::confdir . "/config" + or return; + + local $/; + *CFG = YAML::Syck::Load <$fh>; +} + sub main { + cfg_load; db_load; load_extensions; Event::loop; @@ -979,7 +1107,8 @@ $msg->("reloading cf.pm"); require cf; - # load database again + # load config and database again + cf::cfg_load; cf::db_load; # load extensions @@ -1018,9 +1147,10 @@ unshift @INC, $LIBDIR; $TICK_WATCHER = Event->timer ( - prio => 1, - at => $NEXT_TICK || 1, - cb => sub { + prio => 1, + async => 1, + at => $NEXT_TICK || 1, + cb => sub { cf::server_tick; # one server iteration my $NOW = Event::time; @@ -1034,5 +1164,12 @@ }, ); +IO::AIO::max_poll_time $TICK * 0.2; + +Event->io (fd => IO::AIO::poll_fileno, + poll => 'r', + prio => 5, + cb => \&IO::AIO::poll_cb); + 1