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.157 by root, Wed Jan 10 01:16:54 2007 UTC vs.
Revision 1.164 by root, Thu Jan 11 01:24:25 2007 UTC

… …
33 33
34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
35 35
36our %COMMAND = (); 36our %COMMAND = ();
37our %COMMAND_TIME = (); 37our %COMMAND_TIME = ();
38
39our @EXTS = (); # list of extension package names
38our %EXTCMD = (); 40our %EXTCMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps
39 43
40our @EVENT; 44our @EVENT;
41our $LIBDIR = datadir . "/ext"; 45our $LIBDIR = datadir . "/ext";
42 46
43our $TICK = MAX_TIME * 1e-6; 47our $TICK = MAX_TIME * 1e-6;
… …
52 56
53our %PLAYER; # all users 57our %PLAYER; # all users
54our %MAP; # all maps 58our %MAP; # all maps
55our $LINK_MAP; # the special {link} map 59our $LINK_MAP; # the special {link} map
56our $RANDOM_MAPS = cf::localdir . "/random"; 60our $RANDOM_MAPS = cf::localdir . "/random";
57our %EXT_CORO; # coroutines bound to extensions
58 61
59our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal; 62our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
60our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal; 63our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
61 64
62binmode STDOUT; 65binmode STDOUT;
… …
156} 159}
157 160
158$Event::DIED = sub { 161$Event::DIED = sub {
159 warn "error in event callback: @_"; 162 warn "error in event callback: @_";
160}; 163};
161
162my %ext_pkg;
163my @exts;
164my @hook;
165 164
166=head2 UTILITY FUNCTIONS 165=head2 UTILITY FUNCTIONS
167 166
168=over 4 167=over 4
169 168
… …
319 } 318 }
320} 319}
321 320
322=item $coro = cf::async_ext { BLOCK } 321=item $coro = cf::async_ext { BLOCK }
323 322
324Like async, but this coro is automcatially being canceled when the 323Like async, but this coro is automatically being canceled when the
325extension calling this is being unloaded. 324extension calling this is being unloaded.
326 325
327=cut 326=cut
328 327
329sub async_ext(&) { 328sub async_ext(&) {
… …
367 366
368############################################################################# 367#############################################################################
369 368
370package cf::path; 369package cf::path;
371 370
371use overload
372 '""' => \&as_string;
373
372# used to convert map paths into valid unix filenames by repalcing / by ∕ 374# used to convert map paths into valid unix filenames by repalcing / by ∕
373our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 375our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
374 376
377sub register {
378 my ($pkg, $prefix) = @_;
379
380 $EXT_MAP{$prefix} = $pkg;
381}
382
375sub new { 383sub new {
376 my ($class, $path, $base) = @_; 384 my ($class, $path, $base) = @_;
377 385
378 $path = $path->as_string if ref $path; 386 return $path if ref $path;
379 387
380 my $self = bless { }, $class; 388 my $self = {};
381 389
382 # {... are special paths that are not touched 390 # {... are special paths that are not being touched
383 # ?xxx/... are special absolute paths 391 # ?xxx/... are special absolute paths
384 # ?random/... random maps 392 # ?random/... random maps
385 # /! non-realised random map exit 393 # /! non-realised random map exit
386 # /... normal maps 394 # /... normal maps
387 # ~/... per-player maps without a specific player (DO NOT USE) 395 # ~/... per-player maps without a specific player (DO NOT USE)
388 # ~user/... per-player map of a specific user 396 # ~user/... per-player map of a specific user
389 397
398 $path =~ s/$PATH_SEP/\//go;
399
390 if ($path =~ /^{/) { 400 if ($path =~ /^{/) {
391 # fine as it is 401 # fine as it is
392 } elsif ($path =~ s{^\?random/}{}) {
393 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
394 $self->{random} = cf::from_json $data;
395 } else { 402 } else {
396 if ($path =~ s{^~([^/]+)?}{}) { 403 if ($path =~ s{^~([^/]+)?}{}) {
404 # ~user
397 $self->{user_rel} = 1; 405 $self->{user_rel} = 1;
398 406
399 if (defined $1) { 407 if (defined $1) {
400 $self->{user} = $1; 408 $self->{user} = $1;
401 } elsif ($base =~ m{^~([^/]+)/}) { 409 } elsif ($base =~ m{^~([^/]+)/}) {
402 $self->{user} = $1; 410 $self->{user} = $1;
403 } else { 411 } else {
404 warn "cannot resolve user-relative path without user <$path,$base>\n"; 412 warn "cannot resolve user-relative path without user <$path,$base>\n";
405 } 413 }
414 } elsif ($path =~ s{^\?([^/]+)/}{}) {
415 # ?...
416 $self->{ext} = $1;
417 if (my $ext = $EXT_MAP{$1}) {
418 bless $self, $ext;
419 }
406 } elsif ($path =~ /^\//) { 420 } elsif ($path =~ /^\//) {
421 # /...
407 # already absolute 422 # already absolute
408 } else { 423 } else {
424 # relative
409 $base =~ s{[^/]+/?$}{}; 425 $base =~ s{[^/]+/?$}{};
410 return $class->new ("$base/$path"); 426 return $class->new ("$base/$path");
411 } 427 }
412 428
413 for ($path) { 429 for ($path) {
… …
416 } 432 }
417 } 433 }
418 434
419 $self->{path} = $path; 435 $self->{path} = $path;
420 436
437 if ("HASH" eq ref $self) {
438 bless $self, $class;
439 } else {
440 $self->init;
441 }
442
443 for my $ext (values %EXT_MAP) {
444 if (my $subst = $ext->substitute ($self)) {
445 return $subst;
446 }
447 }
448
421 $self 449 $self
450}
451
452sub init {
453 # nop
454}
455
456sub substitute {
457 ()
422} 458}
423 459
424# the name / primary key / in-game path 460# the name / primary key / in-game path
425sub as_string { 461sub as_string {
426 my ($self) = @_; 462 my ($self) = @_;
427 463
428 $self->{user_rel} ? "~$self->{user}$self->{path}" 464 $self->{user_rel} ? "~$self->{user}$self->{path}"
429 : $self->{random} ? "?random/$self->{path}" 465 : $self->{ext} ? "?$self->{ext}/$self->{path}"
430 : $self->{path} 466 : $self->{path}
431} 467}
432 468
433# the displayed name, this is a one way mapping 469# the displayed name, this is a one way mapping
434sub visible_name { 470sub visible_name {
435 my ($self) = @_; 471 &as_string
436
437# if (my $rmp = $self->{random}) {
438# # todo: be more intelligent about this
439# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
440# } else {
441 $self->as_string
442# }
443} 472}
444 473
445# escape the /'s in the path 474# escape the /'s in the path
446sub _escaped_path { 475sub _escaped_path {
447 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 476 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
477
448 $path 478 $path
449} 479}
450 480
451# the original (read-only) location 481# the original (read-only) location
452sub load_path { 482sub load_path {
… …
457 487
458# the temporary/swap location 488# the temporary/swap location
459sub save_path { 489sub save_path {
460 my ($self) = @_; 490 my ($self) = @_;
461 491
492 $self->{user_rel}
462 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path 493 ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
463 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
464 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path 494 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
465} 495}
466 496
467# the unique path, might be eq to save_path 497# the unique path, undef == no special unique path
468sub uniq_path { 498sub uniq_path {
469 my ($self) = @_; 499 my ($self) = @_;
470 500
471 $self->{user_rel} || $self->{random}
472 ? undef
473 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path 501 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
474}
475
476# return random map parameters, or undef
477sub random_map_params {
478 my ($self) = @_;
479
480 $self->{random}
481} 502}
482 503
483# this is somewhat ugly, but style maps do need special treatment 504# this is somewhat ugly, but style maps do need special treatment
484sub is_style_map { 505sub is_style_map {
485 $_[0]{path} =~ m{^/styles/} 506 $_[0]{path} =~ m{^/styles/}
507}
508
509sub load_orig {
510 my ($self) = @_;
511
512 &cf::map::load_map_header ($self->load_path)
513}
514
515sub load_temp {
516 my ($self) = @_;
517
518 &cf::map::load_map_header ($self->save_path)
519}
520
521sub unlink_save {
522 my ($self) = @_;
523
524 utf8::encode (my $save = $self->save_path);
525 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save;
526 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst";
486} 527}
487 528
488package cf; 529package cf;
489 530
490############################################################################# 531#############################################################################
… …
940=cut 981=cut
941 982
942sub register_extcmd { 983sub register_extcmd {
943 my ($name, $cb) = @_; 984 my ($name, $cb) = @_;
944 985
945 my $caller = caller;
946 #warn "registering extcmd '$name' to '$caller'";
947
948 $EXTCMD{$name} = [$cb, $caller]; 986 $EXTCMD{$name} = $cb;
949} 987}
950 988
951cf::player->attach ( 989cf::player->attach (
952 on_command => sub { 990 on_command => sub {
953 my ($pl, $name, $params) = @_; 991 my ($pl, $name, $params) = @_;
… …
966 1004
967 my $msg = eval { from_json $buf }; 1005 my $msg = eval { from_json $buf };
968 1006
969 if (ref $msg) { 1007 if (ref $msg) {
970 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1008 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
971 if (my %reply = $cb->[0]->($pl, $msg)) { 1009 if (my %reply = $cb->($pl, $msg)) {
972 $pl->ext_reply ($msg->{msgid}, %reply); 1010 $pl->ext_reply ($msg->{msgid}, %reply);
973 } 1011 }
974 } 1012 }
975 } else { 1013 } else {
976 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1014 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
978 1016
979 cf::override; 1017 cf::override;
980 }, 1018 },
981); 1019);
982 1020
983sub register {
984 my ($base, $pkg) = @_;
985
986 #TODO
987}
988
989sub load_extension { 1021sub load_extension {
990 my ($path) = @_; 1022 my ($path) = @_;
991 1023
992 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1024 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
993 my $base = $1; 1025 my $base = $1;
994 my $pkg = $1; 1026 my $pkg = $1;
995 $pkg =~ s/[^[:word:]]/_/g; 1027 $pkg =~ s/[^[:word:]]/_/g;
996 $pkg = "ext::$pkg"; 1028 $pkg = "ext::$pkg";
997 1029
998 warn "loading '$path' into '$pkg'\n"; 1030 warn "... loading '$path' into '$pkg'\n";
999 1031
1000 open my $fh, "<:utf8", $path 1032 open my $fh, "<:utf8", $path
1001 or die "$path: $!"; 1033 or die "$path: $!";
1002 1034
1003 my $source = 1035 my $source =
… …
1008 1040
1009 eval $source 1041 eval $source
1010 or die $@ ? "$path: $@\n" 1042 or die $@ ? "$path: $@\n"
1011 : "extension disabled.\n"; 1043 : "extension disabled.\n";
1012 1044
1013 push @exts, $pkg; 1045 push @EXTS, $pkg;
1014 $ext_pkg{$base} = $pkg;
1015
1016# no strict 'refs';
1017# @{"$pkg\::ISA"} = ext::;
1018
1019 register $base, $pkg;
1020}
1021
1022sub unload_extension {
1023 my ($pkg) = @_;
1024
1025 warn "removing extension $pkg\n";
1026
1027 # remove hooks
1028 #TODO
1029# for my $idx (0 .. $#PLUGIN_EVENT) {
1030# delete $hook[$idx]{$pkg};
1031# }
1032
1033 # remove commands
1034 for my $name (keys %COMMAND) {
1035 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1036
1037 if (@cb) {
1038 $COMMAND{$name} = \@cb;
1039 } else {
1040 delete $COMMAND{$name};
1041 }
1042 }
1043
1044 # remove extcmds
1045 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1046 delete $EXTCMD{$name};
1047 }
1048
1049 if (my $cb = $pkg->can ("unload")) {
1050 eval {
1051 $cb->($pkg);
1052 1
1053 } or warn "$pkg unloaded, but with errors: $@";
1054 }
1055
1056 Symbol::delete_package $pkg;
1057} 1046}
1058 1047
1059sub load_extensions { 1048sub load_extensions {
1060 for my $ext (<$LIBDIR/*.ext>) { 1049 for my $ext (<$LIBDIR/*.ext>) {
1061 next unless -r $ext; 1050 next unless -r $ext;
… …
1240 my @paths; 1229 my @paths;
1241 1230
1242 for (@$files) { 1231 for (@$files) {
1243 utf8::decode $_; 1232 utf8::decode $_;
1244 next if /\.(?:pl|pst)$/; 1233 next if /\.(?:pl|pst)$/;
1245 next unless /^$PATH_SEP/; 1234 next unless /^$PATH_SEP/o;
1246 1235
1247 s/$PATH_SEP/\//g;
1248 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_; 1236 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
1249 } 1237 }
1250 1238
1251 \@paths 1239 \@paths
1252} 1240}
… …
1286 1274
1287sub generate_random_map { 1275sub generate_random_map {
1288 my ($path, $rmp) = @_; 1276 my ($path, $rmp) = @_;
1289 1277
1290 # mit "rum" bekleckern, nicht 1278 # mit "rum" bekleckern, nicht
1291 cf::map::_create_random_map 1279 cf::map::_create_random_map (
1292 $path, 1280 $path,
1293 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1281 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1294 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1282 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1295 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1283 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1296 $rmp->{exit_on_final_map}, 1284 $rmp->{exit_on_final_map},
… …
1298 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1286 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1299 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1287 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1300 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1288 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1301 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1289 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1302 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1290 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1303 (cf::region::find $rmp->{region}) 1291 (cf::region::find $rmp->{region}), $rmp->{custom}
1292 )
1304} 1293}
1305 1294
1306# and all this just because we cannot iterate over 1295# and all this just because we cannot iterate over
1307# all maps in C++... 1296# all maps in C++...
1308sub change_all_map_light { 1297sub change_all_map_light {
… …
1310 1299
1311 $_->change_map_light ($change) 1300 $_->change_map_light ($change)
1312 for grep $_->outdoor, values %cf::MAP; 1301 for grep $_->outdoor, values %cf::MAP;
1313} 1302}
1314 1303
1315sub try_load_header($) { 1304sub load_map_header($) {
1316 my ($path) = @_; 1305 my ($path) = @_;
1317 1306
1318 utf8::encode $path; 1307 utf8::encode $path;
1319 aio_open $path, O_RDONLY, 0 1308 aio_open $path, O_RDONLY, 0
1320 or return; 1309 or return;
1321 1310
1322 my $map = cf::map::new 1311 my $map = cf::map::new
1323 or return; 1312 or return;
1324 1313
1325 # for better error messages only, will be overwritten 1314 # for better error messages only, will be overwritten later
1326 $map->path ($path); 1315 $map->path ($path);
1327 1316
1328 $map->load_header ($path) 1317 $map->load_header ($path)
1329 or return; 1318 or return;
1330 1319
… …
1346 1335
1347 $cf::MAP{$key} || do { 1336 $cf::MAP{$key} || do {
1348 my $guard = cf::lock_acquire "map_find:$key"; 1337 my $guard = cf::lock_acquire "map_find:$key";
1349 1338
1350 # do it the slow way 1339 # do it the slow way
1351 my $map = try_load_header $path->save_path; 1340 my $map = $path->load_temp;
1352 1341
1353 Coro::cede; 1342 Coro::cede;
1354 1343
1355 if ($map) { 1344 if ($map) {
1356 $map->last_access ((delete $map->{last_access}) 1345 $map->last_access ((delete $map->{last_access})
1357 || $cf::RUNTIME); #d# 1346 || $cf::RUNTIME); #d#
1358 # safety 1347 # safety
1359 $map->{instantiate_time} = $cf::RUNTIME 1348 $map->{instantiate_time} = $cf::RUNTIME
1360 if $map->{instantiate_time} > $cf::RUNTIME; 1349 if $map->{instantiate_time} > $cf::RUNTIME;
1361 } else { 1350 } else {
1362 if (my $rmp = $path->random_map_params) { 1351 $map = $path->load_orig
1363 $map = generate_random_map $key, $rmp;
1364 } else {
1365 $map = try_load_header $path->load_path;
1366 }
1367
1368 $map or return; 1352 or return;
1369 1353
1370 $map->{load_original} = 1; 1354 $map->{load_original} = 1;
1371 $map->{instantiate_time} = $cf::RUNTIME; 1355 $map->{instantiate_time} = $cf::RUNTIME;
1372 $map->last_access ($cf::RUNTIME); 1356 $map->last_access ($cf::RUNTIME);
1373 $map->instantiate; 1357 $map->instantiate;
… …
1425 1409
1426 if ($self->{path}->is_style_map) { 1410 if ($self->{path}->is_style_map) {
1427 $self->{deny_save} = 1; 1411 $self->{deny_save} = 1;
1428 $self->{deny_reset} = 1; 1412 $self->{deny_reset} = 1;
1429 } else { 1413 } else {
1414 $self->decay_objects;
1430 $self->fix_auto_apply; 1415 $self->fix_auto_apply;
1431 $self->decay_objects;
1432 $self->update_buttons; 1416 $self->update_buttons;
1433 $self->set_darkness_map; 1417 $self->set_darkness_map;
1434 $self->difficulty ($self->estimate_difficulty) 1418 $self->difficulty ($self->estimate_difficulty)
1435 unless $self->difficulty; 1419 unless $self->difficulty;
1436 $self->activate; 1420 $self->activate;
… …
1572 my ($self) = @_; 1556 my ($self) = @_;
1573 1557
1574 $self->reset_at <= $cf::RUNTIME 1558 $self->reset_at <= $cf::RUNTIME
1575} 1559}
1576 1560
1577sub unlink_save {
1578 my ($self) = @_;
1579
1580 utf8::encode (my $save = $self->{path}->save_path);
1581 aioreq_pri 3; IO::AIO::aio_unlink $save;
1582 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1583}
1584
1585sub rename { 1561sub rename {
1586 my ($self, $new_path) = @_; 1562 my ($self, $new_path) = @_;
1587 1563
1588 $self->unlink_save; 1564 $self->{path}->unlink_save;
1589 1565
1590 delete $cf::MAP{$self->path}; 1566 delete $cf::MAP{$self->path};
1591 $self->{path} = new cf::path $new_path; 1567 $self->{path} = new cf::path $new_path;
1592 $self->path ($self->{path}->as_string); 1568 $self->path ($self->{path}->as_string);
1593 $cf::MAP{$self->path} = $self; 1569 $cf::MAP{$self->path} = $self;
… …
1607 1583
1608 delete $cf::MAP{$self->path}; 1584 delete $cf::MAP{$self->path};
1609 1585
1610 $_->clear_links_to ($self) for values %cf::MAP; 1586 $_->clear_links_to ($self) for values %cf::MAP;
1611 1587
1612 $self->unlink_save; 1588 $self->{path}->unlink_save;
1613 $self->destroy; 1589 $self->destroy;
1614} 1590}
1615 1591
1616my $nuke_counter = "aaaa"; 1592my $nuke_counter = "aaaa";
1617 1593
… …
1630 if ($map->per_player) { 1606 if ($map->per_player) {
1631 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1607 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path};
1632 } 1608 }
1633 1609
1634 $map 1610 $map
1611}
1612
1613=item cf::map::unique_maps
1614
1615Returns an arrayref of cf::path's of all shared maps that have
1616instantiated unique items. May block.
1617
1618=cut
1619
1620sub unique_maps() {
1621 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1622 or return;
1623
1624 my @paths;
1625
1626 for (@$files) {
1627 utf8::decode $_;
1628 next if /\.pst$/;
1629 next unless /^$PATH_SEP/o;
1630
1631 push @paths, new cf::path $_;
1632 }
1633
1634 \@paths
1635} 1635}
1636 1636
1637package cf; 1637package cf;
1638 1638
1639=back 1639=back
… …
1810 1810
1811sub cf::object::player::goto { 1811sub cf::object::player::goto {
1812 my ($self, $path, $x, $y) = @_; 1812 my ($self, $path, $x, $y) = @_;
1813 1813
1814 $path = new cf::path $path; 1814 $path = new cf::path $path;
1815 $path ne "/" or Carp::cluck ("oy");#d#
1816 1815
1817 $self->enter_link; 1816 $self->enter_link;
1818 1817
1819 (async { 1818 (async {
1820 my $map = cf::map::find $path->as_string; 1819 my $map = cf::map::find $path->as_string;
… …
1897 1896
1898 1; 1897 1;
1899 }) { 1898 }) {
1900 $self->message ("Something went wrong deep within the crossfire server. " 1899 $self->message ("Something went wrong deep within the crossfire server. "
1901 . "I'll try to bring you back to the map you were before. " 1900 . "I'll try to bring you back to the map you were before. "
1902 . "Please report this to the dungeon master", 1901 . "Please report this to the dungeon master!",
1903 cf::NDI_UNIQUE | cf::NDI_RED); 1902 cf::NDI_UNIQUE | cf::NDI_RED);
1904 1903
1905 warn "ERROR in enter_exit: $@"; 1904 warn "ERROR in enter_exit: $@";
1906 $self->leave_link; 1905 $self->leave_link;
1907 } 1906 }
… …
2313 return; 2312 return;
2314 } 2313 }
2315 2314
2316 warn "reloading..."; 2315 warn "reloading...";
2317 2316
2317 warn "freezing server";
2318 my $guard = freeze_mainloop; 2318 my $guard = freeze_mainloop;
2319 cf::emergency_save; 2319 cf::emergency_save;
2320 2320
2321 warn "sync database to disk";
2322 cf::db_sync;
2323 IO::AIO::flush;
2324
2321 eval { 2325 eval {
2322 # if anything goes wrong in here, we should simply crash as we already saved 2326 # if anything goes wrong in here, we should simply crash as we already saved
2323 2327
2324 # cancel all watchers 2328 warn "cancel all watchers";
2325 for (Event::all_watchers) { 2329 for (Event::all_watchers) {
2326 $_->cancel if $_->data & WF_AUTOCANCEL; 2330 $_->cancel if $_->data & WF_AUTOCANCEL;
2327 } 2331 }
2328 2332
2329 # cancel all extension coros 2333 warn "cancel all extension coros";
2330 $_->cancel for values %EXT_CORO; 2334 $_->cancel for values %EXT_CORO;
2331 %EXT_CORO = (); 2335 %EXT_CORO = ();
2332 2336
2337 warn "remove commands";
2338 %COMMAND = ();
2339
2340 warn "remove ext commands";
2341 %EXTCMD = ();
2342
2333 # unload all extensions 2343 warn "unload/nuke all extensions";
2334 for (@exts) { 2344 for my $pkg (@EXTS) {
2335 warn "unloading <$_>"; 2345 warn "... unloading $pkg";
2336 unload_extension $_; 2346
2347 if (my $cb = $pkg->can ("unload")) {
2348 eval {
2349 $cb->($pkg);
2350 1
2351 } or warn "$pkg unloaded, but with errors: $@";
2337 } 2352 }
2338 2353
2354 warn "... nuking $pkg";
2355 Symbol::delete_package $pkg;
2356 }
2357
2339 # unload all modules loaded from $LIBDIR 2358 warn "unload all perl modules loaded from $LIBDIR";
2340 while (my ($k, $v) = each %INC) { 2359 while (my ($k, $v) = each %INC) {
2341 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2360 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2342 2361
2343 warn "removing <$k>"; 2362 warn "removing <$k>";
2344 delete $INC{$k}; 2363 delete $INC{$k};
… …
2351 } 2370 }
2352 2371
2353 Symbol::delete_package $k; 2372 Symbol::delete_package $k;
2354 } 2373 }
2355 2374
2356 # sync database to disk
2357 cf::db_sync;
2358 IO::AIO::flush;
2359
2360 # get rid of safe::, as good as possible 2375 warn "get rid of safe::, as good as possible";
2361 Symbol::delete_package "safe::$_" 2376 Symbol::delete_package "safe::$_"
2362 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2377 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2363 2378
2364 # remove register_script_function callbacks
2365 # TODO
2366
2367 # unload cf.pm "a bit" 2379 warn "unload cf.pm \"a bit\"";
2368 delete $INC{"cf.pm"}; 2380 delete $INC{"cf.pm"};
2369 2381
2370 # don't, removes xs symbols, too, 2382 # don't, removes xs symbols, too,
2371 # and global variables created in xs 2383 # and global variables created in xs
2372 #Symbol::delete_package __PACKAGE__; 2384 #Symbol::delete_package __PACKAGE__;
2373 2385
2374 # reload cf.pm
2375 warn "reloading cf.pm"; 2386 warn "reloading cf.pm";
2376 require cf; 2387 require cf;
2377 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2388 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2378 2389
2379 # load config and database again 2390 warn "load config and database again";
2380 cf::cfg_load; 2391 cf::cfg_load;
2381 cf::db_load; 2392 cf::db_load;
2382 2393
2383 # load extensions
2384 warn "load extensions"; 2394 warn "load extensions";
2385 cf::load_extensions; 2395 cf::load_extensions;
2386 2396
2387 # reattach attachments to objects 2397 warn "reattach attachments to objects/players";
2388 warn "reattach";
2389 _global_reattach; 2398 _global_reattach;
2399 warn "reattach attachments to maps";
2390 reattach $_ for values %MAP; 2400 reattach $_ for values %MAP;
2391 }; 2401 };
2392 2402
2393 if ($@) { 2403 if ($@) {
2394 warn $@; 2404 warn $@;
2395 warn "error while reloading, exiting."; 2405 warn "error while reloading, exiting.";
2396 exit 1; 2406 exit 1;
2397 } 2407 }
2398 2408
2399 warn "reloaded successfully"; 2409 warn "reloaded";
2400}; 2410};
2401 2411
2402############################################################################# 2412#############################################################################
2403 2413
2404unless ($LINK_MAP) { 2414unless ($LINK_MAP) {
… …
2440 $LINK_MAP->{deny_reset} = 1; 2450 $LINK_MAP->{deny_reset} = 1;
2441 2451
2442 $cf::MAP{$LINK_MAP->path} = $LINK_MAP; 2452 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2443} 2453}
2444 2454
2445register "<global>", __PACKAGE__;
2446
2447register_command "reload" => sub { 2455register_command "reload" => sub {
2448 my ($who, $arg) = @_; 2456 my ($who, $arg) = @_;
2449 2457
2450 if ($who->flag (FLAG_WIZ)) { 2458 if ($who->flag (FLAG_WIZ)) {
2451 $who->message ("start of reload."); 2459 $who->message ("start of reload.");
… …
2460 reentrant => 0, 2468 reentrant => 0,
2461 prio => 0, 2469 prio => 0,
2462 at => $NEXT_TICK || $TICK, 2470 at => $NEXT_TICK || $TICK,
2463 data => WF_AUTOCANCEL, 2471 data => WF_AUTOCANCEL,
2464 cb => sub { 2472 cb => sub {
2473 $NOW = Event::time;
2474
2465 cf::server_tick; # one server iteration 2475 cf::server_tick; # one server iteration
2466 $RUNTIME += $TICK; 2476 $RUNTIME += $TICK;
2467 $NEXT_TICK += $TICK; 2477 $NEXT_TICK += $TICK;
2468 2478
2469 $WAIT_FOR_TICK->broadcast; 2479 $WAIT_FOR_TICK->broadcast;

Diff Legend

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