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.148 by root, Mon Jan 8 12:39:16 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
… …
1119 return $cf::PLAYER{$_[0]} || do { 1084 return $cf::PLAYER{$_[0]} || do {
1120 my $login = $_[0]; 1085 my $login = $_[0];
1121 1086
1122 my $guard = cf::lock_acquire "user_find:$login"; 1087 my $guard = cf::lock_acquire "user_find:$login";
1123 1088
1124 $cf::PLAYER{$login} ||= (load_pl path $login or return); 1089 $cf::PLAYER{$_[0]} || do {
1090 my $pl = load_pl path $login
1091 or return;
1092 $cf::PLAYER{$login} = $pl
1093 }
1125 }; 1094 }
1126} 1095}
1127 1096
1128sub save($) { 1097sub save($) {
1129 my ($pl) = @_; 1098 my ($pl) = @_;
1130 1099
… …
1133 my $path = path $pl; 1102 my $path = path $pl;
1134 my $guard = cf::lock_acquire "user_save:$path"; 1103 my $guard = cf::lock_acquire "user_save:$path";
1135 1104
1136 return if $pl->{deny_save}; 1105 return if $pl->{deny_save};
1137 1106
1138 Coro::AIO::aio_mkdir playerdir $pl, 0770; 1107 aio_mkdir playerdir $pl, 0770;
1139 $pl->{last_save} = $cf::RUNTIME; 1108 $pl->{last_save} = $cf::RUNTIME;
1140 1109
1141 $pl->save_pl ($path); 1110 $pl->save_pl ($path);
1142 Coro::cede; 1111 Coro::cede;
1143} 1112}
… …
1152 1121
1153 $cf::PLAYER{$login} = $self; 1122 $cf::PLAYER{$login} = $self;
1154 1123
1155 $self 1124 $self
1156} 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
1157 1133
1158sub quit_character { 1134sub quit_character {
1159 my ($pl) = @_; 1135 my ($pl) = @_;
1160 1136
1161 $pl->{deny_save} = 1; 1137 $pl->{deny_save} = 1;
… …
1166 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1142 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1167 $pl->ns->destroy if $pl->ns; 1143 $pl->ns->destroy if $pl->ns;
1168 1144
1169 my $path = playerdir $pl; 1145 my $path = playerdir $pl;
1170 my $temp = "$path~$cf::RUNTIME~deleting~"; 1146 my $temp = "$path~$cf::RUNTIME~deleting~";
1171 IO::AIO::aio_rename $path, $temp, sub { 1147 aio_rename $path, $temp;
1172 delete $cf::PLAYER{$pl->ob->name}; 1148 delete $cf::PLAYER{$pl->ob->name};
1173 $pl->destroy; 1149 $pl->destroy;
1174
1175 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;
1176 }; 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
1177} 1202}
1178 1203
1179=item $player->ext_reply ($msgid, $msgtype, %msg) 1204=item $player->ext_reply ($msgid, $msgtype, %msg)
1180 1205
1181Sends an ext reply to the player. 1206Sends an ext reply to the player.
… …
1364 Coro::cede; 1389 Coro::cede;
1365 1390
1366 $self->in_memory (cf::MAP_IN_MEMORY); 1391 $self->in_memory (cf::MAP_IN_MEMORY);
1367} 1392}
1368 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
1369sub find_sync { 1418sub find_sync {
1370 my ($path, $origin) = @_; 1419 my ($path, $origin) = @_;
1371 1420
1372 cf::sync_job { cf::map::find $path, $origin } 1421 cf::sync_job { find $path, $origin }
1373} 1422}
1374 1423
1375sub do_load_sync { 1424sub do_load_sync {
1376 my ($map) = @_; 1425 my ($map) = @_;
1377 1426
1378 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 ()
1379} 1460}
1380 1461
1381sub save { 1462sub save {
1382 my ($self) = @_; 1463 my ($self) = @_;
1383 1464
… …
1501 } 1582 }
1502 1583
1503 $map 1584 $map
1504} 1585}
1505 1586
1506sub emergency_save { 1587=item cf::map::unique_maps
1507 my $freeze_guard = cf::freeze_mainloop;
1508 1588
1509 warn "enter emergency perl save\n"; 1589Returns an arrayref of cf::path's of all shared maps that have
1590instantiated unique items. May block.
1510 1591
1511 cf::sync_job { 1592=cut
1512 warn "begin emergency player save\n";
1513 $_->save for values %cf::PLAYER;
1514 warn "end emergency player save\n";
1515 1593
1516 warn "begin emergency map save\n"; 1594sub unique_maps() {
1517 $_->save for values %cf::MAP; 1595 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1518 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 $_;
1519 }; 1606 }
1520 1607
1521 warn "leave emergency perl save\n"; 1608 \@paths
1522} 1609}
1523 1610
1524package cf; 1611package cf;
1525 1612
1526=back 1613=back
1527 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
1528 1641
1529=head3 cf::object::player 1642=head3 cf::object::player
1530 1643
1531=over 4 1644=over 4
1532 1645
… …
1624 # use -1 or undef as default coordinates, not 0, 0 1737 # use -1 or undef as default coordinates, not 0, 0
1625 ($x, $y) = ($map->enter_x, $map->enter_y) 1738 ($x, $y) = ($map->enter_x, $map->enter_y)
1626 if $x <=0 && $y <= 0; 1739 if $x <=0 && $y <= 0;
1627 1740
1628 $map->load; 1741 $map->load;
1742 $map->load_diag;
1629 1743
1630 return unless $self->contr->active; 1744 return unless $self->contr->active;
1631 $self->activate_recursive; 1745 $self->activate_recursive;
1632 $self->enter_map ($map, $x, $y); 1746 $self->enter_map ($map, $x, $y);
1633} 1747}
… …
1669=cut 1783=cut
1670 1784
1671sub cf::object::player::goto { 1785sub cf::object::player::goto {
1672 my ($self, $path, $x, $y) = @_; 1786 my ($self, $path, $x, $y) = @_;
1673 1787
1788 $path = new cf::path $path;
1789
1674 $self->enter_link; 1790 $self->enter_link;
1675 1791
1676 (async { 1792 (async {
1677 $path = new cf::path $path;
1678
1679 my $map = cf::map::find $path->as_string; 1793 my $map = cf::map::find $path->as_string;
1680 $map = $map->customise_for ($self) if $map; 1794 $map = $map->customise_for ($self) if $map;
1681 1795
1682# warn "entering ", $map->path, " at ($x, $y)\n" 1796# warn "entering ", $map->path, " at ($x, $y)\n"
1683# if $map; 1797# if $map;
1684 1798
1685 $map or $self->message ("The exit 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);
1686 1800
1687 $self->leave_link ($map, $x, $y); 1801 $self->leave_link ($map, $x, $y);
1688 })->prio (1); 1802 })->prio (1);
1689} 1803}
1690 1804
… …
1756 1870
1757 1; 1871 1;
1758 }) { 1872 }) {
1759 $self->message ("Something went wrong deep within the crossfire server. " 1873 $self->message ("Something went wrong deep within the crossfire server. "
1760 . "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. "
1761 . "Please report this to the dungeon master", 1875 . "Please report this to the dungeon master!",
1762 cf::NDI_UNIQUE | cf::NDI_RED); 1876 cf::NDI_UNIQUE | cf::NDI_RED);
1763 1877
1764 warn "ERROR in enter_exit: $@"; 1878 warn "ERROR in enter_exit: $@";
1765 $self->leave_link; 1879 $self->leave_link;
1766 } 1880 }
… …
2119 load_extensions; 2233 load_extensions;
2120 Event::loop; 2234 Event::loop;
2121} 2235}
2122 2236
2123############################################################################# 2237#############################################################################
2124# 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}
2125 2281
2126sub reload() { 2282sub reload() {
2127 # can/must only be called in main 2283 # can/must only be called in main
2128 if ($Coro::current != $Coro::main) { 2284 if ($Coro::current != $Coro::main) {
2129 warn "can only reload from main coroutine\n"; 2285 warn "can only reload from main coroutine\n";
2130 return; 2286 return;
2131 } 2287 }
2132 2288
2133 warn "reloading..."; 2289 warn "reloading...";
2134 2290
2291 warn "freezing server";
2135 my $guard = freeze_mainloop; 2292 my $guard = freeze_mainloop;
2136 cf::emergency_save; 2293 cf::emergency_save;
2137 2294
2295 warn "sync database to disk";
2296 cf::db_sync;
2297 IO::AIO::flush;
2298
2138 eval { 2299 eval {
2139 # 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
2140 2301
2141 # cancel all watchers 2302 warn "cancel all watchers";
2142 for (Event::all_watchers) { 2303 for (Event::all_watchers) {
2143 $_->cancel if $_->data & WF_AUTOCANCEL; 2304 $_->cancel if $_->data & WF_AUTOCANCEL;
2144 } 2305 }
2145 2306
2146 # cancel all extension coros 2307 warn "cancel all extension coros";
2147 $_->cancel for values %EXT_CORO; 2308 $_->cancel for values %EXT_CORO;
2148 %EXT_CORO = (); 2309 %EXT_CORO = ();
2149 2310
2311 warn "remove commands";
2312 %COMMAND = ();
2313
2314 warn "remove ext commands";
2315 %EXTCMD = ();
2316
2150 # unload all extensions 2317 warn "unload/nuke all extensions";
2151 for (@exts) { 2318 for my $pkg (@EXTS) {
2152 warn "unloading <$_>"; 2319 warn "unloading <$pkg>";
2153 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: $@";
2154 } 2326 }
2155 2327
2328 Symbol::delete_package $pkg;
2329 }
2330
2156 # unload all modules loaded from $LIBDIR 2331 warn "unload all perl modules loaded from $LIBDIR";
2157 while (my ($k, $v) = each %INC) { 2332 while (my ($k, $v) = each %INC) {
2158 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2333 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2159 2334
2160 warn "removing <$k>"; 2335 warn "removing <$k>";
2161 delete $INC{$k}; 2336 delete $INC{$k};
… …
2168 } 2343 }
2169 2344
2170 Symbol::delete_package $k; 2345 Symbol::delete_package $k;
2171 } 2346 }
2172 2347
2173 # sync database to disk
2174 cf::db_sync;
2175 IO::AIO::flush;
2176
2177 # get rid of safe::, as good as possible 2348 warn "get rid of safe::, as good as possible";
2178 Symbol::delete_package "safe::$_" 2349 Symbol::delete_package "safe::$_"
2179 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);
2180 2351
2181 # remove register_script_function callbacks
2182 # TODO
2183
2184 # unload cf.pm "a bit" 2352 warn "unload cf.pm \"a bit\"";
2185 delete $INC{"cf.pm"}; 2353 delete $INC{"cf.pm"};
2186 2354
2187 # don't, removes xs symbols, too, 2355 # don't, removes xs symbols, too,
2188 # and global variables created in xs 2356 # and global variables created in xs
2189 #Symbol::delete_package __PACKAGE__; 2357 #Symbol::delete_package __PACKAGE__;
2190 2358
2191 # reload cf.pm
2192 warn "reloading cf.pm"; 2359 warn "reloading cf.pm";
2193 require cf; 2360 require cf;
2194 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2361 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2195 2362
2196 # load config and database again 2363 warn "load config and database again";
2197 cf::cfg_load; 2364 cf::cfg_load;
2198 cf::db_load; 2365 cf::db_load;
2199 2366
2200 # load extensions
2201 warn "load extensions"; 2367 warn "load extensions";
2202 cf::load_extensions; 2368 cf::load_extensions;
2203 2369
2204 # reattach attachments to objects 2370 warn "reattach attachments to objects/players";
2205 warn "reattach";
2206 _global_reattach; 2371 _global_reattach;
2372 warn "reattach attachments to maps";
2207 reattach $_ for values %MAP; 2373 reattach $_ for values %MAP;
2208 }; 2374 };
2209 2375
2210 if ($@) { 2376 if ($@) {
2211 warn $@; 2377 warn $@;
2212 warn "error while reloading, exiting."; 2378 warn "error while reloading, exiting.";
2213 exit 1; 2379 exit 1;
2214 } 2380 }
2215 2381
2216 warn "reloaded successfully"; 2382 warn "reloaded";
2217}; 2383};
2218 2384
2219############################################################################# 2385#############################################################################
2220 2386
2221unless ($LINK_MAP) { 2387unless ($LINK_MAP) {
… …
2256 $LINK_MAP->{deny_save} = 1; 2422 $LINK_MAP->{deny_save} = 1;
2257 $LINK_MAP->{deny_reset} = 1; 2423 $LINK_MAP->{deny_reset} = 1;
2258 2424
2259 $cf::MAP{$LINK_MAP->path} = $LINK_MAP; 2425 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2260} 2426}
2261
2262register "<global>", __PACKAGE__;
2263 2427
2264register_command "reload" => sub { 2428register_command "reload" => sub {
2265 my ($who, $arg) = @_; 2429 my ($who, $arg) = @_;
2266 2430
2267 if ($who->flag (FLAG_WIZ)) { 2431 if ($who->flag (FLAG_WIZ)) {
… …
2280 data => WF_AUTOCANCEL, 2444 data => WF_AUTOCANCEL,
2281 cb => sub { 2445 cb => sub {
2282 cf::server_tick; # one server iteration 2446 cf::server_tick; # one server iteration
2283 $RUNTIME += $TICK; 2447 $RUNTIME += $TICK;
2284 $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;
2285 2452
2286 # 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
2287 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2454 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2288 2455
2289 $TICK_WATCHER->at ($NEXT_TICK); 2456 $TICK_WATCHER->at ($NEXT_TICK);

Diff Legend

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