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.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 IO::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 Coro::cede;
1142 $pl->save_pl ($path); 1160 $pl->save_pl ($path);
1143 Coro::cede; 1161 Coro::cede;
1144} 1162}
1145 1163
1146sub new($) { 1164sub new($) {
… …
1153 1171
1154 $cf::PLAYER{$login} = $self; 1172 $cf::PLAYER{$login} = $self;
1155 1173
1156 $self 1174 $self
1157} 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
1158 1183
1159sub quit_character { 1184sub quit_character {
1160 my ($pl) = @_; 1185 my ($pl) = @_;
1161 1186
1162 $pl->{deny_save} = 1; 1187 $pl->{deny_save} = 1;
… …
1167 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1192 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1168 $pl->ns->destroy if $pl->ns; 1193 $pl->ns->destroy if $pl->ns;
1169 1194
1170 my $path = playerdir $pl; 1195 my $path = playerdir $pl;
1171 my $temp = "$path~$cf::RUNTIME~deleting~"; 1196 my $temp = "$path~$cf::RUNTIME~deleting~";
1172 IO::AIO::aio_rename $path, $temp, sub { 1197 aio_rename $path, $temp;
1173 delete $cf::PLAYER{$pl->ob->name}; 1198 delete $cf::PLAYER{$pl->ob->name};
1174 $pl->destroy; 1199 $pl->destroy;
1175
1176 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;
1177 }; 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
1178} 1252}
1179 1253
1180=item $player->ext_reply ($msgid, $msgtype, %msg) 1254=item $player->ext_reply ($msgid, $msgtype, %msg)
1181 1255
1182Sends an ext reply to the player. 1256Sends an ext reply to the player.
… …
1212 1286
1213sub generate_random_map { 1287sub generate_random_map {
1214 my ($path, $rmp) = @_; 1288 my ($path, $rmp) = @_;
1215 1289
1216 # mit "rum" bekleckern, nicht 1290 # mit "rum" bekleckern, nicht
1217 cf::map::_create_random_map 1291 cf::map::_create_random_map (
1218 $path, 1292 $path,
1219 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1293 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1220 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1294 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1221 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1295 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1222 $rmp->{exit_on_final_map}, 1296 $rmp->{exit_on_final_map},
… …
1224 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1298 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1225 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1299 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1226 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1300 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1227 $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},
1228 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1302 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1229 (cf::region::find $rmp->{region}) 1303 (cf::region::find $rmp->{region}), $rmp->{custom}
1304 )
1230} 1305}
1231 1306
1232# and all this just because we cannot iterate over 1307# and all this just because we cannot iterate over
1233# all maps in C++... 1308# all maps in C++...
1234sub change_all_map_light { 1309sub change_all_map_light {
… …
1236 1311
1237 $_->change_map_light ($change) 1312 $_->change_map_light ($change)
1238 for grep $_->outdoor, values %cf::MAP; 1313 for grep $_->outdoor, values %cf::MAP;
1239} 1314}
1240 1315
1241sub try_load_header($) { 1316sub load_map_header($) {
1242 my ($path) = @_; 1317 my ($path) = @_;
1243 1318
1244 utf8::encode $path; 1319 utf8::encode $path;
1245 aio_open $path, O_RDONLY, 0 1320 aio_open $path, O_RDONLY, 0
1246 or return; 1321 or return;
1247 1322
1248 my $map = cf::map::new 1323 my $map = cf::map::new
1249 or return; 1324 or return;
1250 1325
1251 # for better error messages only, will be overwritten 1326 # for better error messages only, will be overwritten later
1252 $map->path ($path); 1327 $map->path ($path);
1253 1328
1254 $map->load_header ($path) 1329 $map->load_header ($path)
1255 or return; 1330 or return;
1256 1331
… …
1272 1347
1273 $cf::MAP{$key} || do { 1348 $cf::MAP{$key} || do {
1274 my $guard = cf::lock_acquire "map_find:$key"; 1349 my $guard = cf::lock_acquire "map_find:$key";
1275 1350
1276 # do it the slow way 1351 # do it the slow way
1277 my $map = try_load_header $path->save_path; 1352 my $map = $path->load_temp;
1278 1353
1279 Coro::cede; 1354 Coro::cede;
1280 1355
1281 if ($map) { 1356 if ($map) {
1282 $map->last_access ((delete $map->{last_access}) 1357 $map->last_access ((delete $map->{last_access})
1283 || $cf::RUNTIME); #d# 1358 || $cf::RUNTIME); #d#
1284 # safety 1359 # safety
1285 $map->{instantiate_time} = $cf::RUNTIME 1360 $map->{instantiate_time} = $cf::RUNTIME
1286 if $map->{instantiate_time} > $cf::RUNTIME; 1361 if $map->{instantiate_time} > $cf::RUNTIME;
1287 } else { 1362 } else {
1288 if (my $rmp = $path->random_map_params) { 1363 $map = $path->load_orig
1289 $map = generate_random_map $key, $rmp;
1290 } else {
1291 $map = try_load_header $path->load_path;
1292 }
1293
1294 $map or return; 1364 or return;
1295 1365
1296 $map->{load_original} = 1; 1366 $map->{load_original} = 1;
1297 $map->{instantiate_time} = $cf::RUNTIME; 1367 $map->{instantiate_time} = $cf::RUNTIME;
1298 $map->last_access ($cf::RUNTIME); 1368 $map->last_access ($cf::RUNTIME);
1299 $map->instantiate; 1369 $map->instantiate;
… …
1351 1421
1352 if ($self->{path}->is_style_map) { 1422 if ($self->{path}->is_style_map) {
1353 $self->{deny_save} = 1; 1423 $self->{deny_save} = 1;
1354 $self->{deny_reset} = 1; 1424 $self->{deny_reset} = 1;
1355 } else { 1425 } else {
1426 $self->decay_objects;
1356 $self->fix_auto_apply; 1427 $self->fix_auto_apply;
1357 $self->decay_objects;
1358 $self->update_buttons; 1428 $self->update_buttons;
1359 $self->set_darkness_map; 1429 $self->set_darkness_map;
1360 $self->difficulty ($self->estimate_difficulty) 1430 $self->difficulty ($self->estimate_difficulty)
1361 unless $self->difficulty; 1431 unless $self->difficulty;
1362 $self->activate; 1432 $self->activate;
… …
1365 Coro::cede; 1435 Coro::cede;
1366 1436
1367 $self->in_memory (cf::MAP_IN_MEMORY); 1437 $self->in_memory (cf::MAP_IN_MEMORY);
1368} 1438}
1369 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
1370sub find_sync { 1464sub find_sync {
1371 my ($path, $origin) = @_; 1465 my ($path, $origin) = @_;
1372 1466
1373 cf::sync_job { cf::map::find $path, $origin } 1467 cf::sync_job { find $path, $origin }
1374} 1468}
1375 1469
1376sub do_load_sync { 1470sub do_load_sync {
1377 my ($map) = @_; 1471 my ($map) = @_;
1378 1472
1379 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 ()
1380} 1506}
1381 1507
1382sub save { 1508sub save {
1383 my ($self) = @_; 1509 my ($self) = @_;
1384 1510
… …
1442 my ($self) = @_; 1568 my ($self) = @_;
1443 1569
1444 $self->reset_at <= $cf::RUNTIME 1570 $self->reset_at <= $cf::RUNTIME
1445} 1571}
1446 1572
1447sub unlink_save {
1448 my ($self) = @_;
1449
1450 utf8::encode (my $save = $self->{path}->save_path);
1451 aioreq_pri 3; IO::AIO::aio_unlink $save;
1452 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1453}
1454
1455sub rename { 1573sub rename {
1456 my ($self, $new_path) = @_; 1574 my ($self, $new_path) = @_;
1457 1575
1458 $self->unlink_save; 1576 $self->{path}->unlink_save;
1459 1577
1460 delete $cf::MAP{$self->path}; 1578 delete $cf::MAP{$self->path};
1461 $self->{path} = new cf::path $new_path; 1579 $self->{path} = new cf::path $new_path;
1462 $self->path ($self->{path}->as_string); 1580 $self->path ($self->{path}->as_string);
1463 $cf::MAP{$self->path} = $self; 1581 $cf::MAP{$self->path} = $self;
… …
1477 1595
1478 delete $cf::MAP{$self->path}; 1596 delete $cf::MAP{$self->path};
1479 1597
1480 $_->clear_links_to ($self) for values %cf::MAP; 1598 $_->clear_links_to ($self) for values %cf::MAP;
1481 1599
1482 $self->unlink_save; 1600 $self->{path}->unlink_save;
1483 $self->destroy; 1601 $self->destroy;
1484} 1602}
1485 1603
1486my $nuke_counter = "aaaa"; 1604my $nuke_counter = "aaaa";
1487 1605
… …
1492 $self->reset_timeout (1); 1610 $self->reset_timeout (1);
1493 $self->rename ("{nuke}/" . ($nuke_counter++)); 1611 $self->rename ("{nuke}/" . ($nuke_counter++));
1494 $self->reset; # polite request, might not happen 1612 $self->reset; # polite request, might not happen
1495} 1613}
1496 1614
1497sub customise_for { 1615=item cf::map::unique_maps
1498 my ($map, $ob) = @_;
1499 1616
1500 if ($map->per_player) { 1617Returns an arrayref of cf::path's of all shared maps that have
1501 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1618instantiated unique items. May block.
1502 }
1503 1619
1504 $map 1620=cut
1505}
1506 1621
1507sub emergency_save { 1622sub unique_maps() {
1508 my $freeze_guard = cf::freeze_mainloop; 1623 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1624 or return;
1509 1625
1510 warn "enter emergency perl save\n"; 1626 my @paths;
1511 1627
1512 cf::sync_job { 1628 for (@$files) {
1513 warn "begin emergency player save\n"; 1629 utf8::decode $_;
1514 $_->save for values %cf::PLAYER; 1630 next if /\.pst$/;
1515 warn "end emergency player save\n"; 1631 next unless /^$PATH_SEP/o;
1516 1632
1517 warn "begin emergency map save\n"; 1633 push @paths, new cf::path $_;
1518 $_->save for values %cf::MAP;
1519 warn "end emergency map save\n";
1520 }; 1634 }
1521 1635
1522 warn "leave emergency perl save\n"; 1636 \@paths
1523} 1637}
1524 1638
1525package cf; 1639package cf;
1526 1640
1527=back 1641=back
1528 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
1529 1669
1530=head3 cf::object::player 1670=head3 cf::object::player
1531 1671
1532=over 4 1672=over 4
1533 1673
… …
1625 # use -1 or undef as default coordinates, not 0, 0 1765 # use -1 or undef as default coordinates, not 0, 0
1626 ($x, $y) = ($map->enter_x, $map->enter_y) 1766 ($x, $y) = ($map->enter_x, $map->enter_y)
1627 if $x <=0 && $y <= 0; 1767 if $x <=0 && $y <= 0;
1628 1768
1629 $map->load; 1769 $map->load;
1770 $map->load_diag;
1630 1771
1631 return unless $self->contr->active; 1772 return unless $self->contr->active;
1632 $self->activate_recursive; 1773 $self->activate_recursive;
1633 $self->enter_map ($map, $x, $y); 1774 $self->enter_map ($map, $x, $y);
1634} 1775}
… …
1670=cut 1811=cut
1671 1812
1672sub cf::object::player::goto { 1813sub cf::object::player::goto {
1673 my ($self, $path, $x, $y) = @_; 1814 my ($self, $path, $x, $y) = @_;
1674 1815
1816 $path = new cf::path $path;
1817
1675 $self->enter_link; 1818 $self->enter_link;
1676 1819
1677 (async { 1820 (async {
1678 $path = new cf::path $path;
1679
1680 my $map = cf::map::find $path->as_string; 1821 my $map = cf::map::find $path->as_string;
1681 $map = $map->customise_for ($self) if $map; 1822 $map = $map->{path}->customise_for ($map, $self) if $map;
1682 1823
1683# warn "entering ", $map->path, " at ($x, $y)\n" 1824# warn "entering ", $map->path, " at ($x, $y)\n"
1684# if $map; 1825# if $map;
1685 1826
1686 $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);
1687 1828
1688 $self->leave_link ($map, $x, $y); 1829 $self->leave_link ($map, $x, $y);
1689 })->prio (1); 1830 })->prio (1);
1690} 1831}
1691 1832
… …
1757 1898
1758 1; 1899 1;
1759 }) { 1900 }) {
1760 $self->message ("Something went wrong deep within the crossfire server. " 1901 $self->message ("Something went wrong deep within the crossfire server. "
1761 . "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. "
1762 . "Please report this to the dungeon master", 1903 . "Please report this to the dungeon master!",
1763 cf::NDI_UNIQUE | cf::NDI_RED); 1904 cf::NDI_UNIQUE | cf::NDI_RED);
1764 1905
1765 warn "ERROR in enter_exit: $@"; 1906 warn "ERROR in enter_exit: $@";
1766 $self->leave_link; 1907 $self->leave_link;
1767 } 1908 }
… …
2120 load_extensions; 2261 load_extensions;
2121 Event::loop; 2262 Event::loop;
2122} 2263}
2123 2264
2124############################################################################# 2265#############################################################################
2125# 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}
2126 2309
2127sub reload() { 2310sub reload() {
2128 # can/must only be called in main 2311 # can/must only be called in main
2129 if ($Coro::current != $Coro::main) { 2312 if ($Coro::current != $Coro::main) {
2130 warn "can only reload from main coroutine\n"; 2313 warn "can only reload from main coroutine\n";
2131 return; 2314 return;
2132 } 2315 }
2133 2316
2134 warn "reloading..."; 2317 warn "reloading...";
2135 2318
2319 warn "freezing server";
2136 my $guard = freeze_mainloop; 2320 my $guard = freeze_mainloop;
2137 cf::emergency_save; 2321 cf::emergency_save;
2138 2322
2323 warn "sync database to disk";
2324 cf::db_sync;
2325 IO::AIO::flush;
2326
2139 eval { 2327 eval {
2140 # 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
2141 2329
2142 # cancel all watchers 2330 warn "cancel all watchers";
2143 for (Event::all_watchers) { 2331 for (Event::all_watchers) {
2144 $_->cancel if $_->data & WF_AUTOCANCEL; 2332 $_->cancel if $_->data & WF_AUTOCANCEL;
2145 } 2333 }
2146 2334
2147 # cancel all extension coros 2335 warn "cancel all extension coros";
2148 $_->cancel for values %EXT_CORO; 2336 $_->cancel for values %EXT_CORO;
2149 %EXT_CORO = (); 2337 %EXT_CORO = ();
2150 2338
2339 warn "remove commands";
2340 %COMMAND = ();
2341
2342 warn "remove ext commands";
2343 %EXTCMD = ();
2344
2151 # unload all extensions 2345 warn "unload/nuke all extensions";
2152 for (@exts) { 2346 for my $pkg (@EXTS) {
2153 warn "unloading <$_>"; 2347 warn "... unloading $pkg";
2154 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: $@";
2155 } 2354 }
2156 2355
2356 warn "... nuking $pkg";
2357 Symbol::delete_package $pkg;
2358 }
2359
2157 # unload all modules loaded from $LIBDIR 2360 warn "unload all perl modules loaded from $LIBDIR";
2158 while (my ($k, $v) = each %INC) { 2361 while (my ($k, $v) = each %INC) {
2159 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2362 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2160 2363
2161 warn "removing <$k>"; 2364 warn "removing <$k>";
2162 delete $INC{$k}; 2365 delete $INC{$k};
… …
2169 } 2372 }
2170 2373
2171 Symbol::delete_package $k; 2374 Symbol::delete_package $k;
2172 } 2375 }
2173 2376
2174 # sync database to disk
2175 cf::db_sync;
2176 IO::AIO::flush;
2177
2178 # get rid of safe::, as good as possible 2377 warn "get rid of safe::, as good as possible";
2179 Symbol::delete_package "safe::$_" 2378 Symbol::delete_package "safe::$_"
2180 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);
2181 2380
2182 # remove register_script_function callbacks
2183 # TODO
2184
2185 # unload cf.pm "a bit" 2381 warn "unload cf.pm \"a bit\"";
2186 delete $INC{"cf.pm"}; 2382 delete $INC{"cf.pm"};
2187 2383
2188 # don't, removes xs symbols, too, 2384 # don't, removes xs symbols, too,
2189 # and global variables created in xs 2385 # and global variables created in xs
2190 #Symbol::delete_package __PACKAGE__; 2386 #Symbol::delete_package __PACKAGE__;
2191 2387
2192 # reload cf.pm
2193 warn "reloading cf.pm"; 2388 warn "reloading cf.pm";
2194 require cf; 2389 require cf;
2195 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2390 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2196 2391
2197 # load config and database again 2392 warn "load config and database again";
2198 cf::cfg_load; 2393 cf::cfg_load;
2199 cf::db_load; 2394 cf::db_load;
2200 2395
2201 # load extensions
2202 warn "load extensions"; 2396 warn "load extensions";
2203 cf::load_extensions; 2397 cf::load_extensions;
2204 2398
2205 # reattach attachments to objects 2399 warn "reattach attachments to objects/players";
2206 warn "reattach";
2207 _global_reattach; 2400 _global_reattach;
2401 warn "reattach attachments to maps";
2208 reattach $_ for values %MAP; 2402 reattach $_ for values %MAP;
2209 }; 2403 };
2210 2404
2211 if ($@) { 2405 if ($@) {
2212 warn $@; 2406 warn $@;
2213 warn "error while reloading, exiting."; 2407 warn "error while reloading, exiting.";
2214 exit 1; 2408 exit 1;
2215 } 2409 }
2216 2410
2217 warn "reloaded successfully"; 2411 warn "reloaded";
2218}; 2412};
2219 2413
2220############################################################################# 2414#############################################################################
2221 2415
2222unless ($LINK_MAP) { 2416unless ($LINK_MAP) {
… …
2258 $LINK_MAP->{deny_reset} = 1; 2452 $LINK_MAP->{deny_reset} = 1;
2259 2453
2260 $cf::MAP{$LINK_MAP->path} = $LINK_MAP; 2454 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2261} 2455}
2262 2456
2263register "<global>", __PACKAGE__;
2264
2265register_command "reload" => sub { 2457register_command "reload" => sub {
2266 my ($who, $arg) = @_; 2458 my ($who, $arg) = @_;
2267 2459
2268 if ($who->flag (FLAG_WIZ)) { 2460 if ($who->flag (FLAG_WIZ)) {
2269 $who->message ("start of reload."); 2461 $who->message ("start of reload.");
… …
2278 reentrant => 0, 2470 reentrant => 0,
2279 prio => 0, 2471 prio => 0,
2280 at => $NEXT_TICK || $TICK, 2472 at => $NEXT_TICK || $TICK,
2281 data => WF_AUTOCANCEL, 2473 data => WF_AUTOCANCEL,
2282 cb => sub { 2474 cb => sub {
2475 $NOW = Event::time;
2476
2283 cf::server_tick; # one server iteration 2477 cf::server_tick; # one server iteration
2284 $RUNTIME += $TICK; 2478 $RUNTIME += $TICK;
2285 $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;
2286 2483
2287 # 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
2288 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2485 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2289 2486
2290 $TICK_WATCHER->at ($NEXT_TICK); 2487 $TICK_WATCHER->at ($NEXT_TICK);

Diff Legend

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