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.151 by root, Mon Jan 8 20:59:15 2007 UTC vs.
Revision 1.159 by root, Wed Jan 10 22:50:12 2007 UTC

… …
15use Coro::Timer; 15use Coro::Timer;
16use Coro::Signal; 16use Coro::Signal;
17use Coro::Semaphore; 17use Coro::Semaphore;
18use Coro::AIO; 18use Coro::AIO;
19 19
20use Data::Dumper;
20use Digest::MD5; 21use Digest::MD5;
21use Fcntl; 22use Fcntl;
22use IO::AIO 2.32 (); 23use IO::AIO 2.32 ();
23use YAML::Syck (); 24use YAML::Syck ();
24use Time::HiRes; 25use Time::HiRes;
25 26
26use Event; $Event::Eval = 1; # no idea why this is required, but it is 27use Event; $Event::Eval = 1; # no idea why this is required, but it is
27 28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30
28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1; 32$YAML::Syck::ImplicitUnicode = 1;
30 33
31$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
32 35
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34
35our %COMMAND = (); 36our %COMMAND = ();
36our %COMMAND_TIME = (); 37our %COMMAND_TIME = ();
38
39our @EXTS = (); # list of extension package names
37our %EXTCMD = (); 40our %EXTCMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions
38 42
39our @EVENT; 43our @EVENT;
40our $LIBDIR = datadir . "/ext"; 44our $LIBDIR = datadir . "/ext";
41 45
42our $TICK = MAX_TIME * 1e-6; 46our $TICK = MAX_TIME * 1e-6;
… …
51 55
52our %PLAYER; # all users 56our %PLAYER; # all users
53our %MAP; # all maps 57our %MAP; # all maps
54our $LINK_MAP; # the special {link} map 58our $LINK_MAP; # the special {link} map
55our $RANDOM_MAPS = cf::localdir . "/random"; 59our $RANDOM_MAPS = cf::localdir . "/random";
56our %EXT_CORO; # coroutines bound to extensions 60
61our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
62our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
57 63
58binmode STDOUT; 64binmode STDOUT;
59binmode STDERR; 65binmode STDERR;
60 66
61# read virtual server time, if available 67# read virtual server time, if available
… …
105 111
106=item %cf::CFG 112=item %cf::CFG
107 113
108Configuration for the server, loaded from C</etc/crossfire/config>, or 114Configuration for the server, loaded from C</etc/crossfire/config>, or
109from wherever your confdir points to. 115from wherever your confdir points to.
116
117=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
118
119These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
120or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
121processing has been done. Call C<< ->wait >> on them to maximise the
122window of cpu time available, or simply to synchronise to the server tick.
110 123
111=back 124=back
112 125
113=cut 126=cut
114 127
… …
146 159
147$Event::DIED = sub { 160$Event::DIED = sub {
148 warn "error in event callback: @_"; 161 warn "error in event callback: @_";
149}; 162};
150 163
151my %ext_pkg;
152my @exts;
153my @hook;
154
155=head2 UTILITY FUNCTIONS 164=head2 UTILITY FUNCTIONS
156 165
157=over 4 166=over 4
158 167
168=item dumpval $ref
169
159=cut 170=cut
171
172sub dumpval {
173 eval {
174 local $SIG{__DIE__};
175 my $d;
176 if (1) {
177 $d = new Data::Dumper([$_[0]], ["*var"]);
178 $d->Terse(1);
179 $d->Indent(2);
180 $d->Quotekeys(0);
181 $d->Useqq(1);
182 #$d->Bless(...);
183 $d->Seen($_[1]) if @_ > 1;
184 $d = $d->Dump();
185 }
186 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
187 $d
188 } || "[unable to dump $_[0]: '$@']";
189}
160 190
161use JSON::Syck (); # TODO# replace by JSON::PC once working 191use JSON::Syck (); # TODO# replace by JSON::PC once working
162 192
163=item $ref = cf::from_json $json 193=item $ref = cf::from_json $json
164 194
… …
287 } 317 }
288} 318}
289 319
290=item $coro = cf::async_ext { BLOCK } 320=item $coro = cf::async_ext { BLOCK }
291 321
292Like async, but this coro is automcatially being canceled when the 322Like async, but this coro is automatically being canceled when the
293extension calling this is being unloaded. 323extension calling this is being unloaded.
294 324
295=cut 325=cut
296 326
297sub async_ext(&) { 327sub async_ext(&) {
… …
334=cut 364=cut
335 365
336############################################################################# 366#############################################################################
337 367
338package cf::path; 368package cf::path;
369
370use overload
371 '""' => \&as_string;
372
373# used to convert map paths into valid unix filenames by repalcing / by ∕
374our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
339 375
340sub new { 376sub new {
341 my ($class, $path, $base) = @_; 377 my ($class, $path, $base) = @_;
342 378
343 $path = $path->as_string if ref $path; 379 $path = $path->as_string if ref $path;
… …
349 # ?random/... random maps 385 # ?random/... random maps
350 # /! non-realised random map exit 386 # /! non-realised random map exit
351 # /... normal maps 387 # /... normal maps
352 # ~/... per-player maps without a specific player (DO NOT USE) 388 # ~/... per-player maps without a specific player (DO NOT USE)
353 # ~user/... per-player map of a specific user 389 # ~user/... per-player map of a specific user
390
391 $path =~ s/$PATH_SEP/\//go;
354 392
355 if ($path =~ /^{/) { 393 if ($path =~ /^{/) {
356 # fine as it is 394 # fine as it is
357 } elsif ($path =~ s{^\?random/}{}) { 395 } elsif ($path =~ s{^\?random/}{}) {
358 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data; 396 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
… …
407# } 445# }
408} 446}
409 447
410# escape the /'s in the path 448# escape the /'s in the path
411sub _escaped_path { 449sub _escaped_path {
412 # ∕ is U+2215
413 (my $path = $_[0]{path}) =~ s/\//∕/g; 450 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
414 $path 451 $path
415} 452}
416 453
417# the original (read-only) location 454# the original (read-only) location
418sub load_path { 455sub load_path {
… …
906=cut 943=cut
907 944
908sub register_extcmd { 945sub register_extcmd {
909 my ($name, $cb) = @_; 946 my ($name, $cb) = @_;
910 947
911 my $caller = caller;
912 #warn "registering extcmd '$name' to '$caller'";
913
914 $EXTCMD{$name} = [$cb, $caller]; 948 $EXTCMD{$name} = $cb;
915} 949}
916 950
917cf::player->attach ( 951cf::player->attach (
918 on_command => sub { 952 on_command => sub {
919 my ($pl, $name, $params) = @_; 953 my ($pl, $name, $params) = @_;
… …
932 966
933 my $msg = eval { from_json $buf }; 967 my $msg = eval { from_json $buf };
934 968
935 if (ref $msg) { 969 if (ref $msg) {
936 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 970 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
937 if (my %reply = $cb->[0]->($pl, $msg)) { 971 if (my %reply = $cb->($pl, $msg)) {
938 $pl->ext_reply ($msg->{msgid}, %reply); 972 $pl->ext_reply ($msg->{msgid}, %reply);
939 } 973 }
940 } 974 }
941 } else { 975 } else {
942 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 976 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
944 978
945 cf::override; 979 cf::override;
946 }, 980 },
947); 981);
948 982
949sub register {
950 my ($base, $pkg) = @_;
951
952 #TODO
953}
954
955sub load_extension { 983sub load_extension {
956 my ($path) = @_; 984 my ($path) = @_;
957 985
958 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 986 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
959 my $base = $1; 987 my $base = $1;
… …
974 1002
975 eval $source 1003 eval $source
976 or die $@ ? "$path: $@\n" 1004 or die $@ ? "$path: $@\n"
977 : "extension disabled.\n"; 1005 : "extension disabled.\n";
978 1006
979 push @exts, $pkg; 1007 push @EXTS, $pkg;
980 $ext_pkg{$base} = $pkg;
981
982# no strict 'refs';
983# @{"$pkg\::ISA"} = ext::;
984
985 register $base, $pkg;
986}
987
988sub unload_extension {
989 my ($pkg) = @_;
990
991 warn "removing extension $pkg\n";
992
993 # remove hooks
994 #TODO
995# for my $idx (0 .. $#PLUGIN_EVENT) {
996# delete $hook[$idx]{$pkg};
997# }
998
999 # remove commands
1000 for my $name (keys %COMMAND) {
1001 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1002
1003 if (@cb) {
1004 $COMMAND{$name} = \@cb;
1005 } else {
1006 delete $COMMAND{$name};
1007 }
1008 }
1009
1010 # remove extcmds
1011 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1012 delete $EXTCMD{$name};
1013 }
1014
1015 if (my $cb = $pkg->can ("unload")) {
1016 eval {
1017 $cb->($pkg);
1018 1
1019 } or warn "$pkg unloaded, but with errors: $@";
1020 }
1021
1022 Symbol::delete_package $pkg;
1023} 1008}
1024 1009
1025sub load_extensions { 1010sub load_extensions {
1026 for my $ext (<$LIBDIR/*.ext>) { 1011 for my $ext (<$LIBDIR/*.ext>) {
1027 next unless -r $ext; 1012 next unless -r $ext;
… …
1045}; 1030};
1046 1031
1047cf::map->attach (prio => -10000, package => cf::mapsupport::); 1032cf::map->attach (prio => -10000, package => cf::mapsupport::);
1048 1033
1049############################################################################# 1034#############################################################################
1050# load/save perl data associated with player->ob objects
1051
1052sub all_objects(@) {
1053 @_, map all_objects ($_->inv), @_
1054}
1055
1056# TODO: compatibility cruft, remove when no longer needed
1057cf::player->attach (
1058 on_load => sub {
1059 my ($pl, $path) = @_;
1060
1061 for my $o (all_objects $pl->ob) {
1062 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1063 $o->set_ob_key_value ("_perl_data");
1064
1065 %$o = %{ Storable::thaw pack "H*", $value };
1066 }
1067 }
1068 },
1069);
1070
1071#############################################################################
1072 1035
1073=head2 CORE EXTENSIONS 1036=head2 CORE EXTENSIONS
1074 1037
1075Functions and methods that extend core crossfire objects. 1038Functions and methods that extend core crossfire objects.
1076 1039
1077=cut 1040=cut
1078 1041
1079package cf::player; 1042package cf::player;
1043
1044use Coro::AIO;
1080 1045
1081=head3 cf::player 1046=head3 cf::player
1082 1047
1083=over 4 1048=over 4
1084 1049
… …
1137 my $path = path $pl; 1102 my $path = path $pl;
1138 my $guard = cf::lock_acquire "user_save:$path"; 1103 my $guard = cf::lock_acquire "user_save:$path";
1139 1104
1140 return if $pl->{deny_save}; 1105 return if $pl->{deny_save};
1141 1106
1142 Coro::AIO::aio_mkdir playerdir $pl, 0770; 1107 aio_mkdir playerdir $pl, 0770;
1143 $pl->{last_save} = $cf::RUNTIME; 1108 $pl->{last_save} = $cf::RUNTIME;
1144 1109
1145 $pl->save_pl ($path); 1110 $pl->save_pl ($path);
1146 Coro::cede; 1111 Coro::cede;
1147} 1112}
… …
1156 1121
1157 $cf::PLAYER{$login} = $self; 1122 $cf::PLAYER{$login} = $self;
1158 1123
1159 $self 1124 $self
1160} 1125}
1126
1127=item $pl->quit_character
1128
1129Nukes the player without looking back. If logged in, the connection will
1130be destroyed. May block for a long time.
1131
1132=cut
1161 1133
1162sub quit_character { 1134sub quit_character {
1163 my ($pl) = @_; 1135 my ($pl) = @_;
1164 1136
1165 $pl->{deny_save} = 1; 1137 $pl->{deny_save} = 1;
… …
1170 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1142 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1171 $pl->ns->destroy if $pl->ns; 1143 $pl->ns->destroy if $pl->ns;
1172 1144
1173 my $path = playerdir $pl; 1145 my $path = playerdir $pl;
1174 my $temp = "$path~$cf::RUNTIME~deleting~"; 1146 my $temp = "$path~$cf::RUNTIME~deleting~";
1175 Coro::AIO::aio_rename $path, $temp; 1147 aio_rename $path, $temp;
1176 delete $cf::PLAYER{$pl->ob->name}; 1148 delete $cf::PLAYER{$pl->ob->name};
1177 $pl->destroy; 1149 $pl->destroy;
1178 IO::AIO::aio_rmtree $temp; 1150 IO::AIO::aio_rmtree $temp;
1151}
1152
1153=item cf::player::list_logins
1154
1155Returns am arrayref of all valid playernames in the system, can take a
1156while and may block, so not sync_job-capable, ever.
1157
1158=cut
1159
1160sub list_logins {
1161 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1162 or return [];
1163
1164 my @logins;
1165
1166 for my $login (@$dirs) {
1167 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1168 aio_read $fh, 0, 512, my $buf, 0 or next;
1169 $buf !~ /^password -------------$/m or next; # official not-valid tag
1170
1171 utf8::decode $login;
1172 push @logins, $login;
1173 }
1174
1175 \@logins
1176}
1177
1178=item $player->maps
1179
1180Returns an arrayref of cf::path's of all maps that are private for this
1181player. May block.
1182
1183=cut
1184
1185sub maps($) {
1186 my ($pl) = @_;
1187
1188 my $files = aio_readdir playerdir $pl
1189 or return;
1190
1191 my @paths;
1192
1193 for (@$files) {
1194 utf8::decode $_;
1195 next if /\.(?:pl|pst)$/;
1196 next unless /^$PATH_SEP/o;
1197
1198 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
1199 }
1200
1201 \@paths
1179} 1202}
1180 1203
1181=item $player->ext_reply ($msgid, $msgtype, %msg) 1204=item $player->ext_reply ($msgid, $msgtype, %msg)
1182 1205
1183Sends an ext reply to the player. 1206Sends an ext reply to the player.
… …
1366 Coro::cede; 1389 Coro::cede;
1367 1390
1368 $self->in_memory (cf::MAP_IN_MEMORY); 1391 $self->in_memory (cf::MAP_IN_MEMORY);
1369} 1392}
1370 1393
1394# find and load all maps in the 3x3 area around a map
1395sub load_diag {
1396 my ($map) = @_;
1397
1398 my @diag; # diagonal neighbours
1399
1400 for (0 .. 3) {
1401 my $neigh = $map->tile_path ($_)
1402 or next;
1403 $neigh = find $neigh, $map
1404 or next;
1405 $neigh->load;
1406
1407 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1408 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1409 }
1410
1411 for (@diag) {
1412 my $neigh = find @$_
1413 or next;
1414 $neigh->load;
1415 }
1416}
1417
1371sub find_sync { 1418sub find_sync {
1372 my ($path, $origin) = @_; 1419 my ($path, $origin) = @_;
1373 1420
1374 cf::sync_job { cf::map::find $path, $origin } 1421 cf::sync_job { find $path, $origin }
1375} 1422}
1376 1423
1377sub do_load_sync { 1424sub do_load_sync {
1378 my ($map) = @_; 1425 my ($map) = @_;
1379 1426
1380 cf::sync_job { $map->load }; 1427 cf::sync_job { $map->load };
1428}
1429
1430our %MAP_PREFETCH;
1431our $MAP_PREFETCHER = Coro::async {
1432 while () {
1433 while (%MAP_PREFETCH) {
1434 my $key = each %MAP_PREFETCH
1435 or next;
1436 my $path = delete $MAP_PREFETCH{$key};
1437
1438 my $map = find $path
1439 or next;
1440 $map->load;
1441 }
1442 Coro::schedule;
1443 }
1444};
1445
1446sub find_async {
1447 my ($path, $origin) = @_;
1448
1449 $path = new cf::path $path, $origin && $origin->path;
1450 my $key = $path->as_string;
1451
1452 if (my $map = $cf::MAP{$key}) {
1453 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1454 }
1455
1456 $MAP_PREFETCH{$key} = $path;
1457 $MAP_PREFETCHER->ready;
1458
1459 ()
1381} 1460}
1382 1461
1383sub save { 1462sub save {
1384 my ($self) = @_; 1463 my ($self) = @_;
1385 1464
… …
1503 } 1582 }
1504 1583
1505 $map 1584 $map
1506} 1585}
1507 1586
1508sub emergency_save { 1587=item cf::map::unique_maps
1509 my $freeze_guard = cf::freeze_mainloop;
1510 1588
1511 warn "enter emergency perl save\n"; 1589Returns an arrayref of cf::path's of all shared maps that have
1590instantiated unique items. May block.
1512 1591
1513 cf::sync_job { 1592=cut
1514 warn "begin emergency player save\n";
1515 $_->save for values %cf::PLAYER;
1516 warn "end emergency player save\n";
1517 1593
1518 warn "begin emergency map save\n"; 1594sub unique_maps() {
1519 $_->save for values %cf::MAP; 1595 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1520 warn "end emergency map save\n"; 1596 or return;
1597
1598 my @paths;
1599
1600 for (@$files) {
1601 utf8::decode $_;
1602 next if /\.pst$/;
1603 next unless /^$PATH_SEP/o;
1604
1605 push @paths, new cf::path $_;
1521 }; 1606 }
1522 1607
1523 warn "leave emergency perl save\n"; 1608 \@paths
1524} 1609}
1525 1610
1526package cf; 1611package cf;
1527 1612
1528=back 1613=back
1529 1614
1615=head3 cf::object
1616
1617=cut
1618
1619package cf::object;
1620
1621=over 4
1622
1623=item $ob->inv_recursive
1624
1625Returns the inventory of the object _and_ their inventories, recursively.
1626
1627=cut
1628
1629sub inv_recursive_;
1630sub inv_recursive_ {
1631 map { $_, inv_recursive_ $_->inv } @_
1632}
1633
1634sub inv_recursive {
1635 inv_recursive_ inv $_[0]
1636}
1637
1638package cf;
1639
1640=back
1530 1641
1531=head3 cf::object::player 1642=head3 cf::object::player
1532 1643
1533=over 4 1644=over 4
1534 1645
… …
1626 # use -1 or undef as default coordinates, not 0, 0 1737 # use -1 or undef as default coordinates, not 0, 0
1627 ($x, $y) = ($map->enter_x, $map->enter_y) 1738 ($x, $y) = ($map->enter_x, $map->enter_y)
1628 if $x <=0 && $y <= 0; 1739 if $x <=0 && $y <= 0;
1629 1740
1630 $map->load; 1741 $map->load;
1742 $map->load_diag;
1631 1743
1632 return unless $self->contr->active; 1744 return unless $self->contr->active;
1633 $self->activate_recursive; 1745 $self->activate_recursive;
1634 $self->enter_map ($map, $x, $y); 1746 $self->enter_map ($map, $x, $y);
1635} 1747}
… …
1671=cut 1783=cut
1672 1784
1673sub cf::object::player::goto { 1785sub cf::object::player::goto {
1674 my ($self, $path, $x, $y) = @_; 1786 my ($self, $path, $x, $y) = @_;
1675 1787
1788 $path = new cf::path $path;
1789
1676 $self->enter_link; 1790 $self->enter_link;
1677 1791
1678 (async { 1792 (async {
1679 $path = new cf::path $path;
1680
1681 my $map = cf::map::find $path->as_string; 1793 my $map = cf::map::find $path->as_string;
1682 $map = $map->customise_for ($self) if $map; 1794 $map = $map->customise_for ($self) if $map;
1683 1795
1684# warn "entering ", $map->path, " at ($x, $y)\n" 1796# warn "entering ", $map->path, " at ($x, $y)\n"
1685# if $map; 1797# if $map;
1686 1798
1687 $map or $map->cluck ("oy");#d#
1688 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1799 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1689 1800
1690 $self->leave_link ($map, $x, $y); 1801 $self->leave_link ($map, $x, $y);
1691 })->prio (1); 1802 })->prio (1);
1692} 1803}
… …
1759 1870
1760 1; 1871 1;
1761 }) { 1872 }) {
1762 $self->message ("Something went wrong deep within the crossfire server. " 1873 $self->message ("Something went wrong deep within the crossfire server. "
1763 . "I'll try to bring you back to the map you were before. " 1874 . "I'll try to bring you back to the map you were before. "
1764 . "Please report this to the dungeon master", 1875 . "Please report this to the dungeon master!",
1765 cf::NDI_UNIQUE | cf::NDI_RED); 1876 cf::NDI_UNIQUE | cf::NDI_RED);
1766 1877
1767 warn "ERROR in enter_exit: $@"; 1878 warn "ERROR in enter_exit: $@";
1768 $self->leave_link; 1879 $self->leave_link;
1769 } 1880 }
… …
2122 load_extensions; 2233 load_extensions;
2123 Event::loop; 2234 Event::loop;
2124} 2235}
2125 2236
2126############################################################################# 2237#############################################################################
2127# initialisation 2238# initialisation and cleanup
2239
2240# install some emergency cleanup handlers
2241BEGIN {
2242 for my $signal (qw(INT HUP TERM)) {
2243 Event->signal (
2244 data => WF_AUTOCANCEL,
2245 signal => $signal,
2246 cb => sub {
2247 cf::cleanup "SIG$signal";
2248 },
2249 );
2250 }
2251}
2252
2253sub emergency_save() {
2254 my $freeze_guard = cf::freeze_mainloop;
2255
2256 warn "enter emergency perl save\n";
2257
2258 cf::sync_job {
2259 # use a peculiar iteration method to avoid tripping on perl
2260 # refcount bugs in for. also avoids problems with players
2261 # and maps saved/Destroyed asynchronously.
2262 warn "begin emergency player save\n";
2263 for my $login (keys %cf::PLAYER) {
2264 my $pl = $cf::PLAYER{$login} or next;
2265 $pl->valid or next;
2266 $pl->save;
2267 }
2268 warn "end emergency player save\n";
2269
2270 warn "begin emergency map save\n";
2271 for my $path (keys %cf::MAP) {
2272 my $map = $cf::MAP{$path} or next;
2273 $map->valid or next;
2274 $map->save;
2275 }
2276 warn "end emergency map save\n";
2277 };
2278
2279 warn "leave emergency perl save\n";
2280}
2128 2281
2129sub reload() { 2282sub reload() {
2130 # can/must only be called in main 2283 # can/must only be called in main
2131 if ($Coro::current != $Coro::main) { 2284 if ($Coro::current != $Coro::main) {
2132 warn "can only reload from main coroutine\n"; 2285 warn "can only reload from main coroutine\n";
2133 return; 2286 return;
2134 } 2287 }
2135 2288
2136 warn "reloading..."; 2289 warn "reloading...";
2137 2290
2291 warn "freezing server";
2138 my $guard = freeze_mainloop; 2292 my $guard = freeze_mainloop;
2139 cf::emergency_save; 2293 cf::emergency_save;
2140 2294
2295 warn "sync database to disk";
2296 cf::db_sync;
2297 IO::AIO::flush;
2298
2141 eval { 2299 eval {
2142 # if anything goes wrong in here, we should simply crash as we already saved 2300 # if anything goes wrong in here, we should simply crash as we already saved
2143 2301
2144 # cancel all watchers 2302 warn "cancel all watchers";
2145 for (Event::all_watchers) { 2303 for (Event::all_watchers) {
2146 $_->cancel if $_->data & WF_AUTOCANCEL; 2304 $_->cancel if $_->data & WF_AUTOCANCEL;
2147 } 2305 }
2148 2306
2149 # cancel all extension coros 2307 warn "cancel all extension coros";
2150 $_->cancel for values %EXT_CORO; 2308 $_->cancel for values %EXT_CORO;
2151 %EXT_CORO = (); 2309 %EXT_CORO = ();
2152 2310
2311 warn "remove commands";
2312 %COMMAND = ();
2313
2314 warn "remove ext commands";
2315 %EXTCMD = ();
2316
2153 # unload all extensions 2317 warn "unload/nuke all extensions";
2154 for (@exts) { 2318 for my $pkg (@EXTS) {
2155 warn "unloading <$_>"; 2319 warn "unloading <$pkg>";
2156 unload_extension $_; 2320
2321 if (my $cb = $pkg->can ("unload")) {
2322 eval {
2323 $cb->($pkg);
2324 1
2325 } or warn "$pkg unloaded, but with errors: $@";
2157 } 2326 }
2158 2327
2328 Symbol::delete_package $pkg;
2329 }
2330
2159 # unload all modules loaded from $LIBDIR 2331 warn "unload all perl modules loaded from $LIBDIR";
2160 while (my ($k, $v) = each %INC) { 2332 while (my ($k, $v) = each %INC) {
2161 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2333 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2162 2334
2163 warn "removing <$k>"; 2335 warn "removing <$k>";
2164 delete $INC{$k}; 2336 delete $INC{$k};
… …
2171 } 2343 }
2172 2344
2173 Symbol::delete_package $k; 2345 Symbol::delete_package $k;
2174 } 2346 }
2175 2347
2176 # sync database to disk
2177 cf::db_sync;
2178 IO::AIO::flush;
2179
2180 # get rid of safe::, as good as possible 2348 warn "get rid of safe::, as good as possible";
2181 Symbol::delete_package "safe::$_" 2349 Symbol::delete_package "safe::$_"
2182 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2350 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2183 2351
2184 # remove register_script_function callbacks
2185 # TODO
2186
2187 # unload cf.pm "a bit" 2352 warn "unload cf.pm \"a bit\"";
2188 delete $INC{"cf.pm"}; 2353 delete $INC{"cf.pm"};
2189 2354
2190 # don't, removes xs symbols, too, 2355 # don't, removes xs symbols, too,
2191 # and global variables created in xs 2356 # and global variables created in xs
2192 #Symbol::delete_package __PACKAGE__; 2357 #Symbol::delete_package __PACKAGE__;
2193 2358
2194 # reload cf.pm
2195 warn "reloading cf.pm"; 2359 warn "reloading cf.pm";
2196 require cf; 2360 require cf;
2197 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2361 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2198 2362
2199 # load config and database again 2363 warn "load config and database again";
2200 cf::cfg_load; 2364 cf::cfg_load;
2201 cf::db_load; 2365 cf::db_load;
2202 2366
2203 # load extensions
2204 warn "load extensions"; 2367 warn "load extensions";
2205 cf::load_extensions; 2368 cf::load_extensions;
2206 2369
2207 # reattach attachments to objects 2370 warn "reattach attachments to objects/players";
2208 warn "reattach";
2209 _global_reattach; 2371 _global_reattach;
2372 warn "reattach attachments to maps";
2210 reattach $_ for values %MAP; 2373 reattach $_ for values %MAP;
2211 }; 2374 };
2212 2375
2213 if ($@) { 2376 if ($@) {
2214 warn $@; 2377 warn $@;
2215 warn "error while reloading, exiting."; 2378 warn "error while reloading, exiting.";
2216 exit 1; 2379 exit 1;
2217 } 2380 }
2218 2381
2219 warn "reloaded successfully"; 2382 warn "reloaded";
2220}; 2383};
2221 2384
2222############################################################################# 2385#############################################################################
2223 2386
2224unless ($LINK_MAP) { 2387unless ($LINK_MAP) {
… …
2259 $LINK_MAP->{deny_save} = 1; 2422 $LINK_MAP->{deny_save} = 1;
2260 $LINK_MAP->{deny_reset} = 1; 2423 $LINK_MAP->{deny_reset} = 1;
2261 2424
2262 $cf::MAP{$LINK_MAP->path} = $LINK_MAP; 2425 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2263} 2426}
2264
2265register "<global>", __PACKAGE__;
2266 2427
2267register_command "reload" => sub { 2428register_command "reload" => sub {
2268 my ($who, $arg) = @_; 2429 my ($who, $arg) = @_;
2269 2430
2270 if ($who->flag (FLAG_WIZ)) { 2431 if ($who->flag (FLAG_WIZ)) {
… …
2283 data => WF_AUTOCANCEL, 2444 data => WF_AUTOCANCEL,
2284 cb => sub { 2445 cb => sub {
2285 cf::server_tick; # one server iteration 2446 cf::server_tick; # one server iteration
2286 $RUNTIME += $TICK; 2447 $RUNTIME += $TICK;
2287 $NEXT_TICK += $TICK; 2448 $NEXT_TICK += $TICK;
2449
2450 $WAIT_FOR_TICK->broadcast;
2451 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2288 2452
2289 # if we are delayed by four ticks or more, skip them all 2453 # if we are delayed by four ticks or more, skip them all
2290 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2454 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2291 2455
2292 $TICK_WATCHER->at ($NEXT_TICK); 2456 $TICK_WATCHER->at ($NEXT_TICK);

Diff Legend

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