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.25 by root, Thu Jul 20 07:22:40 2006 UTC vs.
Revision 1.31 by elmex, Mon Aug 14 04:22:04 2006 UTC

… …
14 14
15our %COMMAND; 15our %COMMAND;
16our @EVENT; 16our @EVENT;
17our %PROP_TYPE; 17our %PROP_TYPE;
18our %PROP_IDX; 18our %PROP_IDX;
19our $LIBDIR = maps_directory "perl";
19 20
20BEGIN { 21BEGIN {
21 @EVENT = map lc, @EVENT; 22 @EVENT = map lc, @EVENT;
22 23
23 *CORE::GLOBAL::warn = sub { 24 *CORE::GLOBAL::warn = sub {
… …
69@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 70@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
70@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object'; 71@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
71 72
72# we bless all objects into derived classes to force a method lookup 73# we bless all objects into derived classes to force a method lookup
73# within the Safe compartment. 74# within the Safe compartment.
74for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region)) { 75for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
75 no strict 'refs'; 76 no strict 'refs';
76 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 77 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
77} 78}
78 79
79$Event::DIED = sub { 80$Event::DIED = sub {
… …
179 180
180sub unload_extension { 181sub unload_extension {
181 my ($pkg) = @_; 182 my ($pkg) = @_;
182 183
183 warn "removing extension $pkg\n"; 184 warn "removing extension $pkg\n";
184
185 if (my $cb = $pkg->can ("on_unload")) {
186 $cb->($pkg);
187 }
188 185
189 # remove hooks 186 # remove hooks
190 for my $idx (0 .. $#EVENT) { 187 for my $idx (0 .. $#EVENT) {
191 delete $hook[$idx]{$pkg}; 188 delete $hook[$idx]{$pkg};
192 } 189 }
… …
207 # remove extcmds 204 # remove extcmds
208 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 205 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
209 delete $extcmd{$name}; 206 delete $extcmd{$name};
210 } 207 }
211 208
209 if (my $cb = $pkg->can ("on_unload")) {
210 eval {
211 $cb->($pkg);
212 1
213 } or warn "$pkg unloaded, but with errors: $@";
214 }
215
212 Symbol::delete_package $pkg; 216 Symbol::delete_package $pkg;
213} 217}
214 218
215sub load_extensions { 219sub load_extensions {
216 my $LIBDIR = maps_directory "perl"; 220 my $LIBDIR = maps_directory "perl";
… …
230 if ($who->flag (FLAG_WIZ)) { 234 if ($who->flag (FLAG_WIZ)) {
231 $who->message ("reloading..."); 235 $who->message ("reloading...");
232 236
233 warn "reloading...\n"; 237 warn "reloading...\n";
234 eval { 238 eval {
239 # 1. cancel all watchers
235 $_->cancel for Event::all_watchers; 240 $_->cancel for Event::all_watchers;
236 241
242 # 2. unload all extensions
243 for (@exts) {
244 $who->message ("unloading <$_>");
237 unload_extension $_ for @exts; 245 unload_extension $_;
246 }
247
248 # 3. unload all modules loaded from $LIBDIR
249 while (my ($k, $v) = each %INC) {
250 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
251
252 $who->message ("removing <$k>");
253 delete $INC{$k};
254
255 $k =~ s/\.pm$//;
256 $k =~ s/\//::/g;
257
258 if (my $cb = $k->can ("unload_module")) {
259 $cb->();
260 }
261
262 Symbol::delete_package $k;
263 }
264
265 # 4. get rid of ext::, as good as possible
266 Symbol::delete_package "ext::$_"
267 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
268
269 # 5. remove register_script_function callbacks
270 # TODO
271
272 # 6. unload cf.pm "a bit"
238 delete $INC{"cf.pm"}; 273 delete $INC{"cf.pm"};
239 274
240 # don't, removes xs symbols, too 275 # don't, removes xs symbols, too
241 #Symbol::delete_package __PACKAGE__; 276 #Symbol::delete_package __PACKAGE__;
242 277
278 # 7. reload cf.pm
279 $who->message ("reloading cf.pm");
243 require cf; 280 require cf;
244 }; 281 };
245 warn $@ if $@; 282 warn $@ if $@;
246 $who->message ($@) if $@; 283 $who->message ($@) if $@;
247 warn "reloaded\n"; 284 warn "reloaded\n";
… …
251 $who->message ("Intruder Alert!"); 288 $who->message ("Intruder Alert!");
252 } 289 }
253}; 290};
254 291
255############################################################################# 292#############################################################################
293# utility functions
294
295use JSON::Syck (); # TODO# replace by JSON::PC once working
296
297sub from_json($) {
298 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
299 JSON::Syck::Load $_[0]
300}
301
302sub to_json($) {
303 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
304 JSON::Syck::Dump $_[0]
305}
306
307#############################################################################
256# extcmd framework, basically convert ext <id> <pkg> arg1 args 308# extcmd framework, basically convert ext <msg>
257# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 309# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
258 310
259sub on_extcmd { 311sub on_extcmd {
260 my ($pl, $buf) = @_; 312 my ($pl, $buf) = @_;
261 313
262 my ($type) = $buf =~ s/^(\S+) // ? $1 : ""; 314 my $msg = eval { from_json $buf };
263 315
264 $extcmd{$type}[0]->($pl, $buf) 316 if (ref $msg) {
265 if $extcmd{$type}; 317 if (my $cb = $extcmd{$msg->{msgtype}}) {
318 if (my %reply = $cb->[0]->($pl, $msg)) {
319 $pl->ext_reply ($msg->{msgid}, %reply);
320 }
321 }
322 } else {
323 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
324 }
325
326 1
266} 327}
267 328
268############################################################################# 329#############################################################################
269# load/save/clean perl data associated with a map 330# load/save/clean perl data associated with a map
270 331
… …
326# load/save perl data associated with player->ob objects 387# load/save perl data associated with player->ob objects
327 388
328*on_player_load = sub { 389*on_player_load = sub {
329 my ($ob, $path) = @_; 390 my ($ob, $path) = @_;
330 391
331 if (open my $fh, "<:raw", "$path.cfperl") {
332
333 #d##TODO#remove
334
335 my $data = Storable::thaw do { local $/; <$fh> };
336
337 $data->{version} <= 1
338 or return; # too new
339
340 %$ob = %{$data->{ob}};
341 return;
342 }
343
344 for my $o ($ob, $ob->inv) { 392 for my $o ($ob, $ob->inv) {
345 if (my $value = $o->get_ob_key_value ("_perl_data")) { 393 if (my $value = $o->get_ob_key_value ("_perl_data")) {
346 $o->set_ob_key_value ("_perl_data"); 394 $o->set_ob_key_value ("_perl_data");
347 395
348 %$o = %{ Storable::thaw pack "H*", $value }; 396 %$o = %{ Storable::thaw pack "H*", $value };
… …
353*on_player_save = sub { 401*on_player_save = sub {
354 my ($ob, $path) = @_; 402 my ($ob, $path) = @_;
355 403
356 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) 404 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
357 for grep %$_, $ob, $ob->inv; 405 for grep %$_, $ob, $ob->inv;
358
359 unlink "$path.cfperl";#d##TODO#remove
360}; 406};
361 407
362############################################################################# 408#############################################################################
363# core extensions - in perl 409# core extensions - in perl
364 410
… …
370 416
371sub cf::player::exists($) { 417sub cf::player::exists($) {
372 cf::player::find $_[0] 418 cf::player::find $_[0]
373 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 419 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
374} 420}
421
422=item $player->reply ($npc, $msg[, $flags])
423
424Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
425can be C<undef>. Does the right thing when the player is currently in a
426dialogue with the given NPC character.
427
428=cut
375 429
376# rough implementation of a future "reply" method that works 430# rough implementation of a future "reply" method that works
377# with dialog boxes. 431# with dialog boxes.
378sub cf::object::player::reply($$$;$) { 432sub cf::object::player::reply($$$;$) {
379 my ($self, $npc, $msg, $flags) = @_; 433 my ($self, $npc, $msg, $flags) = @_;
… …
386 $msg = $npc->name . " says: $msg" if $npc; 440 $msg = $npc->name . " says: $msg" if $npc;
387 $self->message ($msg, $flags); 441 $self->message ($msg, $flags);
388 } 442 }
389} 443}
390 444
445=item $player->ext_reply ($msgid, $msgtype, %msg)
446
447Sends an ext reply to the player.
448
449=cut
450
451sub cf::player::ext_reply($$$%) {
452 my ($self, $id, %msg) = @_;
453
454 $msg{msgid} = $id;
455
456 $self->send ("ext " . to_json \%msg);
457}
458
391############################################################################# 459#############################################################################
392# map scripting support 460# map scripting support
393 461
394our $safe = new Safe "ext"; 462our $safe = new Safe "ext";
395our $safe_hole = new Safe::Hole; 463our $safe_hole = new Safe::Hole;
… …
399$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 467$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
400 468
401# here we export the classes and methods available to script code 469# here we export the classes and methods available to script code
402 470
403for ( 471for (
404 ["cf::object" => qw(contr)], 472 ["cf::object" => qw(contr pay_amount pay_player)],
405 ["cf::object::player" => qw(player)], 473 ["cf::object::player" => qw(player)],
406 ["cf::player" => qw(peaceful)], 474 ["cf::player" => qw(peaceful)],
407) { 475) {
408 no strict 'refs'; 476 no strict 'refs';
409 my ($pkg, @funs) = @$_; 477 my ($pkg, @funs) = @$_;
… …
446############################################################################# 514#############################################################################
447# initialisation 515# initialisation
448 516
449register "<global>", __PACKAGE__; 517register "<global>", __PACKAGE__;
450 518
451unshift @INC, maps_directory "perl"; 519unshift @INC, $LIBDIR;
452 520
453load_extensions; 521load_extensions;
454 522
4551 5231
456 524

Diff Legend

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