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

Diff Legend

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