… | |
… | |
14 | |
14 | |
15 | our %COMMAND; |
15 | our %COMMAND; |
16 | our @EVENT; |
16 | our @EVENT; |
17 | our %PROP_TYPE; |
17 | our %PROP_TYPE; |
18 | our %PROP_IDX; |
18 | our %PROP_IDX; |
|
|
19 | our $LIBDIR = maps_directory "perl"; |
19 | |
20 | |
20 | BEGIN { |
21 | BEGIN { |
21 | @EVENT = map lc, @EVENT; |
22 | @EVENT = map lc, @EVENT; |
22 | |
23 | |
23 | *CORE::GLOBAL::warn = sub { |
24 | *CORE::GLOBAL::warn = sub { |
… | |
… | |
230 | if ($who->flag (FLAG_WIZ)) { |
231 | if ($who->flag (FLAG_WIZ)) { |
231 | $who->message ("reloading..."); |
232 | $who->message ("reloading..."); |
232 | |
233 | |
233 | warn "reloading...\n"; |
234 | warn "reloading...\n"; |
234 | eval { |
235 | eval { |
|
|
236 | # 1. cancel all watchers |
235 | $_->cancel for Event::all_watchers; |
237 | $_->cancel for Event::all_watchers; |
236 | |
238 | |
|
|
239 | # 2. unload all extensions |
|
|
240 | for (@exts) { |
|
|
241 | $who->message ("unloading <$_>"); |
237 | unload_extension $_ for @exts; |
242 | unload_extension $_; |
|
|
243 | } |
|
|
244 | |
|
|
245 | # 3. unload all modules loaded from $LIBDIR |
|
|
246 | while (my ($k, $v) = each %INC) { |
|
|
247 | next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; |
|
|
248 | |
|
|
249 | $who->message ("removing <$k>"); |
|
|
250 | delete $INC{$k}; |
|
|
251 | |
|
|
252 | $k =~ s/\.pm$//; |
|
|
253 | $k =~ s/\//::/g; |
|
|
254 | |
|
|
255 | if (my $cb = $k->can ("unload_module")) { |
|
|
256 | $cb->(); |
|
|
257 | } |
|
|
258 | |
|
|
259 | Symbol::delete_package $k; |
|
|
260 | } |
|
|
261 | |
|
|
262 | # 4. get rid of ext::, as good as possible |
|
|
263 | Symbol::delete_package "ext::$_" |
|
|
264 | for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region); |
|
|
265 | |
|
|
266 | # 5. remove register_script_function callbacks |
|
|
267 | # TODO |
|
|
268 | |
|
|
269 | # 6. unload cf.pm "a bit" |
238 | delete $INC{"cf.pm"}; |
270 | delete $INC{"cf.pm"}; |
239 | |
271 | |
240 | # don't, removes xs symbols, too |
272 | # don't, removes xs symbols, too |
241 | #Symbol::delete_package __PACKAGE__; |
273 | #Symbol::delete_package __PACKAGE__; |
242 | |
274 | |
|
|
275 | # 7. reload cf.pm |
|
|
276 | $who->message ("reloading cf.pm"); |
243 | require cf; |
277 | require cf; |
244 | }; |
278 | }; |
245 | warn $@ if $@; |
279 | warn $@ if $@; |
246 | $who->message ($@) if $@; |
280 | $who->message ($@) if $@; |
247 | warn "reloaded\n"; |
281 | warn "reloaded\n"; |
… | |
… | |
326 | # load/save perl data associated with player->ob objects |
360 | # load/save perl data associated with player->ob objects |
327 | |
361 | |
328 | *on_player_load = sub { |
362 | *on_player_load = sub { |
329 | my ($ob, $path) = @_; |
363 | my ($ob, $path) = @_; |
330 | |
364 | |
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) { |
365 | for my $o ($ob, $ob->inv) { |
345 | if (my $value = $o->get_ob_key_value ("_perl_data")) { |
366 | if (my $value = $o->get_ob_key_value ("_perl_data")) { |
346 | $o->set_ob_key_value ("_perl_data"); |
367 | $o->set_ob_key_value ("_perl_data"); |
347 | |
368 | |
348 | %$o = %{ Storable::thaw pack "H*", $value }; |
369 | %$o = %{ Storable::thaw pack "H*", $value }; |
… | |
… | |
353 | *on_player_save = sub { |
374 | *on_player_save = sub { |
354 | my ($ob, $path) = @_; |
375 | my ($ob, $path) = @_; |
355 | |
376 | |
356 | $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) |
377 | $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) |
357 | for grep %$_, $ob, $ob->inv; |
378 | for grep %$_, $ob, $ob->inv; |
358 | |
|
|
359 | unlink "$path.cfperl";#d##TODO#remove |
|
|
360 | }; |
379 | }; |
361 | |
380 | |
362 | ############################################################################# |
381 | ############################################################################# |
363 | # core extensions - in perl |
382 | # core extensions - in perl |
364 | |
383 | |
… | |
… | |
399 | $safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); |
418 | $safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); |
400 | |
419 | |
401 | # here we export the classes and methods available to script code |
420 | # here we export the classes and methods available to script code |
402 | |
421 | |
403 | for ( |
422 | for ( |
404 | ["cf::object" => qw(contr)], |
423 | ["cf::object" => qw(contr pay_amount pay_player)], |
405 | ["cf::object::player" => qw(player)], |
424 | ["cf::object::player" => qw(player)], |
406 | ["cf::player" => qw(peaceful)], |
425 | ["cf::player" => qw(peaceful)], |
407 | ) { |
426 | ) { |
408 | no strict 'refs'; |
427 | no strict 'refs'; |
409 | my ($pkg, @funs) = @$_; |
428 | my ($pkg, @funs) = @$_; |
… | |
… | |
446 | ############################################################################# |
465 | ############################################################################# |
447 | # initialisation |
466 | # initialisation |
448 | |
467 | |
449 | register "<global>", __PACKAGE__; |
468 | register "<global>", __PACKAGE__; |
450 | |
469 | |
451 | unshift @INC, maps_directory "perl"; |
470 | unshift @INC, $LIBDIR; |
452 | |
471 | |
453 | load_extensions; |
472 | load_extensions; |
454 | |
473 | |
455 | 1 |
474 | 1 |
456 | |
475 | |