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.165 by root, Fri Jan 12 22:09:22 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;
477
414 $path 478 $path
415} 479}
416 480
417# the original (read-only) location 481# the original (read-only) location
418sub load_path { 482sub load_path {
… …
423 487
424# the temporary/swap location 488# the temporary/swap location
425sub save_path { 489sub save_path {
426 my ($self) = @_; 490 my ($self) = @_;
427 491
492 $self->{user_rel}
428 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path 493 ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
429 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
430 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path 494 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
431} 495}
432 496
433# the unique path, might be eq to save_path 497# the unique path, undef == no special unique path
434sub uniq_path { 498sub uniq_path {
435 my ($self) = @_; 499 my ($self) = @_;
436 500
437 $self->{user_rel} || $self->{random} 501 $self->{user_rel} || $self->{ext}
438 ? undef 502 ? undef
439 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path 503 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
440} 504}
441 505
442# return random map parameters, or undef 506sub customise_for {
443sub random_map_params {
444 my ($self) = @_; 507 my ($self, $map, $ob) = @_;
445 508
446 $self->{random} 509 if ($map->per_player) {
510 return cf::map::find ("~" . $ob->name . "/" . $map->{path}{path});
511 }
512
513 $map
447} 514}
448 515
449# this is somewhat ugly, but style maps do need special treatment 516# this is somewhat ugly, but style maps do need special treatment
450sub is_style_map { 517sub is_style_map {
451 $_[0]{path} =~ m{^/styles/} 518 $_[0]{path} =~ m{^/styles/}
519}
520
521sub load_orig {
522 my ($self) = @_;
523
524 &cf::map::load_map_header ($self->load_path)
525}
526
527sub load_temp {
528 my ($self) = @_;
529
530 &cf::map::load_map_header ($self->save_path)
531}
532
533sub unlink_save {
534 my ($self) = @_;
535
536 utf8::encode (my $save = $self->save_path);
537 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save;
538 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst";
452} 539}
453 540
454package cf; 541package cf;
455 542
456############################################################################# 543#############################################################################
… …
906=cut 993=cut
907 994
908sub register_extcmd { 995sub register_extcmd {
909 my ($name, $cb) = @_; 996 my ($name, $cb) = @_;
910 997
911 my $caller = caller;
912 #warn "registering extcmd '$name' to '$caller'";
913
914 $EXTCMD{$name} = [$cb, $caller]; 998 $EXTCMD{$name} = $cb;
915} 999}
916 1000
917cf::player->attach ( 1001cf::player->attach (
918 on_command => sub { 1002 on_command => sub {
919 my ($pl, $name, $params) = @_; 1003 my ($pl, $name, $params) = @_;
… …
932 1016
933 my $msg = eval { from_json $buf }; 1017 my $msg = eval { from_json $buf };
934 1018
935 if (ref $msg) { 1019 if (ref $msg) {
936 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1020 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
937 if (my %reply = $cb->[0]->($pl, $msg)) { 1021 if (my %reply = $cb->($pl, $msg)) {
938 $pl->ext_reply ($msg->{msgid}, %reply); 1022 $pl->ext_reply ($msg->{msgid}, %reply);
939 } 1023 }
940 } 1024 }
941 } else { 1025 } else {
942 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1026 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
944 1028
945 cf::override; 1029 cf::override;
946 }, 1030 },
947); 1031);
948 1032
949sub register {
950 my ($base, $pkg) = @_;
951
952 #TODO
953}
954
955sub load_extension { 1033sub load_extension {
956 my ($path) = @_; 1034 my ($path) = @_;
957 1035
958 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1036 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
959 my $base = $1; 1037 my $base = $1;
960 my $pkg = $1; 1038 my $pkg = $1;
961 $pkg =~ s/[^[:word:]]/_/g; 1039 $pkg =~ s/[^[:word:]]/_/g;
962 $pkg = "ext::$pkg"; 1040 $pkg = "ext::$pkg";
963 1041
964 warn "loading '$path' into '$pkg'\n"; 1042 warn "... loading '$path' into '$pkg'\n";
965 1043
966 open my $fh, "<:utf8", $path 1044 open my $fh, "<:utf8", $path
967 or die "$path: $!"; 1045 or die "$path: $!";
968 1046
969 my $source = 1047 my $source =
… …
974 1052
975 eval $source 1053 eval $source
976 or die $@ ? "$path: $@\n" 1054 or die $@ ? "$path: $@\n"
977 : "extension disabled.\n"; 1055 : "extension disabled.\n";
978 1056
979 push @exts, $pkg; 1057 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} 1058}
1024 1059
1025sub load_extensions { 1060sub load_extensions {
1026 for my $ext (<$LIBDIR/*.ext>) { 1061 for my $ext (<$LIBDIR/*.ext>) {
1027 next unless -r $ext; 1062 next unless -r $ext;
… …
1045}; 1080};
1046 1081
1047cf::map->attach (prio => -10000, package => cf::mapsupport::); 1082cf::map->attach (prio => -10000, package => cf::mapsupport::);
1048 1083
1049############################################################################# 1084#############################################################################
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 1085
1073=head2 CORE EXTENSIONS 1086=head2 CORE EXTENSIONS
1074 1087
1075Functions and methods that extend core crossfire objects. 1088Functions and methods that extend core crossfire objects.
1076 1089
1077=cut 1090=cut
1078 1091
1079package cf::player; 1092package cf::player;
1093
1094use Coro::AIO;
1080 1095
1081=head3 cf::player 1096=head3 cf::player
1082 1097
1083=over 4 1098=over 4
1084 1099
… …
1119 return $cf::PLAYER{$_[0]} || do { 1134 return $cf::PLAYER{$_[0]} || do {
1120 my $login = $_[0]; 1135 my $login = $_[0];
1121 1136
1122 my $guard = cf::lock_acquire "user_find:$login"; 1137 my $guard = cf::lock_acquire "user_find:$login";
1123 1138
1124 $cf::PLAYER{$login} ||= (load_pl path $login or return); 1139 $cf::PLAYER{$_[0]} || do {
1140 my $pl = load_pl path $login
1141 or return;
1142 $cf::PLAYER{$login} = $pl
1143 }
1125 }; 1144 }
1126} 1145}
1127 1146
1128sub save($) { 1147sub save($) {
1129 my ($pl) = @_; 1148 my ($pl) = @_;
1130 1149
… …
1133 my $path = path $pl; 1152 my $path = path $pl;
1134 my $guard = cf::lock_acquire "user_save:$path"; 1153 my $guard = cf::lock_acquire "user_save:$path";
1135 1154
1136 return if $pl->{deny_save}; 1155 return if $pl->{deny_save};
1137 1156
1138 Coro::AIO::aio_mkdir playerdir $pl, 0770; 1157 aio_mkdir playerdir $pl, 0770;
1139 $pl->{last_save} = $cf::RUNTIME; 1158 $pl->{last_save} = $cf::RUNTIME;
1140 1159
1141 $pl->save_pl ($path); 1160 $pl->save_pl ($path);
1142 Coro::cede; 1161 Coro::cede;
1143} 1162}
… …
1152 1171
1153 $cf::PLAYER{$login} = $self; 1172 $cf::PLAYER{$login} = $self;
1154 1173
1155 $self 1174 $self
1156} 1175}
1176
1177=item $pl->quit_character
1178
1179Nukes the player without looking back. If logged in, the connection will
1180be destroyed. May block for a long time.
1181
1182=cut
1157 1183
1158sub quit_character { 1184sub quit_character {
1159 my ($pl) = @_; 1185 my ($pl) = @_;
1160 1186
1161 $pl->{deny_save} = 1; 1187 $pl->{deny_save} = 1;
… …
1166 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1192 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1167 $pl->ns->destroy if $pl->ns; 1193 $pl->ns->destroy if $pl->ns;
1168 1194
1169 my $path = playerdir $pl; 1195 my $path = playerdir $pl;
1170 my $temp = "$path~$cf::RUNTIME~deleting~"; 1196 my $temp = "$path~$cf::RUNTIME~deleting~";
1171 IO::AIO::aio_rename $path, $temp, sub { 1197 aio_rename $path, $temp;
1172 delete $cf::PLAYER{$pl->ob->name}; 1198 delete $cf::PLAYER{$pl->ob->name};
1173 $pl->destroy; 1199 $pl->destroy;
1174
1175 IO::AIO::aio_rmtree $temp; 1200 IO::AIO::aio_rmtree $temp;
1201}
1202
1203=item cf::player::list_logins
1204
1205Returns am arrayref of all valid playernames in the system, can take a
1206while and may block, so not sync_job-capable, ever.
1207
1208=cut
1209
1210sub list_logins {
1211 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1212 or return [];
1213
1214 my @logins;
1215
1216 for my $login (@$dirs) {
1217 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1218 aio_read $fh, 0, 512, my $buf, 0 or next;
1219 $buf !~ /^password -------------$/m or next; # official not-valid tag
1220
1221 utf8::decode $login;
1222 push @logins, $login;
1176 }; 1223 }
1224
1225 \@logins
1226}
1227
1228=item $player->maps
1229
1230Returns an arrayref of cf::path's of all maps that are private for this
1231player. May block.
1232
1233=cut
1234
1235sub maps($) {
1236 my ($pl) = @_;
1237
1238 my $files = aio_readdir playerdir $pl
1239 or return;
1240
1241 my @paths;
1242
1243 for (@$files) {
1244 utf8::decode $_;
1245 next if /\.(?:pl|pst)$/;
1246 next unless /^$PATH_SEP/o;
1247
1248 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
1249 }
1250
1251 \@paths
1177} 1252}
1178 1253
1179=item $player->ext_reply ($msgid, $msgtype, %msg) 1254=item $player->ext_reply ($msgid, $msgtype, %msg)
1180 1255
1181Sends an ext reply to the player. 1256Sends an ext reply to the player.
… …
1211 1286
1212sub generate_random_map { 1287sub generate_random_map {
1213 my ($path, $rmp) = @_; 1288 my ($path, $rmp) = @_;
1214 1289
1215 # mit "rum" bekleckern, nicht 1290 # mit "rum" bekleckern, nicht
1216 cf::map::_create_random_map 1291 cf::map::_create_random_map (
1217 $path, 1292 $path,
1218 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1293 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1219 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1294 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1220 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1295 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1221 $rmp->{exit_on_final_map}, 1296 $rmp->{exit_on_final_map},
… …
1223 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1298 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1224 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1299 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1225 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1300 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1226 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1301 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1227 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1302 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1228 (cf::region::find $rmp->{region}) 1303 (cf::region::find $rmp->{region}), $rmp->{custom}
1304 )
1229} 1305}
1230 1306
1231# and all this just because we cannot iterate over 1307# and all this just because we cannot iterate over
1232# all maps in C++... 1308# all maps in C++...
1233sub change_all_map_light { 1309sub change_all_map_light {
… …
1235 1311
1236 $_->change_map_light ($change) 1312 $_->change_map_light ($change)
1237 for grep $_->outdoor, values %cf::MAP; 1313 for grep $_->outdoor, values %cf::MAP;
1238} 1314}
1239 1315
1240sub try_load_header($) { 1316sub load_map_header($) {
1241 my ($path) = @_; 1317 my ($path) = @_;
1242 1318
1243 utf8::encode $path; 1319 utf8::encode $path;
1244 aio_open $path, O_RDONLY, 0 1320 aio_open $path, O_RDONLY, 0
1245 or return; 1321 or return;
1246 1322
1247 my $map = cf::map::new 1323 my $map = cf::map::new
1248 or return; 1324 or return;
1249 1325
1250 # for better error messages only, will be overwritten 1326 # for better error messages only, will be overwritten later
1251 $map->path ($path); 1327 $map->path ($path);
1252 1328
1253 $map->load_header ($path) 1329 $map->load_header ($path)
1254 or return; 1330 or return;
1255 1331
… …
1271 1347
1272 $cf::MAP{$key} || do { 1348 $cf::MAP{$key} || do {
1273 my $guard = cf::lock_acquire "map_find:$key"; 1349 my $guard = cf::lock_acquire "map_find:$key";
1274 1350
1275 # do it the slow way 1351 # do it the slow way
1276 my $map = try_load_header $path->save_path; 1352 my $map = $path->load_temp;
1277 1353
1278 Coro::cede; 1354 Coro::cede;
1279 1355
1280 if ($map) { 1356 if ($map) {
1281 $map->last_access ((delete $map->{last_access}) 1357 $map->last_access ((delete $map->{last_access})
1282 || $cf::RUNTIME); #d# 1358 || $cf::RUNTIME); #d#
1283 # safety 1359 # safety
1284 $map->{instantiate_time} = $cf::RUNTIME 1360 $map->{instantiate_time} = $cf::RUNTIME
1285 if $map->{instantiate_time} > $cf::RUNTIME; 1361 if $map->{instantiate_time} > $cf::RUNTIME;
1286 } else { 1362 } else {
1287 if (my $rmp = $path->random_map_params) { 1363 $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; 1364 or return;
1294 1365
1295 $map->{load_original} = 1; 1366 $map->{load_original} = 1;
1296 $map->{instantiate_time} = $cf::RUNTIME; 1367 $map->{instantiate_time} = $cf::RUNTIME;
1297 $map->last_access ($cf::RUNTIME); 1368 $map->last_access ($cf::RUNTIME);
1298 $map->instantiate; 1369 $map->instantiate;
… …
1350 1421
1351 if ($self->{path}->is_style_map) { 1422 if ($self->{path}->is_style_map) {
1352 $self->{deny_save} = 1; 1423 $self->{deny_save} = 1;
1353 $self->{deny_reset} = 1; 1424 $self->{deny_reset} = 1;
1354 } else { 1425 } else {
1426 $self->decay_objects;
1355 $self->fix_auto_apply; 1427 $self->fix_auto_apply;
1356 $self->decay_objects;
1357 $self->update_buttons; 1428 $self->update_buttons;
1358 $self->set_darkness_map; 1429 $self->set_darkness_map;
1359 $self->difficulty ($self->estimate_difficulty) 1430 $self->difficulty ($self->estimate_difficulty)
1360 unless $self->difficulty; 1431 unless $self->difficulty;
1361 $self->activate; 1432 $self->activate;
… …
1364 Coro::cede; 1435 Coro::cede;
1365 1436
1366 $self->in_memory (cf::MAP_IN_MEMORY); 1437 $self->in_memory (cf::MAP_IN_MEMORY);
1367} 1438}
1368 1439
1440# find and load all maps in the 3x3 area around a map
1441sub load_diag {
1442 my ($map) = @_;
1443
1444 my @diag; # diagonal neighbours
1445
1446 for (0 .. 3) {
1447 my $neigh = $map->tile_path ($_)
1448 or next;
1449 $neigh = find $neigh, $map
1450 or next;
1451 $neigh->load;
1452
1453 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1454 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1455 }
1456
1457 for (@diag) {
1458 my $neigh = find @$_
1459 or next;
1460 $neigh->load;
1461 }
1462}
1463
1369sub find_sync { 1464sub find_sync {
1370 my ($path, $origin) = @_; 1465 my ($path, $origin) = @_;
1371 1466
1372 cf::sync_job { cf::map::find $path, $origin } 1467 cf::sync_job { find $path, $origin }
1373} 1468}
1374 1469
1375sub do_load_sync { 1470sub do_load_sync {
1376 my ($map) = @_; 1471 my ($map) = @_;
1377 1472
1378 cf::sync_job { $map->load }; 1473 cf::sync_job { $map->load };
1474}
1475
1476our %MAP_PREFETCH;
1477our $MAP_PREFETCHER = Coro::async {
1478 while () {
1479 while (%MAP_PREFETCH) {
1480 my $key = each %MAP_PREFETCH
1481 or next;
1482 my $path = delete $MAP_PREFETCH{$key};
1483
1484 my $map = find $path
1485 or next;
1486 $map->load;
1487 }
1488 Coro::schedule;
1489 }
1490};
1491
1492sub find_async {
1493 my ($path, $origin) = @_;
1494
1495 $path = new cf::path $path, $origin && $origin->path;
1496 my $key = $path->as_string;
1497
1498 if (my $map = $cf::MAP{$key}) {
1499 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1500 }
1501
1502 $MAP_PREFETCH{$key} = $path;
1503 $MAP_PREFETCHER->ready;
1504
1505 ()
1379} 1506}
1380 1507
1381sub save { 1508sub save {
1382 my ($self) = @_; 1509 my ($self) = @_;
1383 1510
… …
1441 my ($self) = @_; 1568 my ($self) = @_;
1442 1569
1443 $self->reset_at <= $cf::RUNTIME 1570 $self->reset_at <= $cf::RUNTIME
1444} 1571}
1445 1572
1446sub unlink_save {
1447 my ($self) = @_;
1448
1449 utf8::encode (my $save = $self->{path}->save_path);
1450 aioreq_pri 3; IO::AIO::aio_unlink $save;
1451 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1452}
1453
1454sub rename { 1573sub rename {
1455 my ($self, $new_path) = @_; 1574 my ($self, $new_path) = @_;
1456 1575
1457 $self->unlink_save; 1576 $self->{path}->unlink_save;
1458 1577
1459 delete $cf::MAP{$self->path}; 1578 delete $cf::MAP{$self->path};
1460 $self->{path} = new cf::path $new_path; 1579 $self->{path} = new cf::path $new_path;
1461 $self->path ($self->{path}->as_string); 1580 $self->path ($self->{path}->as_string);
1462 $cf::MAP{$self->path} = $self; 1581 $cf::MAP{$self->path} = $self;
… …
1476 1595
1477 delete $cf::MAP{$self->path}; 1596 delete $cf::MAP{$self->path};
1478 1597
1479 $_->clear_links_to ($self) for values %cf::MAP; 1598 $_->clear_links_to ($self) for values %cf::MAP;
1480 1599
1481 $self->unlink_save; 1600 $self->{path}->unlink_save;
1482 $self->destroy; 1601 $self->destroy;
1483} 1602}
1484 1603
1485my $nuke_counter = "aaaa"; 1604my $nuke_counter = "aaaa";
1486 1605
… …
1491 $self->reset_timeout (1); 1610 $self->reset_timeout (1);
1492 $self->rename ("{nuke}/" . ($nuke_counter++)); 1611 $self->rename ("{nuke}/" . ($nuke_counter++));
1493 $self->reset; # polite request, might not happen 1612 $self->reset; # polite request, might not happen
1494} 1613}
1495 1614
1496sub customise_for { 1615=item cf::map::unique_maps
1497 my ($map, $ob) = @_;
1498 1616
1499 if ($map->per_player) { 1617Returns an arrayref of cf::path's of all shared maps that have
1500 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1618instantiated unique items. May block.
1501 }
1502 1619
1503 $map 1620=cut
1504}
1505 1621
1506sub emergency_save { 1622sub unique_maps() {
1507 my $freeze_guard = cf::freeze_mainloop; 1623 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1624 or return;
1508 1625
1509 warn "enter emergency perl save\n"; 1626 my @paths;
1510 1627
1511 cf::sync_job { 1628 for (@$files) {
1512 warn "begin emergency player save\n"; 1629 utf8::decode $_;
1513 $_->save for values %cf::PLAYER; 1630 next if /\.pst$/;
1514 warn "end emergency player save\n"; 1631 next unless /^$PATH_SEP/o;
1515 1632
1516 warn "begin emergency map save\n"; 1633 push @paths, new cf::path $_;
1517 $_->save for values %cf::MAP;
1518 warn "end emergency map save\n";
1519 }; 1634 }
1520 1635
1521 warn "leave emergency perl save\n"; 1636 \@paths
1522} 1637}
1523 1638
1524package cf; 1639package cf;
1525 1640
1526=back 1641=back
1527 1642
1643=head3 cf::object
1644
1645=cut
1646
1647package cf::object;
1648
1649=over 4
1650
1651=item $ob->inv_recursive
1652
1653Returns the inventory of the object _and_ their inventories, recursively.
1654
1655=cut
1656
1657sub inv_recursive_;
1658sub inv_recursive_ {
1659 map { $_, inv_recursive_ $_->inv } @_
1660}
1661
1662sub inv_recursive {
1663 inv_recursive_ inv $_[0]
1664}
1665
1666package cf;
1667
1668=back
1528 1669
1529=head3 cf::object::player 1670=head3 cf::object::player
1530 1671
1531=over 4 1672=over 4
1532 1673
… …
1624 # use -1 or undef as default coordinates, not 0, 0 1765 # use -1 or undef as default coordinates, not 0, 0
1625 ($x, $y) = ($map->enter_x, $map->enter_y) 1766 ($x, $y) = ($map->enter_x, $map->enter_y)
1626 if $x <=0 && $y <= 0; 1767 if $x <=0 && $y <= 0;
1627 1768
1628 $map->load; 1769 $map->load;
1770 $map->load_diag;
1629 1771
1630 return unless $self->contr->active; 1772 return unless $self->contr->active;
1631 $self->activate_recursive; 1773 $self->activate_recursive;
1632 $self->enter_map ($map, $x, $y); 1774 $self->enter_map ($map, $x, $y);
1633} 1775}
… …
1669=cut 1811=cut
1670 1812
1671sub cf::object::player::goto { 1813sub cf::object::player::goto {
1672 my ($self, $path, $x, $y) = @_; 1814 my ($self, $path, $x, $y) = @_;
1673 1815
1816 $path = new cf::path $path;
1817
1674 $self->enter_link; 1818 $self->enter_link;
1675 1819
1676 (async { 1820 (async {
1677 $path = new cf::path $path;
1678
1679 my $map = cf::map::find $path->as_string; 1821 my $map = cf::map::find $path->as_string;
1680 $map = $map->customise_for ($self) if $map; 1822 $map = $map->{path}->customise_for ($map, $self) if $map;
1681 1823
1682# warn "entering ", $map->path, " at ($x, $y)\n" 1824# warn "entering ", $map->path, " at ($x, $y)\n"
1683# if $map; 1825# if $map;
1684 1826
1685 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1827 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1686 1828
1687 $self->leave_link ($map, $x, $y); 1829 $self->leave_link ($map, $x, $y);
1688 })->prio (1); 1830 })->prio (1);
1689} 1831}
1690 1832
… …
1756 1898
1757 1; 1899 1;
1758 }) { 1900 }) {
1759 $self->message ("Something went wrong deep within the crossfire server. " 1901 $self->message ("Something went wrong deep within the crossfire server. "
1760 . "I'll try to bring you back to the map you were before. " 1902 . "I'll try to bring you back to the map you were before. "
1761 . "Please report this to the dungeon master", 1903 . "Please report this to the dungeon master!",
1762 cf::NDI_UNIQUE | cf::NDI_RED); 1904 cf::NDI_UNIQUE | cf::NDI_RED);
1763 1905
1764 warn "ERROR in enter_exit: $@"; 1906 warn "ERROR in enter_exit: $@";
1765 $self->leave_link; 1907 $self->leave_link;
1766 } 1908 }
… …
2119 load_extensions; 2261 load_extensions;
2120 Event::loop; 2262 Event::loop;
2121} 2263}
2122 2264
2123############################################################################# 2265#############################################################################
2124# initialisation 2266# initialisation and cleanup
2267
2268# install some emergency cleanup handlers
2269BEGIN {
2270 for my $signal (qw(INT HUP TERM)) {
2271 Event->signal (
2272 data => WF_AUTOCANCEL,
2273 signal => $signal,
2274 cb => sub {
2275 cf::cleanup "SIG$signal";
2276 },
2277 );
2278 }
2279}
2280
2281sub emergency_save() {
2282 my $freeze_guard = cf::freeze_mainloop;
2283
2284 warn "enter emergency perl save\n";
2285
2286 cf::sync_job {
2287 # use a peculiar iteration method to avoid tripping on perl
2288 # refcount bugs in for. also avoids problems with players
2289 # and maps saved/Destroyed asynchronously.
2290 warn "begin emergency player save\n";
2291 for my $login (keys %cf::PLAYER) {
2292 my $pl = $cf::PLAYER{$login} or next;
2293 $pl->valid or next;
2294 $pl->save;
2295 }
2296 warn "end emergency player save\n";
2297
2298 warn "begin emergency map save\n";
2299 for my $path (keys %cf::MAP) {
2300 my $map = $cf::MAP{$path} or next;
2301 $map->valid or next;
2302 $map->save;
2303 }
2304 warn "end emergency map save\n";
2305 };
2306
2307 warn "leave emergency perl save\n";
2308}
2125 2309
2126sub reload() { 2310sub reload() {
2127 # can/must only be called in main 2311 # can/must only be called in main
2128 if ($Coro::current != $Coro::main) { 2312 if ($Coro::current != $Coro::main) {
2129 warn "can only reload from main coroutine\n"; 2313 warn "can only reload from main coroutine\n";
2130 return; 2314 return;
2131 } 2315 }
2132 2316
2133 warn "reloading..."; 2317 warn "reloading...";
2134 2318
2319 warn "freezing server";
2135 my $guard = freeze_mainloop; 2320 my $guard = freeze_mainloop;
2136 cf::emergency_save; 2321 cf::emergency_save;
2137 2322
2323 warn "sync database to disk";
2324 cf::db_sync;
2325 IO::AIO::flush;
2326
2138 eval { 2327 eval {
2139 # if anything goes wrong in here, we should simply crash as we already saved 2328 # if anything goes wrong in here, we should simply crash as we already saved
2140 2329
2141 # cancel all watchers 2330 warn "cancel all watchers";
2142 for (Event::all_watchers) { 2331 for (Event::all_watchers) {
2143 $_->cancel if $_->data & WF_AUTOCANCEL; 2332 $_->cancel if $_->data & WF_AUTOCANCEL;
2144 } 2333 }
2145 2334
2146 # cancel all extension coros 2335 warn "cancel all extension coros";
2147 $_->cancel for values %EXT_CORO; 2336 $_->cancel for values %EXT_CORO;
2148 %EXT_CORO = (); 2337 %EXT_CORO = ();
2149 2338
2339 warn "remove commands";
2340 %COMMAND = ();
2341
2342 warn "remove ext commands";
2343 %EXTCMD = ();
2344
2150 # unload all extensions 2345 warn "unload/nuke all extensions";
2151 for (@exts) { 2346 for my $pkg (@EXTS) {
2152 warn "unloading <$_>"; 2347 warn "... unloading $pkg";
2153 unload_extension $_; 2348
2349 if (my $cb = $pkg->can ("unload")) {
2350 eval {
2351 $cb->($pkg);
2352 1
2353 } or warn "$pkg unloaded, but with errors: $@";
2154 } 2354 }
2155 2355
2356 warn "... nuking $pkg";
2357 Symbol::delete_package $pkg;
2358 }
2359
2156 # unload all modules loaded from $LIBDIR 2360 warn "unload all perl modules loaded from $LIBDIR";
2157 while (my ($k, $v) = each %INC) { 2361 while (my ($k, $v) = each %INC) {
2158 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2362 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2159 2363
2160 warn "removing <$k>"; 2364 warn "removing <$k>";
2161 delete $INC{$k}; 2365 delete $INC{$k};
… …
2168 } 2372 }
2169 2373
2170 Symbol::delete_package $k; 2374 Symbol::delete_package $k;
2171 } 2375 }
2172 2376
2173 # sync database to disk
2174 cf::db_sync;
2175 IO::AIO::flush;
2176
2177 # get rid of safe::, as good as possible 2377 warn "get rid of safe::, as good as possible";
2178 Symbol::delete_package "safe::$_" 2378 Symbol::delete_package "safe::$_"
2179 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2379 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2180 2380
2181 # remove register_script_function callbacks
2182 # TODO
2183
2184 # unload cf.pm "a bit" 2381 warn "unload cf.pm \"a bit\"";
2185 delete $INC{"cf.pm"}; 2382 delete $INC{"cf.pm"};
2186 2383
2187 # don't, removes xs symbols, too, 2384 # don't, removes xs symbols, too,
2188 # and global variables created in xs 2385 # and global variables created in xs
2189 #Symbol::delete_package __PACKAGE__; 2386 #Symbol::delete_package __PACKAGE__;
2190 2387
2191 # reload cf.pm
2192 warn "reloading cf.pm"; 2388 warn "reloading cf.pm";
2193 require cf; 2389 require cf;
2194 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2390 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2195 2391
2196 # load config and database again 2392 warn "load config and database again";
2197 cf::cfg_load; 2393 cf::cfg_load;
2198 cf::db_load; 2394 cf::db_load;
2199 2395
2200 # load extensions
2201 warn "load extensions"; 2396 warn "load extensions";
2202 cf::load_extensions; 2397 cf::load_extensions;
2203 2398
2204 # reattach attachments to objects 2399 warn "reattach attachments to objects/players";
2205 warn "reattach";
2206 _global_reattach; 2400 _global_reattach;
2401 warn "reattach attachments to maps";
2207 reattach $_ for values %MAP; 2402 reattach $_ for values %MAP;
2208 }; 2403 };
2209 2404
2210 if ($@) { 2405 if ($@) {
2211 warn $@; 2406 warn $@;
2212 warn "error while reloading, exiting."; 2407 warn "error while reloading, exiting.";
2213 exit 1; 2408 exit 1;
2214 } 2409 }
2215 2410
2216 warn "reloaded successfully"; 2411 warn "reloaded";
2217}; 2412};
2218 2413
2219############################################################################# 2414#############################################################################
2220 2415
2221unless ($LINK_MAP) { 2416unless ($LINK_MAP) {
… …
2257 $LINK_MAP->{deny_reset} = 1; 2452 $LINK_MAP->{deny_reset} = 1;
2258 2453
2259 $cf::MAP{$LINK_MAP->path} = $LINK_MAP; 2454 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2260} 2455}
2261 2456
2262register "<global>", __PACKAGE__;
2263
2264register_command "reload" => sub { 2457register_command "reload" => sub {
2265 my ($who, $arg) = @_; 2458 my ($who, $arg) = @_;
2266 2459
2267 if ($who->flag (FLAG_WIZ)) { 2460 if ($who->flag (FLAG_WIZ)) {
2268 $who->message ("start of reload."); 2461 $who->message ("start of reload.");
… …
2277 reentrant => 0, 2470 reentrant => 0,
2278 prio => 0, 2471 prio => 0,
2279 at => $NEXT_TICK || $TICK, 2472 at => $NEXT_TICK || $TICK,
2280 data => WF_AUTOCANCEL, 2473 data => WF_AUTOCANCEL,
2281 cb => sub { 2474 cb => sub {
2475 $NOW = Event::time;
2476
2282 cf::server_tick; # one server iteration 2477 cf::server_tick; # one server iteration
2283 $RUNTIME += $TICK; 2478 $RUNTIME += $TICK;
2284 $NEXT_TICK += $TICK; 2479 $NEXT_TICK += $TICK;
2480
2481 $WAIT_FOR_TICK->broadcast;
2482 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2285 2483
2286 # if we are delayed by four ticks or more, skip them all 2484 # if we are delayed by four ticks or more, skip them all
2287 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2485 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2288 2486
2289 $TICK_WATCHER->at ($NEXT_TICK); 2487 $TICK_WATCHER->at ($NEXT_TICK);

Diff Legend

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