ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.22 by root, Wed Jul 19 08:50:42 2006 UTC vs.
Revision 1.33 by root, Mon Aug 21 01:51:23 2006 UTC

1package cf; 1package cf;
2 2
3use Symbol; 3use Symbol;
4use List::Util; 4use List::Util;
5use Storable; 5use Storable;
6use Opcode;
7use Safe;
8use Safe::Hole;
6 9
10use Time::HiRes;
7use Event; 11use Event;
8$Event::Eval = 1; # no idea why this is required, but it is 12$Event::Eval = 1; # no idea why this is required, but it is
9 13
10use strict; 14use strict;
11 15
12our %COMMAND; 16our %COMMAND;
13our @EVENT; 17our @EVENT;
14our %PROP_TYPE; 18our %PROP_TYPE;
15our %PROP_IDX; 19our %PROP_IDX;
20our $LIBDIR = maps_directory "perl";
16 21
17BEGIN { 22BEGIN {
18 @EVENT = map lc, @EVENT; 23 @EVENT = map lc, @EVENT;
19 24
20 *CORE::GLOBAL::warn = sub { 25 *CORE::GLOBAL::warn = sub {
… …
61prop_gen MAP_PROP => "cf::map"; 66prop_gen MAP_PROP => "cf::map";
62prop_gen ARCH_PROP => "cf::arch"; 67prop_gen ARCH_PROP => "cf::arch";
63 68
64# guessed hierarchies 69# guessed hierarchies
65 70
66@cf::object::player::ISA = 'cf::object'; 71@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
67@cf::object::map::ISA = 'cf::object'; 72@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
73
74# we bless all objects into derived classes to force a method lookup
75# within the Safe compartment.
76for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
77 no strict 'refs';
78 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
79}
68 80
69$Event::DIED = sub { 81$Event::DIED = sub {
70 warn "error in event callback: @_"; 82 warn "error in event callback: @_";
71}; 83};
72 84
… …
160 172
161 push @exts, $pkg; 173 push @exts, $pkg;
162 $ext_pkg{$base} = $pkg; 174 $ext_pkg{$base} = $pkg;
163 175
164# no strict 'refs'; 176# no strict 'refs';
165# @{"$pkg\::ISA"} = cf::ext::; 177# @{"$pkg\::ISA"} = ext::;
166 178
167 register $base, $pkg; 179 register $base, $pkg;
168} 180}
169 181
170sub unload_extension { 182sub unload_extension {
171 my ($pkg) = @_; 183 my ($pkg) = @_;
172 184
173 warn "removing extension $pkg\n"; 185 warn "removing extension $pkg\n";
174
175 if (my $cb = $pkg->can ("on_unload")) {
176 $cb->($pkg);
177 }
178 186
179 # remove hooks 187 # remove hooks
180 for my $idx (0 .. $#EVENT) { 188 for my $idx (0 .. $#EVENT) {
181 delete $hook[$idx]{$pkg}; 189 delete $hook[$idx]{$pkg};
182 } 190 }
… …
197 # remove extcmds 205 # remove extcmds
198 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 206 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
199 delete $extcmd{$name}; 207 delete $extcmd{$name};
200 } 208 }
201 209
210 if (my $cb = $pkg->can ("on_unload")) {
211 eval {
212 $cb->($pkg);
213 1
214 } or warn "$pkg unloaded, but with errors: $@";
215 }
216
202 Symbol::delete_package $pkg; 217 Symbol::delete_package $pkg;
203} 218}
204 219
205sub load_extensions { 220sub load_extensions {
206 my $LIBDIR = maps_directory "perl"; 221 my $LIBDIR = maps_directory "perl";
… …
220 if ($who->flag (FLAG_WIZ)) { 235 if ($who->flag (FLAG_WIZ)) {
221 $who->message ("reloading..."); 236 $who->message ("reloading...");
222 237
223 warn "reloading...\n"; 238 warn "reloading...\n";
224 eval { 239 eval {
240 # 1. cancel all watchers
225 $_->cancel for Event::all_watchers; 241 $_->cancel for Event::all_watchers;
226 242
243 # 2. unload all extensions
244 for (@exts) {
245 $who->message ("unloading <$_>");
227 unload_extension $_ for @exts; 246 unload_extension $_;
247 }
248
249 # 3. unload all modules loaded from $LIBDIR
250 while (my ($k, $v) = each %INC) {
251 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
252
253 $who->message ("removing <$k>");
254 delete $INC{$k};
255
256 $k =~ s/\.pm$//;
257 $k =~ s/\//::/g;
258
259 if (my $cb = $k->can ("unload_module")) {
260 $cb->();
261 }
262
263 Symbol::delete_package $k;
264 }
265
266 # 4. get rid of ext::, as good as possible
267 Symbol::delete_package "ext::$_"
268 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
269
270 # 5. remove register_script_function callbacks
271 # TODO
272
273 # 6. unload cf.pm "a bit"
228 delete $INC{"cf.pm"}; 274 delete $INC{"cf.pm"};
229 275
230 # don't, removes xs symbols, too 276 # don't, removes xs symbols, too
231 #Symbol::delete_package __PACKAGE__; 277 #Symbol::delete_package __PACKAGE__;
232 278
279 # 7. reload cf.pm
280 $who->message ("reloading cf.pm");
233 require cf; 281 require cf;
234 }; 282 };
235 warn $@ if $@; 283 warn $@ if $@;
236 $who->message ($@) if $@; 284 $who->message ($@) if $@;
237 warn "reloaded\n"; 285 warn "reloaded\n";
… …
241 $who->message ("Intruder Alert!"); 289 $who->message ("Intruder Alert!");
242 } 290 }
243}; 291};
244 292
245############################################################################# 293#############################################################################
294# utility functions
295
296use JSON::Syck (); # TODO# replace by JSON::PC once working
297
298sub from_json($) {
299 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
300 JSON::Syck::Load $_[0]
301}
302
303sub to_json($) {
304 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
305 JSON::Syck::Dump $_[0]
306}
307
308#############################################################################
246# extcmd framework, basically convert ext <id> <pkg> arg1 args 309# extcmd framework, basically convert ext <msg>
247# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 310# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
248 311
249sub on_extcmd { 312sub on_extcmd {
250 my ($pl, $buf) = @_; 313 my ($pl, $buf) = @_;
251 314
252 my ($type) = $buf =~ s/^(\S+) // ? $1 : ""; 315 my $msg = eval { from_json $buf };
253 316
254 $extcmd{$type}[0]->($pl, $buf) 317 if (ref $msg) {
255 if $extcmd{$type}; 318 if (my $cb = $extcmd{$msg->{msgtype}}) {
319 if (my %reply = $cb->[0]->($pl, $msg)) {
320 $pl->ext_reply ($msg->{msgid}, %reply);
321 }
322 }
323 } else {
324 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
325 }
326
327 1
256} 328}
257 329
258############################################################################# 330#############################################################################
259# load/save/clean perl data associated with a map 331# load/save/clean perl data associated with a map
260 332
… …
313}; 385};
314 386
315############################################################################# 387#############################################################################
316# load/save perl data associated with player->ob objects 388# load/save perl data associated with player->ob objects
317 389
390sub all_objects(@) {
391 @_, map all_objects ($_->inv), @_
392}
393
318*on_player_load = sub { 394*on_player_load = sub {
319 my ($ob, $path) = @_; 395 my ($ob, $path) = @_;
320 396
321 if (open my $fh, "<:raw", "$path.cfperl") { 397 for my $o (all_objects $ob) {
322
323 #d##TODO#remove
324
325 my $data = Storable::thaw do { local $/; <$fh> };
326
327 $data->{version} <= 1
328 or return; # too new
329
330 %$ob = %{$data->{ob}};
331 return;
332 }
333
334 for my $o ($ob, $ob->inv) {
335 if (my $value = $o->get_ob_key_value ("_perl_data")) { 398 if (my $value = $o->get_ob_key_value ("_perl_data")) {
336 $o->set_ob_key_value ("_perl_data"); 399 $o->set_ob_key_value ("_perl_data");
337 400
338 %$o = %{ Storable::thaw pack "H*", $value }; 401 %$o = %{ Storable::thaw pack "H*", $value };
339 } 402 }
… …
342 405
343*on_player_save = sub { 406*on_player_save = sub {
344 my ($ob, $path) = @_; 407 my ($ob, $path) = @_;
345 408
346 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) 409 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
347 for grep %$_, $ob, $ob->inv; 410 for grep %$_, all_objects $ob;
348
349 unlink "$path.cfperl";#d##TODO#remove
350}; 411};
351 412
352############################################################################# 413#############################################################################
353# core extensions - in perl 414# core extensions - in perl
415
416my $delta_timer = Event->timer (
417 parked => 1,
418 prio => Event::PRIO_HIGH,
419 cb => sub { Event::unloop (undef) },
420);
421
422sub sleep_delta($) {
423 $delta_timer->at (Event::time + $_[0]);
424 $delta_timer->start;
425 Event::loop;
426}
427
428=item cf::player::exists $login
429
430Returns true when the given account exists.
431
432=cut
433
434sub cf::player::exists($) {
435 cf::player::find $_[0]
436 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
437}
438
439=item $player->reply ($npc, $msg[, $flags])
440
441Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
442can be C<undef>. Does the right thing when the player is currently in a
443dialogue with the given NPC character.
444
445=cut
354 446
355# rough implementation of a future "reply" method that works 447# rough implementation of a future "reply" method that works
356# with dialog boxes. 448# with dialog boxes.
357sub cf::object::player::reply($$;$) { 449sub cf::object::player::reply($$$;$) {
358 my ($self, $msg, $flags) = @_; 450 my ($self, $npc, $msg, $flags) = @_;
359 451
360 $flags = cf::NDI_WHITE unless @_ >= 3; 452 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
361 453
454 if ($self->{record_replies}) {
455 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
456 } else {
457 $msg = $npc->name . " says: $msg" if $npc;
362 $self->message ($msg, $flags); 458 $self->message ($msg, $flags);
459 }
460}
461
462=item $player->ext_reply ($msgid, $msgtype, %msg)
463
464Sends an ext reply to the player.
465
466=cut
467
468sub cf::player::ext_reply($$$%) {
469 my ($self, $id, %msg) = @_;
470
471 $msg{msgid} = $id;
472
473 $self->send ("ext " . to_json \%msg);
474}
475
476#############################################################################
477# map scripting support
478
479our $safe = new Safe "ext";
480our $safe_hole = new Safe::Hole;
481
482$SIG{FPE} = 'IGNORE';
483
484$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
485
486# here we export the classes and methods available to script code
487
488for (
489 ["cf::object" => qw(contr pay_amount pay_player)],
490 ["cf::object::player" => qw(player)],
491 ["cf::player" => qw(peaceful)],
492) {
493 no strict 'refs';
494 my ($pkg, @funs) = @$_;
495 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
496 for @funs;
497}
498
499sub safe_eval($;@) {
500 my ($code, %vars) = @_;
501
502 my $qcode = $code;
503 $qcode =~ s/"/‟/g; # not allowed in #line filenames
504 $qcode =~ s/\n/\\n/g;
505
506 local $_;
507 local @ext::cf::_safe_eval_args = values %vars;
508
509 $code =
510 "do {\n"
511 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
512 . "#line 0 \"{$qcode}\"\n"
513 . $code
514 . "\n}"
515 ;
516
517 sub_generation_inc;
518 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code);
519 sub_generation_inc;
520
521 wantarray ? @res : $res[0]
522}
523
524sub register_script_function {
525 my ($fun, $cb) = @_;
526
527 no strict 'refs';
528 *{"ext::$fun"} = $safe_hole->wrap ($cb);
363} 529}
364 530
365############################################################################# 531#############################################################################
366# initialisation 532# initialisation
367 533
368register "<global>", __PACKAGE__; 534register "<global>", __PACKAGE__;
369 535
370unshift @INC, maps_directory "perl"; 536unshift @INC, $LIBDIR;
371 537
372load_extensions; 538load_extensions;
373 539
3741 5401
375 541

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines