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

Diff Legend

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