--- deliantra/server/lib/cf.pm 2006/07/11 14:24:15 1.18 +++ deliantra/server/lib/cf.pm 2006/08/15 18:07:25 1.32 @@ -3,7 +3,13 @@ use Symbol; use List::Util; use Storable; +use Opcode; +use Safe; +use Safe::Hole; + +use Time::HiRes; use Event; +$Event::Eval = 1; # no idea why this is required, but it is use strict; @@ -11,6 +17,7 @@ our @EVENT; our %PROP_TYPE; our %PROP_IDX; +our $LIBDIR = maps_directory "perl"; BEGIN { @EVENT = map lc, @EVENT; @@ -61,8 +68,15 @@ # guessed hierarchies -@cf::object::player::ISA = 'cf::object'; -@cf::object::map::ISA = 'cf::object'; +@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; +@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object'; + +# 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 cf::arch)) { + no strict 'refs'; + @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; +} $Event::DIED = sub { warn "error in event callback: @_"; @@ -160,7 +174,7 @@ $ext_pkg{$base} = $pkg; # no strict 'refs'; -# @{"$pkg\::ISA"} = cf::ext::; +# @{"$pkg\::ISA"} = ext::; register $base, $pkg; } @@ -193,6 +207,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; } @@ -216,12 +237,47 @@ warn "reloading...\n"; eval { - unload_extension $_ for @exts; + # 1. cancel all watchers + $_->cancel for Event::all_watchers; + + # 2. unload all extensions + for (@exts) { + $who->message ("unloading <$_>"); + unload_extension $_; + } + + # 3. unload all modules loaded from $LIBDIR + while (my ($k, $v) = each %INC) { + next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; + + $who->message ("removing <$k>"); + delete $INC{$k}; + + $k =~ s/\.pm$//; + $k =~ s/\//::/g; + + if (my $cb = $k->can ("unload_module")) { + $cb->(); + } + + Symbol::delete_package $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 $pkg; + #Symbol::delete_package __PACKAGE__; + # 7. reload cf.pm + $who->message ("reloading cf.pm"); require cf; }; warn $@ if $@; @@ -235,16 +291,40 @@ }; ############################################################################# -# 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 }; + + 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"; + } - $extcmd{$type}[0]->($pl, $buf) - if $extcmd{$type}; + 1 } ############################################################################# @@ -310,19 +390,6 @@ *on_player_load = sub { my ($ob, $path) = @_; - if (open my $fh, "<:raw", "$path.cfperl") { - - #d##TODO#remove - - my $data = Storable::thaw do { local $/; <$fh> }; - - $data->{version} <= 1 - or return; # too new - - %$ob = %{$data->{ob}}; - return; - } - for my $o ($ob, $ob->inv) { if (my $value = $o->get_ob_key_value ("_perl_data")) { $o->set_ob_key_value ("_perl_data"); @@ -337,13 +404,132 @@ $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) for grep %$_, $ob, $ob->inv; - - unlink "$path.cfperl";#d##TODO#remove }; +############################################################################# +# core extensions - in perl + +my $delta_timer = Event->timer ( + parked => 1, + prio => Event::PRIO_HIGH, + cb => sub { Event::unloop (undef) }, +); + +sub sleep_delta($) { + $delta_timer->at (Event::time + $_[0]); + $delta_timer->start; + Event::loop; +} + +=item cf::player::exists $login + +Returns true when the given account exists. + +=cut + +sub cf::player::exists($) { + cf::player::find $_[0] + 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($$$;$) { + my ($self, $npc, $msg, $flags) = @_; + + $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; + + if ($self->{record_replies}) { + push @{ $self->{record_replies} }, [$npc, $msg, $flags]; + } else { + $msg = $npc->name . " says: $msg" if $npc; + $self->message ($msg, $flags); + } +} + +=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 + +our $safe = new Safe "ext"; +our $safe_hole = new Safe::Hole; + +$SIG{FPE} = 'IGNORE'; + +$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); + +# here we export the classes and methods available to script code + +for ( + ["cf::object" => qw(contr pay_amount pay_player)], + ["cf::object::player" => qw(player)], + ["cf::player" => qw(peaceful)], +) { + no strict 'refs'; + my ($pkg, @funs) = @$_; + *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) + for @funs; +} + +sub safe_eval($;@) { + my ($code, %vars) = @_; + + my $qcode = $code; + $qcode =~ s/"/‟/g; # not allowed in #line filenames + $qcode =~ s/\n/\\n/g; + + local $_; + local @ext::cf::_safe_eval_args = values %vars; + + $code = + "do {\n" + . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" + . "#line 0 \"{$qcode}\"\n" + . $code + . "\n}" + ; + + sub_generation_inc; + my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); + sub_generation_inc; + + wantarray ? @res : $res[0] +} + +sub register_script_function { + my ($fun, $cb) = @_; + + no strict 'refs'; + *{"ext::$fun"} = $safe_hole->wrap ($cb); +} + +############################################################################# +# initialisation + register "", __PACKAGE__; -unshift @INC, maps_directory "perl"; +unshift @INC, $LIBDIR; load_extensions;