--- deliantra/server/lib/cf.pm 2006/03/07 01:37:06 1.6 +++ deliantra/server/lib/cf.pm 2006/08/09 10:57:28 1.29 @@ -3,6 +3,12 @@ use Symbol; use List::Util; use Storable; +use Opcode; +use Safe; +use Safe::Hole; + +use Event; +$Event::Eval = 1; # no idea why this is required, but it is use strict; @@ -10,6 +16,7 @@ our @EVENT; our %PROP_TYPE; our %PROP_IDX; +our $LIBDIR = maps_directory "perl"; BEGIN { @EVENT = map lc, @EVENT; @@ -24,6 +31,8 @@ }; } +my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! + # generate property mutators sub prop_gen { my ($prefix, $class) = @_; @@ -43,7 +52,7 @@ *{"$class\::set_$sub"} = sub { $_[0]->set_property ($type, $idx, $_[1]); - }; + } unless $ignore_set{$prop}; } } @@ -58,32 +67,43 @@ # 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)) { + no strict 'refs'; + @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; +} + +$Event::DIED = sub { + warn "error in event callback: @_"; +}; my %ext_pkg; my @exts; my @hook; my %command; +my %extcmd; sub inject_event { - my ($data) = @_; + my $extension = shift; + my $event_code = shift; - my $cb = $hook[$data->{event_code}]{$data->{extension}} + my $cb = $hook[$event_code]{$extension} or return; - $cb->($data) + &$cb } sub inject_global_event { - my ($data) = @_; + my $event = shift; - my $cb = $hook[$data->{event_code}] + my $cb = $hook[$event] or return; - $_->($data) for values %$cb; - - () + List::Util::max map &$_, values %$cb } sub inject_command { @@ -100,19 +120,27 @@ my ($name, $time, $cb) = @_; my $caller = caller; - - warn "registering command '$name/$time' to '$caller'"; + #warn "registering command '$name/$time' to '$caller'"; push @{ $command{$name} }, [$time, $cb, $caller]; $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} }; } +sub register_extcmd { + my ($name, $cb) = @_; + + my $caller = caller; + #warn "registering extcmd '$name' to '$caller'"; + + $extcmd{$name} = [$cb, $caller]; +} + sub register { my ($base, $pkg) = @_; for my $idx (0 .. $#EVENT) { if (my $ref = $pkg->can ("on_$EVENT[$idx]")) { - warn "registering $EVENT[$idx] hook to '$pkg'\n"; + #warn "registering $EVENT[$idx] hook to '$pkg'\n"; $hook[$idx]{$base} = $ref; } } @@ -145,7 +173,7 @@ $ext_pkg{$base} = $pkg; # no strict 'refs'; -# @{"$pkg\::ISA"} = cf::ext::; +# @{"$pkg\::ISA"} = ext::; register $base, $pkg; } @@ -155,6 +183,10 @@ warn "removing extension $pkg\n"; + if (my $cb = $pkg->can ("on_unload")) { + $cb->($pkg); + } + # remove hooks for my $idx (0 .. $#EVENT) { delete $hook[$idx]{$pkg}; @@ -173,6 +205,11 @@ } } + # remove extcmds + for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { + delete $extcmd{$name}; + } + Symbol::delete_package $pkg; } @@ -196,12 +233,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 $@; @@ -214,9 +286,58 @@ } }; +############################################################################# +# 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 $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"; + } + + 1 +} + +############################################################################# +# load/save/clean perl data associated with a map + +*on_mapclean = sub { + my ($map) = @_; + + my $path = $map->tmpname; + defined $path or return; + + unlink "$path.cfperl"; +}; + *on_mapin = *on_mapload = sub { - my $map = shift->{map}; + my ($map) = @_; my $path = $map->tmpname; $path = $map->path unless defined $path; @@ -233,7 +354,7 @@ }; *on_mapout = sub { - my $map = shift->{map}; + my ($map) = @_; my $path = $map->tmpname; $path = $map->path unless defined $path; @@ -244,17 +365,156 @@ open my $fh, ">:raw", "$path.cfperl" or die "$path.cfperl: $!"; + stat $path; + print $fh Storable::nfreeze { + size => (stat _)[7], + time => (stat _)[9], version => 1, - obs => $obs, + obs => $obs, }; + + chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g* } else { unlink "$path.cfperl"; } }; +############################################################################# +# load/save perl data associated with player->ob objects + +*on_player_load = sub { + my ($ob, $path) = @_; + + for my $o ($ob, $ob->inv) { + if (my $value = $o->get_ob_key_value ("_perl_data")) { + $o->set_ob_key_value ("_perl_data"); + + %$o = %{ Storable::thaw pack "H*", $value }; + } + } +}; + +*on_player_save = sub { + my ($ob, $path) = @_; + + $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) + for grep %$_, $ob, $ob->inv; +}; + +############################################################################# +# core extensions - in perl + +=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, $LIBDIR; + load_extensions; 1