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.149 by root, Mon Jan 8 14:11:05 2007 UTC vs.
Revision 1.161 by root, Thu Jan 11 00:16:58 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
42our %EXT_MAP = (); # pluggable maps
38 43
39our @EVENT; 44our @EVENT;
40our $LIBDIR = datadir . "/ext"; 45our $LIBDIR = datadir . "/ext";
41 46
42our $TICK = MAX_TIME * 1e-6; 47our $TICK = MAX_TIME * 1e-6;
… …
51 56
52our %PLAYER; # all users 57our %PLAYER; # all users
53our %MAP; # all maps 58our %MAP; # all maps
54our $LINK_MAP; # the special {link} map 59our $LINK_MAP; # the special {link} map
55our $RANDOM_MAPS = cf::localdir . "/random"; 60our $RANDOM_MAPS = cf::localdir . "/random";
56our %EXT_CORO; # coroutines bound to extensions 61
62our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
63our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
57 64
58binmode STDOUT; 65binmode STDOUT;
59binmode STDERR; 66binmode STDERR;
60 67
61# read virtual server time, if available 68# read virtual server time, if available
… …
105 112
106=item %cf::CFG 113=item %cf::CFG
107 114
108Configuration for the server, loaded from C</etc/crossfire/config>, or 115Configuration for the server, loaded from C</etc/crossfire/config>, or
109from wherever your confdir points to. 116from wherever your confdir points to.
117
118=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
119
120These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
121or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
122processing has been done. Call C<< ->wait >> on them to maximise the
123window of cpu time available, or simply to synchronise to the server tick.
110 124
111=back 125=back
112 126
113=cut 127=cut
114 128
… …
146 160
147$Event::DIED = sub { 161$Event::DIED = sub {
148 warn "error in event callback: @_"; 162 warn "error in event callback: @_";
149}; 163};
150 164
151my %ext_pkg;
152my @exts;
153my @hook;
154
155=head2 UTILITY FUNCTIONS 165=head2 UTILITY FUNCTIONS
156 166
157=over 4 167=over 4
158 168
169=item dumpval $ref
170
159=cut 171=cut
172
173sub dumpval {
174 eval {
175 local $SIG{__DIE__};
176 my $d;
177 if (1) {
178 $d = new Data::Dumper([$_[0]], ["*var"]);
179 $d->Terse(1);
180 $d->Indent(2);
181 $d->Quotekeys(0);
182 $d->Useqq(1);
183 #$d->Bless(...);
184 $d->Seen($_[1]) if @_ > 1;
185 $d = $d->Dump();
186 }
187 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
188 $d
189 } || "[unable to dump $_[0]: '$@']";
190}
160 191
161use JSON::Syck (); # TODO# replace by JSON::PC once working 192use JSON::Syck (); # TODO# replace by JSON::PC once working
162 193
163=item $ref = cf::from_json $json 194=item $ref = cf::from_json $json
164 195
… …
287 } 318 }
288} 319}
289 320
290=item $coro = cf::async_ext { BLOCK } 321=item $coro = cf::async_ext { BLOCK }
291 322
292Like async, but this coro is automcatially being canceled when the 323Like async, but this coro is automatically being canceled when the
293extension calling this is being unloaded. 324extension calling this is being unloaded.
294 325
295=cut 326=cut
296 327
297sub async_ext(&) { 328sub async_ext(&) {
… …
335 366
336############################################################################# 367#############################################################################
337 368
338package cf::path; 369package cf::path;
339 370
371use overload
372 '""' => \&as_string;
373
374# used to convert map paths into valid unix filenames by repalcing / by ∕
375our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
376
377sub register {
378 my ($pkg, $prefix) = @_;
379
380 $EXT_MAP{$prefix} = $pkg;
381}
382
340sub new { 383sub new {
341 my ($class, $path, $base) = @_; 384 my ($class, $path, $base) = @_;
342 385
343 $path = $path->as_string if ref $path; 386 return $path if ref $path;
344 387
345 my $self = bless { }, $class; 388 my $self = {};
346 389
347 # {... are special paths that are not touched 390 # {... are special paths that are not being touched
348 # ?xxx/... are special absolute paths 391 # ?xxx/... are special absolute paths
349 # ?random/... random maps 392 # ?random/... random maps
350 # /! non-realised random map exit 393 # /! non-realised random map exit
351 # /... normal maps 394 # /... normal maps
352 # ~/... per-player maps without a specific player (DO NOT USE) 395 # ~/... per-player maps without a specific player (DO NOT USE)
353 # ~user/... per-player map of a specific user 396 # ~user/... per-player map of a specific user
354 397
398 $path =~ s/$PATH_SEP/\//go;
399
355 if ($path =~ /^{/) { 400 if ($path =~ /^{/) {
356 # fine as it is 401 # fine as it is
357 } elsif ($path =~ s{^\?random/}{}) {
358 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
359 $self->{random} = cf::from_json $data;
360 } else { 402 } else {
361 if ($path =~ s{^~([^/]+)?}{}) { 403 if ($path =~ s{^~([^/]+)?}{}) {
404 # ~user
362 $self->{user_rel} = 1; 405 $self->{user_rel} = 1;
363 406
364 if (defined $1) { 407 if (defined $1) {
365 $self->{user} = $1; 408 $self->{user} = $1;
366 } elsif ($base =~ m{^~([^/]+)/}) { 409 } elsif ($base =~ m{^~([^/]+)/}) {
367 $self->{user} = $1; 410 $self->{user} = $1;
368 } else { 411 } else {
369 warn "cannot resolve user-relative path without user <$path,$base>\n"; 412 warn "cannot resolve user-relative path without user <$path,$base>\n";
370 } 413 }
414 } elsif ($path =~ s{^\?([^/]+)/}{}) {
415 # ?...
416 $self->{ext} = $1;
417 if (my $ext = $EXT_MAP{$1}) {
418 bless $self, $ext;
419 }
371 } elsif ($path =~ /^\//) { 420 } elsif ($path =~ /^\//) {
421 # /...
372 # already absolute 422 # already absolute
373 } else { 423 } else {
424 # relative
374 $base =~ s{[^/]+/?$}{}; 425 $base =~ s{[^/]+/?$}{};
375 return $class->new ("$base/$path"); 426 return $class->new ("$base/$path");
376 } 427 }
377 428
378 for ($path) { 429 for ($path) {
… …
381 } 432 }
382 } 433 }
383 434
384 $self->{path} = $path; 435 $self->{path} = $path;
385 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
386 $self 449 $self
450}
451
452sub init {
453 # nop
454}
455
456sub substitute {
457 ()
387} 458}
388 459
389# the name / primary key / in-game path 460# the name / primary key / in-game path
390sub as_string { 461sub as_string {
391 my ($self) = @_; 462 my ($self) = @_;
392 463
393 $self->{user_rel} ? "~$self->{user}$self->{path}" 464 $self->{user_rel} ? "~$self->{user}$self->{path}"
394 : $self->{random} ? "?random/$self->{path}" 465 : $self->{ext} ? "?$self->{ext}/$self->{path}"
395 : $self->{path} 466 : $self->{path}
396} 467}
397 468
398# the displayed name, this is a one way mapping 469# the displayed name, this is a one way mapping
399sub visible_name { 470sub visible_name {
400 my ($self) = @_; 471 &as_string
401
402# if (my $rmp = $self->{random}) {
403# # todo: be more intelligent about this
404# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
405# } else {
406 $self->as_string
407# }
408} 472}
409 473
410# escape the /'s in the path 474# escape the /'s in the path
411sub _escaped_path { 475sub _escaped_path {
412 # ∕ is U+2215
413 (my $path = $_[0]{path}) =~ s/\//∕/g; 476 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
414 $path 477 $path
415} 478}
416 479
417# the original (read-only) location 480# the original (read-only) location
418sub load_path { 481sub load_path {
… …
428 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path 491 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
429 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path} 492 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
430 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path 493 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
431} 494}
432 495
433# the unique path, might be eq to save_path 496# the unique path, undef == no special unique path
434sub uniq_path { 497sub uniq_path {
435 my ($self) = @_; 498 my ($self) = @_;
436 499
437 $self->{user_rel} || $self->{random}
438 ? undef
439 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path 500 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
440}
441
442# return random map parameters, or undef
443sub random_map_params {
444 my ($self) = @_;
445
446 $self->{random}
447} 501}
448 502
449# this is somewhat ugly, but style maps do need special treatment 503# this is somewhat ugly, but style maps do need special treatment
450sub is_style_map { 504sub is_style_map {
451 $_[0]{path} =~ m{^/styles/} 505 $_[0]{path} =~ m{^/styles/}
506}
507
508sub load_orig {
509 my ($self) = @_;
510
511 &cf::map::load_map_header ($self->load_path)
512}
513
514sub load_temp {
515 my ($self) = @_;
516
517 &cf::map::load_map_header ($self->save_path)
452} 518}
453 519
454package cf; 520package cf;
455 521
456############################################################################# 522#############################################################################
… …
906=cut 972=cut
907 973
908sub register_extcmd { 974sub register_extcmd {
909 my ($name, $cb) = @_; 975 my ($name, $cb) = @_;
910 976
911 my $caller = caller;
912 #warn "registering extcmd '$name' to '$caller'";
913
914 $EXTCMD{$name} = [$cb, $caller]; 977 $EXTCMD{$name} = $cb;
915} 978}
916 979
917cf::player->attach ( 980cf::player->attach (
918 on_command => sub { 981 on_command => sub {
919 my ($pl, $name, $params) = @_; 982 my ($pl, $name, $params) = @_;
… …
932 995
933 my $msg = eval { from_json $buf }; 996 my $msg = eval { from_json $buf };
934 997
935 if (ref $msg) { 998 if (ref $msg) {
936 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 999 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
937 if (my %reply = $cb->[0]->($pl, $msg)) { 1000 if (my %reply = $cb->($pl, $msg)) {
938 $pl->ext_reply ($msg->{msgid}, %reply); 1001 $pl->ext_reply ($msg->{msgid}, %reply);
939 } 1002 }
940 } 1003 }
941 } else { 1004 } else {
942 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1005 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
944 1007
945 cf::override; 1008 cf::override;
946 }, 1009 },
947); 1010);
948 1011
949sub register {
950 my ($base, $pkg) = @_;
951
952 #TODO
953}
954
955sub load_extension { 1012sub load_extension {
956 my ($path) = @_; 1013 my ($path) = @_;
957 1014
958 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1015 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
959 my $base = $1; 1016 my $base = $1;
960 my $pkg = $1; 1017 my $pkg = $1;
961 $pkg =~ s/[^[:word:]]/_/g; 1018 $pkg =~ s/[^[:word:]]/_/g;
962 $pkg = "ext::$pkg"; 1019 $pkg = "ext::$pkg";
963 1020
964 warn "loading '$path' into '$pkg'\n"; 1021 warn "... loading '$path' into '$pkg'\n";
965 1022
966 open my $fh, "<:utf8", $path 1023 open my $fh, "<:utf8", $path
967 or die "$path: $!"; 1024 or die "$path: $!";
968 1025
969 my $source = 1026 my $source =
… …
974 1031
975 eval $source 1032 eval $source
976 or die $@ ? "$path: $@\n" 1033 or die $@ ? "$path: $@\n"
977 : "extension disabled.\n"; 1034 : "extension disabled.\n";
978 1035
979 push @exts, $pkg; 1036 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} 1037}
1024 1038
1025sub load_extensions { 1039sub load_extensions {
1026 for my $ext (<$LIBDIR/*.ext>) { 1040 for my $ext (<$LIBDIR/*.ext>) {
1027 next unless -r $ext; 1041 next unless -r $ext;
… …
1045}; 1059};
1046 1060
1047cf::map->attach (prio => -10000, package => cf::mapsupport::); 1061cf::map->attach (prio => -10000, package => cf::mapsupport::);
1048 1062
1049############################################################################# 1063#############################################################################
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 1064
1073=head2 CORE EXTENSIONS 1065=head2 CORE EXTENSIONS
1074 1066
1075Functions and methods that extend core crossfire objects. 1067Functions and methods that extend core crossfire objects.
1076 1068
1077=cut 1069=cut
1078 1070
1079package cf::player; 1071package cf::player;
1072
1073use Coro::AIO;
1080 1074
1081=head3 cf::player 1075=head3 cf::player
1082 1076
1083=over 4 1077=over 4
1084 1078
… …
1119 return $cf::PLAYER{$_[0]} || do { 1113 return $cf::PLAYER{$_[0]} || do {
1120 my $login = $_[0]; 1114 my $login = $_[0];
1121 1115
1122 my $guard = cf::lock_acquire "user_find:$login"; 1116 my $guard = cf::lock_acquire "user_find:$login";
1123 1117
1124 $cf::PLAYER{$login} ||= (load_pl path $login or return); 1118 $cf::PLAYER{$_[0]} || do {
1119 my $pl = load_pl path $login
1120 or return;
1121 $cf::PLAYER{$login} = $pl
1122 }
1125 }; 1123 }
1126} 1124}
1127 1125
1128sub save($) { 1126sub save($) {
1129 my ($pl) = @_; 1127 my ($pl) = @_;
1130 1128
… …
1133 my $path = path $pl; 1131 my $path = path $pl;
1134 my $guard = cf::lock_acquire "user_save:$path"; 1132 my $guard = cf::lock_acquire "user_save:$path";
1135 1133
1136 return if $pl->{deny_save}; 1134 return if $pl->{deny_save};
1137 1135
1138 Coro::AIO::aio_mkdir playerdir $pl, 0770; 1136 aio_mkdir playerdir $pl, 0770;
1139 $pl->{last_save} = $cf::RUNTIME; 1137 $pl->{last_save} = $cf::RUNTIME;
1140 1138
1141 $pl->save_pl ($path); 1139 $pl->save_pl ($path);
1142 Coro::cede; 1140 Coro::cede;
1143} 1141}
… …
1152 1150
1153 $cf::PLAYER{$login} = $self; 1151 $cf::PLAYER{$login} = $self;
1154 1152
1155 $self 1153 $self
1156} 1154}
1155
1156=item $pl->quit_character
1157
1158Nukes the player without looking back. If logged in, the connection will
1159be destroyed. May block for a long time.
1160
1161=cut
1157 1162
1158sub quit_character { 1163sub quit_character {
1159 my ($pl) = @_; 1164 my ($pl) = @_;
1160 1165
1161 $pl->{deny_save} = 1; 1166 $pl->{deny_save} = 1;
… …
1166 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1171 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1167 $pl->ns->destroy if $pl->ns; 1172 $pl->ns->destroy if $pl->ns;
1168 1173
1169 my $path = playerdir $pl; 1174 my $path = playerdir $pl;
1170 my $temp = "$path~$cf::RUNTIME~deleting~"; 1175 my $temp = "$path~$cf::RUNTIME~deleting~";
1171 IO::AIO::aio_rename $path, $temp, sub { 1176 aio_rename $path, $temp;
1172 delete $cf::PLAYER{$pl->ob->name}; 1177 delete $cf::PLAYER{$pl->ob->name};
1173 $pl->destroy; 1178 $pl->destroy;
1174
1175 IO::AIO::aio_rmtree $temp; 1179 IO::AIO::aio_rmtree $temp;
1180}
1181
1182=item cf::player::list_logins
1183
1184Returns am arrayref of all valid playernames in the system, can take a
1185while and may block, so not sync_job-capable, ever.
1186
1187=cut
1188
1189sub list_logins {
1190 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1191 or return [];
1192
1193 my @logins;
1194
1195 for my $login (@$dirs) {
1196 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1197 aio_read $fh, 0, 512, my $buf, 0 or next;
1198 $buf !~ /^password -------------$/m or next; # official not-valid tag
1199
1200 utf8::decode $login;
1201 push @logins, $login;
1176 }; 1202 }
1203
1204 \@logins
1205}
1206
1207=item $player->maps
1208
1209Returns an arrayref of cf::path's of all maps that are private for this
1210player. May block.
1211
1212=cut
1213
1214sub maps($) {
1215 my ($pl) = @_;
1216
1217 my $files = aio_readdir playerdir $pl
1218 or return;
1219
1220 my @paths;
1221
1222 for (@$files) {
1223 utf8::decode $_;
1224 next if /\.(?:pl|pst)$/;
1225 next unless /^$PATH_SEP/o;
1226
1227 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
1228 }
1229
1230 \@paths
1177} 1231}
1178 1232
1179=item $player->ext_reply ($msgid, $msgtype, %msg) 1233=item $player->ext_reply ($msgid, $msgtype, %msg)
1180 1234
1181Sends an ext reply to the player. 1235Sends an ext reply to the player.
… …
1235 1289
1236 $_->change_map_light ($change) 1290 $_->change_map_light ($change)
1237 for grep $_->outdoor, values %cf::MAP; 1291 for grep $_->outdoor, values %cf::MAP;
1238} 1292}
1239 1293
1240sub try_load_header($) { 1294sub load_map_header($) {
1241 my ($path) = @_; 1295 my ($path) = @_;
1242 1296
1243 utf8::encode $path; 1297 utf8::encode $path;
1244 aio_open $path, O_RDONLY, 0 1298 aio_open $path, O_RDONLY, 0
1245 or return; 1299 or return;
1246 1300
1247 my $map = cf::map::new 1301 my $map = cf::map::new
1248 or return; 1302 or return;
1249 1303
1250 # for better error messages only, will be overwritten 1304 # for better error messages only, will be overwritten later
1251 $map->path ($path); 1305 $map->path ($path);
1252 1306
1253 $map->load_header ($path) 1307 $map->load_header ($path)
1254 or return; 1308 or return;
1255 1309
… …
1271 1325
1272 $cf::MAP{$key} || do { 1326 $cf::MAP{$key} || do {
1273 my $guard = cf::lock_acquire "map_find:$key"; 1327 my $guard = cf::lock_acquire "map_find:$key";
1274 1328
1275 # do it the slow way 1329 # do it the slow way
1276 my $map = try_load_header $path->save_path; 1330 my $map = $path->load_temp;
1277 1331
1278 Coro::cede; 1332 Coro::cede;
1279 1333
1280 if ($map) { 1334 if ($map) {
1281 $map->last_access ((delete $map->{last_access}) 1335 $map->last_access ((delete $map->{last_access})
1282 || $cf::RUNTIME); #d# 1336 || $cf::RUNTIME); #d#
1283 # safety 1337 # safety
1284 $map->{instantiate_time} = $cf::RUNTIME 1338 $map->{instantiate_time} = $cf::RUNTIME
1285 if $map->{instantiate_time} > $cf::RUNTIME; 1339 if $map->{instantiate_time} > $cf::RUNTIME;
1286 } else { 1340 } else {
1287 if (my $rmp = $path->random_map_params) { 1341 $map = $path->load_orig
1288 $map = generate_random_map $key, $rmp;
1289 } else {
1290 $map = try_load_header $path->load_path;
1291 }
1292
1293 $map or return; 1342 or return;
1294 1343
1295 $map->{load_original} = 1; 1344 $map->{load_original} = 1;
1296 $map->{instantiate_time} = $cf::RUNTIME; 1345 $map->{instantiate_time} = $cf::RUNTIME;
1297 $map->last_access ($cf::RUNTIME); 1346 $map->last_access ($cf::RUNTIME);
1298 $map->instantiate; 1347 $map->instantiate;
… …
1364 Coro::cede; 1413 Coro::cede;
1365 1414
1366 $self->in_memory (cf::MAP_IN_MEMORY); 1415 $self->in_memory (cf::MAP_IN_MEMORY);
1367} 1416}
1368 1417
1418# find and load all maps in the 3x3 area around a map
1419sub load_diag {
1420 my ($map) = @_;
1421
1422 my @diag; # diagonal neighbours
1423
1424 for (0 .. 3) {
1425 my $neigh = $map->tile_path ($_)
1426 or next;
1427 $neigh = find $neigh, $map
1428 or next;
1429 $neigh->load;
1430
1431 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1432 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1433 }
1434
1435 for (@diag) {
1436 my $neigh = find @$_
1437 or next;
1438 $neigh->load;
1439 }
1440}
1441
1369sub find_sync { 1442sub find_sync {
1370 my ($path, $origin) = @_; 1443 my ($path, $origin) = @_;
1371 1444
1372 cf::sync_job { cf::map::find $path, $origin } 1445 cf::sync_job { find $path, $origin }
1373} 1446}
1374 1447
1375sub do_load_sync { 1448sub do_load_sync {
1376 my ($map) = @_; 1449 my ($map) = @_;
1377 1450
1378 cf::sync_job { $map->load }; 1451 cf::sync_job { $map->load };
1452}
1453
1454our %MAP_PREFETCH;
1455our $MAP_PREFETCHER = Coro::async {
1456 while () {
1457 while (%MAP_PREFETCH) {
1458 my $key = each %MAP_PREFETCH
1459 or next;
1460 my $path = delete $MAP_PREFETCH{$key};
1461
1462 my $map = find $path
1463 or next;
1464 $map->load;
1465 }
1466 Coro::schedule;
1467 }
1468};
1469
1470sub find_async {
1471 my ($path, $origin) = @_;
1472
1473 $path = new cf::path $path, $origin && $origin->path;
1474 my $key = $path->as_string;
1475
1476 if (my $map = $cf::MAP{$key}) {
1477 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1478 }
1479
1480 $MAP_PREFETCH{$key} = $path;
1481 $MAP_PREFETCHER->ready;
1482
1483 ()
1379} 1484}
1380 1485
1381sub save { 1486sub save {
1382 my ($self) = @_; 1487 my ($self) = @_;
1383 1488
… …
1501 } 1606 }
1502 1607
1503 $map 1608 $map
1504} 1609}
1505 1610
1506sub emergency_save { 1611=item cf::map::unique_maps
1507 my $freeze_guard = cf::freeze_mainloop;
1508 1612
1509 warn "enter emergency perl save\n"; 1613Returns an arrayref of cf::path's of all shared maps that have
1614instantiated unique items. May block.
1510 1615
1511 cf::sync_job { 1616=cut
1512 warn "begin emergency player save\n";
1513 $_->save for values %cf::PLAYER;
1514 warn "end emergency player save\n";
1515 1617
1516 warn "begin emergency map save\n"; 1618sub unique_maps() {
1517 $_->save for values %cf::MAP; 1619 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1518 warn "end emergency map save\n"; 1620 or return;
1621
1622 my @paths;
1623
1624 for (@$files) {
1625 utf8::decode $_;
1626 next if /\.pst$/;
1627 next unless /^$PATH_SEP/o;
1628
1629 push @paths, new cf::path $_;
1519 }; 1630 }
1520 1631
1521 warn "leave emergency perl save\n"; 1632 \@paths
1522} 1633}
1523 1634
1524package cf; 1635package cf;
1525 1636
1526=back 1637=back
1527 1638
1639=head3 cf::object
1640
1641=cut
1642
1643package cf::object;
1644
1645=over 4
1646
1647=item $ob->inv_recursive
1648
1649Returns the inventory of the object _and_ their inventories, recursively.
1650
1651=cut
1652
1653sub inv_recursive_;
1654sub inv_recursive_ {
1655 map { $_, inv_recursive_ $_->inv } @_
1656}
1657
1658sub inv_recursive {
1659 inv_recursive_ inv $_[0]
1660}
1661
1662package cf;
1663
1664=back
1528 1665
1529=head3 cf::object::player 1666=head3 cf::object::player
1530 1667
1531=over 4 1668=over 4
1532 1669
… …
1624 # use -1 or undef as default coordinates, not 0, 0 1761 # use -1 or undef as default coordinates, not 0, 0
1625 ($x, $y) = ($map->enter_x, $map->enter_y) 1762 ($x, $y) = ($map->enter_x, $map->enter_y)
1626 if $x <=0 && $y <= 0; 1763 if $x <=0 && $y <= 0;
1627 1764
1628 $map->load; 1765 $map->load;
1766 $map->load_diag;
1629 1767
1630 return unless $self->contr->active; 1768 return unless $self->contr->active;
1631 $self->activate_recursive; 1769 $self->activate_recursive;
1632 $self->enter_map ($map, $x, $y); 1770 $self->enter_map ($map, $x, $y);
1633} 1771}
… …
1669=cut 1807=cut
1670 1808
1671sub cf::object::player::goto { 1809sub cf::object::player::goto {
1672 my ($self, $path, $x, $y) = @_; 1810 my ($self, $path, $x, $y) = @_;
1673 1811
1812 $path = new cf::path $path;
1813
1674 $self->enter_link; 1814 $self->enter_link;
1675 1815
1676 (async { 1816 (async {
1677 $path = new cf::path $path;
1678
1679 my $map = cf::map::find $path->as_string; 1817 my $map = cf::map::find $path->as_string;
1680 $map = $map->customise_for ($self) if $map; 1818 $map = $map->customise_for ($self) if $map;
1681 1819
1682# warn "entering ", $map->path, " at ($x, $y)\n" 1820# warn "entering ", $map->path, " at ($x, $y)\n"
1683# if $map; 1821# if $map;
1684 1822
1685 $map or $map->cluck ("oy");#d#
1686 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1823 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1687 1824
1688 $self->leave_link ($map, $x, $y); 1825 $self->leave_link ($map, $x, $y);
1689 })->prio (1); 1826 })->prio (1);
1690} 1827}
… …
1757 1894
1758 1; 1895 1;
1759 }) { 1896 }) {
1760 $self->message ("Something went wrong deep within the crossfire server. " 1897 $self->message ("Something went wrong deep within the crossfire server. "
1761 . "I'll try to bring you back to the map you were before. " 1898 . "I'll try to bring you back to the map you were before. "
1762 . "Please report this to the dungeon master", 1899 . "Please report this to the dungeon master!",
1763 cf::NDI_UNIQUE | cf::NDI_RED); 1900 cf::NDI_UNIQUE | cf::NDI_RED);
1764 1901
1765 warn "ERROR in enter_exit: $@"; 1902 warn "ERROR in enter_exit: $@";
1766 $self->leave_link; 1903 $self->leave_link;
1767 } 1904 }
… …
2120 load_extensions; 2257 load_extensions;
2121 Event::loop; 2258 Event::loop;
2122} 2259}
2123 2260
2124############################################################################# 2261#############################################################################
2125# initialisation 2262# initialisation and cleanup
2263
2264# install some emergency cleanup handlers
2265BEGIN {
2266 for my $signal (qw(INT HUP TERM)) {
2267 Event->signal (
2268 data => WF_AUTOCANCEL,
2269 signal => $signal,
2270 cb => sub {
2271 cf::cleanup "SIG$signal";
2272 },
2273 );
2274 }
2275}
2276
2277sub emergency_save() {
2278 my $freeze_guard = cf::freeze_mainloop;
2279
2280 warn "enter emergency perl save\n";
2281
2282 cf::sync_job {
2283 # use a peculiar iteration method to avoid tripping on perl
2284 # refcount bugs in for. also avoids problems with players
2285 # and maps saved/Destroyed asynchronously.
2286 warn "begin emergency player save\n";
2287 for my $login (keys %cf::PLAYER) {
2288 my $pl = $cf::PLAYER{$login} or next;
2289 $pl->valid or next;
2290 $pl->save;
2291 }
2292 warn "end emergency player save\n";
2293
2294 warn "begin emergency map save\n";
2295 for my $path (keys %cf::MAP) {
2296 my $map = $cf::MAP{$path} or next;
2297 $map->valid or next;
2298 $map->save;
2299 }
2300 warn "end emergency map save\n";
2301 };
2302
2303 warn "leave emergency perl save\n";
2304}
2126 2305
2127sub reload() { 2306sub reload() {
2128 # can/must only be called in main 2307 # can/must only be called in main
2129 if ($Coro::current != $Coro::main) { 2308 if ($Coro::current != $Coro::main) {
2130 warn "can only reload from main coroutine\n"; 2309 warn "can only reload from main coroutine\n";
2131 return; 2310 return;
2132 } 2311 }
2133 2312
2134 warn "reloading..."; 2313 warn "reloading...";
2135 2314
2315 warn "freezing server";
2136 my $guard = freeze_mainloop; 2316 my $guard = freeze_mainloop;
2137 cf::emergency_save; 2317 cf::emergency_save;
2138 2318
2319 warn "sync database to disk";
2320 cf::db_sync;
2321 IO::AIO::flush;
2322
2139 eval { 2323 eval {
2140 # if anything goes wrong in here, we should simply crash as we already saved 2324 # if anything goes wrong in here, we should simply crash as we already saved
2141 2325
2142 # cancel all watchers 2326 warn "cancel all watchers";
2143 for (Event::all_watchers) { 2327 for (Event::all_watchers) {
2144 $_->cancel if $_->data & WF_AUTOCANCEL; 2328 $_->cancel if $_->data & WF_AUTOCANCEL;
2145 } 2329 }
2146 2330
2147 # cancel all extension coros 2331 warn "cancel all extension coros";
2148 $_->cancel for values %EXT_CORO; 2332 $_->cancel for values %EXT_CORO;
2149 %EXT_CORO = (); 2333 %EXT_CORO = ();
2150 2334
2335 warn "remove commands";
2336 %COMMAND = ();
2337
2338 warn "remove ext commands";
2339 %EXTCMD = ();
2340
2151 # unload all extensions 2341 warn "unload/nuke all extensions";
2152 for (@exts) { 2342 for my $pkg (@EXTS) {
2153 warn "unloading <$_>"; 2343 warn "... unloading $pkg";
2154 unload_extension $_; 2344
2345 if (my $cb = $pkg->can ("unload")) {
2346 eval {
2347 $cb->($pkg);
2348 1
2349 } or warn "$pkg unloaded, but with errors: $@";
2155 } 2350 }
2156 2351
2352 warn "... nuking $pkg";
2353 Symbol::delete_package $pkg;
2354 }
2355
2157 # unload all modules loaded from $LIBDIR 2356 warn "unload all perl modules loaded from $LIBDIR";
2158 while (my ($k, $v) = each %INC) { 2357 while (my ($k, $v) = each %INC) {
2159 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2358 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2160 2359
2161 warn "removing <$k>"; 2360 warn "removing <$k>";
2162 delete $INC{$k}; 2361 delete $INC{$k};
… …
2169 } 2368 }
2170 2369
2171 Symbol::delete_package $k; 2370 Symbol::delete_package $k;
2172 } 2371 }
2173 2372
2174 # sync database to disk
2175 cf::db_sync;
2176 IO::AIO::flush;
2177
2178 # get rid of safe::, as good as possible 2373 warn "get rid of safe::, as good as possible";
2179 Symbol::delete_package "safe::$_" 2374 Symbol::delete_package "safe::$_"
2180 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2375 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2181 2376
2182 # remove register_script_function callbacks
2183 # TODO
2184
2185 # unload cf.pm "a bit" 2377 warn "unload cf.pm \"a bit\"";
2186 delete $INC{"cf.pm"}; 2378 delete $INC{"cf.pm"};
2187 2379
2188 # don't, removes xs symbols, too, 2380 # don't, removes xs symbols, too,
2189 # and global variables created in xs 2381 # and global variables created in xs
2190 #Symbol::delete_package __PACKAGE__; 2382 #Symbol::delete_package __PACKAGE__;
2191 2383
2192 # reload cf.pm
2193 warn "reloading cf.pm"; 2384 warn "reloading cf.pm";
2194 require cf; 2385 require cf;
2195 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2386 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2196 2387
2197 # load config and database again 2388 warn "load config and database again";
2198 cf::cfg_load; 2389 cf::cfg_load;
2199 cf::db_load; 2390 cf::db_load;
2200 2391
2201 # load extensions
2202 warn "load extensions"; 2392 warn "load extensions";
2203 cf::load_extensions; 2393 cf::load_extensions;
2204 2394
2205 # reattach attachments to objects 2395 warn "reattach attachments to objects/players";
2206 warn "reattach";
2207 _global_reattach; 2396 _global_reattach;
2397 warn "reattach attachments to maps";
2208 reattach $_ for values %MAP; 2398 reattach $_ for values %MAP;
2209 }; 2399 };
2210 2400
2211 if ($@) { 2401 if ($@) {
2212 warn $@; 2402 warn $@;
2213 warn "error while reloading, exiting."; 2403 warn "error while reloading, exiting.";
2214 exit 1; 2404 exit 1;
2215 } 2405 }
2216 2406
2217 warn "reloaded successfully"; 2407 warn "reloaded";
2218}; 2408};
2219 2409
2220############################################################################# 2410#############################################################################
2221 2411
2222unless ($LINK_MAP) { 2412unless ($LINK_MAP) {
… …
2257 $LINK_MAP->{deny_save} = 1; 2447 $LINK_MAP->{deny_save} = 1;
2258 $LINK_MAP->{deny_reset} = 1; 2448 $LINK_MAP->{deny_reset} = 1;
2259 2449
2260 $cf::MAP{$LINK_MAP->path} = $LINK_MAP; 2450 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2261} 2451}
2262
2263register "<global>", __PACKAGE__;
2264 2452
2265register_command "reload" => sub { 2453register_command "reload" => sub {
2266 my ($who, $arg) = @_; 2454 my ($who, $arg) = @_;
2267 2455
2268 if ($who->flag (FLAG_WIZ)) { 2456 if ($who->flag (FLAG_WIZ)) {
… …
2281 data => WF_AUTOCANCEL, 2469 data => WF_AUTOCANCEL,
2282 cb => sub { 2470 cb => sub {
2283 cf::server_tick; # one server iteration 2471 cf::server_tick; # one server iteration
2284 $RUNTIME += $TICK; 2472 $RUNTIME += $TICK;
2285 $NEXT_TICK += $TICK; 2473 $NEXT_TICK += $TICK;
2474
2475 $WAIT_FOR_TICK->broadcast;
2476 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2286 2477
2287 # if we are delayed by four ticks or more, skip them all 2478 # if we are delayed by four ticks or more, skip them all
2288 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2479 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2289 2480
2290 $TICK_WATCHER->at ($NEXT_TICK); 2481 $TICK_WATCHER->at ($NEXT_TICK);

Diff Legend

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