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

Diff Legend

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