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.154 by root, Tue Jan 9 15:36:19 2007 UTC vs.
Revision 1.165 by root, Fri Jan 12 22:09:22 2007 UTC

… …
24use YAML::Syck (); 24use YAML::Syck ();
25use Time::HiRes; 25use Time::HiRes;
26 26
27use 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
28 28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30
29# 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?
30$YAML::Syck::ImplicitUnicode = 1; 32$YAML::Syck::ImplicitUnicode = 1;
31 33
32$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
33 35
34sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
35
36our %COMMAND = (); 36our %COMMAND = ();
37our %COMMAND_TIME = (); 37our %COMMAND_TIME = ();
38
39our @EXTS = (); # list of extension package names
38our %EXTCMD = (); 40our %EXTCMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps
39 43
40our @EVENT; 44our @EVENT;
41our $LIBDIR = datadir . "/ext"; 45our $LIBDIR = datadir . "/ext";
42 46
43our $TICK = MAX_TIME * 1e-6; 47our $TICK = MAX_TIME * 1e-6;
… …
52 56
53our %PLAYER; # all users 57our %PLAYER; # all users
54our %MAP; # all maps 58our %MAP; # all maps
55our $LINK_MAP; # the special {link} map 59our $LINK_MAP; # the special {link} map
56our $RANDOM_MAPS = cf::localdir . "/random"; 60our $RANDOM_MAPS = cf::localdir . "/random";
57our %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;
58 64
59binmode STDOUT; 65binmode STDOUT;
60binmode STDERR; 66binmode STDERR;
61 67
62# read virtual server time, if available 68# read virtual server time, if available
… …
106 112
107=item %cf::CFG 113=item %cf::CFG
108 114
109Configuration for the server, loaded from C</etc/crossfire/config>, or 115Configuration for the server, loaded from C</etc/crossfire/config>, or
110from 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.
111 124
112=back 125=back
113 126
114=cut 127=cut
115 128
… …
146} 159}
147 160
148$Event::DIED = sub { 161$Event::DIED = sub {
149 warn "error in event callback: @_"; 162 warn "error in event callback: @_";
150}; 163};
151
152my %ext_pkg;
153my @exts;
154my @hook;
155 164
156=head2 UTILITY FUNCTIONS 165=head2 UTILITY FUNCTIONS
157 166
158=over 4 167=over 4
159 168
… …
309 } 318 }
310} 319}
311 320
312=item $coro = cf::async_ext { BLOCK } 321=item $coro = cf::async_ext { BLOCK }
313 322
314Like async, but this coro is automcatially being canceled when the 323Like async, but this coro is automatically being canceled when the
315extension calling this is being unloaded. 324extension calling this is being unloaded.
316 325
317=cut 326=cut
318 327
319sub async_ext(&) { 328sub async_ext(&) {
… …
357 366
358############################################################################# 367#############################################################################
359 368
360package cf::path; 369package cf::path;
361 370
371use overload
372 '""' => \&as_string;
373
362# used to convert map paths into valid unix filenames by repalcing / by ∕ 374# used to convert map paths into valid unix filenames by repalcing / by ∕
363our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 375our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
364 376
377sub register {
378 my ($pkg, $prefix) = @_;
379
380 $EXT_MAP{$prefix} = $pkg;
381}
382
365sub new { 383sub new {
366 my ($class, $path, $base) = @_; 384 my ($class, $path, $base) = @_;
367 385
368 $path = $path->as_string if ref $path; 386 return $path if ref $path;
369 387
370 my $self = bless { }, $class; 388 my $self = {};
371 389
372 # {... are special paths that are not touched 390 # {... are special paths that are not being touched
373 # ?xxx/... are special absolute paths 391 # ?xxx/... are special absolute paths
374 # ?random/... random maps 392 # ?random/... random maps
375 # /! non-realised random map exit 393 # /! non-realised random map exit
376 # /... normal maps 394 # /... normal maps
377 # ~/... per-player maps without a specific player (DO NOT USE) 395 # ~/... per-player maps without a specific player (DO NOT USE)
378 # ~user/... per-player map of a specific user 396 # ~user/... per-player map of a specific user
379 397
398 $path =~ s/$PATH_SEP/\//go;
399
380 if ($path =~ /^{/) { 400 if ($path =~ /^{/) {
381 # fine as it is 401 # fine as it is
382 } elsif ($path =~ s{^\?random/}{}) {
383 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
384 $self->{random} = cf::from_json $data;
385 } else { 402 } else {
386 if ($path =~ s{^~([^/]+)?}{}) { 403 if ($path =~ s{^~([^/]+)?}{}) {
404 # ~user
387 $self->{user_rel} = 1; 405 $self->{user_rel} = 1;
388 406
389 if (defined $1) { 407 if (defined $1) {
390 $self->{user} = $1; 408 $self->{user} = $1;
391 } elsif ($base =~ m{^~([^/]+)/}) { 409 } elsif ($base =~ m{^~([^/]+)/}) {
392 $self->{user} = $1; 410 $self->{user} = $1;
393 } else { 411 } else {
394 warn "cannot resolve user-relative path without user <$path,$base>\n"; 412 warn "cannot resolve user-relative path without user <$path,$base>\n";
395 } 413 }
414 } elsif ($path =~ s{^\?([^/]+)/}{}) {
415 # ?...
416 $self->{ext} = $1;
417 if (my $ext = $EXT_MAP{$1}) {
418 bless $self, $ext;
419 }
396 } elsif ($path =~ /^\//) { 420 } elsif ($path =~ /^\//) {
421 # /...
397 # already absolute 422 # already absolute
398 } else { 423 } else {
424 # relative
399 $base =~ s{[^/]+/?$}{}; 425 $base =~ s{[^/]+/?$}{};
400 return $class->new ("$base/$path"); 426 return $class->new ("$base/$path");
401 } 427 }
402 428
403 for ($path) { 429 for ($path) {
… …
406 } 432 }
407 } 433 }
408 434
409 $self->{path} = $path; 435 $self->{path} = $path;
410 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
411 $self 449 $self
450}
451
452sub init {
453 # nop
454}
455
456sub substitute {
457 ()
412} 458}
413 459
414# the name / primary key / in-game path 460# the name / primary key / in-game path
415sub as_string { 461sub as_string {
416 my ($self) = @_; 462 my ($self) = @_;
417 463
418 $self->{user_rel} ? "~$self->{user}$self->{path}" 464 $self->{user_rel} ? "~$self->{user}$self->{path}"
419 : $self->{random} ? "?random/$self->{path}" 465 : $self->{ext} ? "?$self->{ext}/$self->{path}"
420 : $self->{path} 466 : $self->{path}
421} 467}
422 468
423# the displayed name, this is a one way mapping 469# the displayed name, this is a one way mapping
424sub visible_name { 470sub visible_name {
425 my ($self) = @_; 471 &as_string
426
427# if (my $rmp = $self->{random}) {
428# # todo: be more intelligent about this
429# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
430# } else {
431 $self->as_string
432# }
433} 472}
434 473
435# escape the /'s in the path 474# escape the /'s in the path
436sub _escaped_path { 475sub _escaped_path {
437 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 476 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
477
438 $path 478 $path
439} 479}
440 480
441# the original (read-only) location 481# the original (read-only) location
442sub load_path { 482sub load_path {
… …
447 487
448# the temporary/swap location 488# the temporary/swap location
449sub save_path { 489sub save_path {
450 my ($self) = @_; 490 my ($self) = @_;
451 491
492 $self->{user_rel}
452 $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
453 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
454 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path 494 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
455} 495}
456 496
457# the unique path, might be eq to save_path 497# the unique path, undef == no special unique path
458sub uniq_path { 498sub uniq_path {
459 my ($self) = @_; 499 my ($self) = @_;
460 500
461 $self->{user_rel} || $self->{random} 501 $self->{user_rel} || $self->{ext}
462 ? undef 502 ? undef
463 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path 503 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
464} 504}
465 505
466# return random map parameters, or undef 506sub customise_for {
467sub random_map_params {
468 my ($self) = @_; 507 my ($self, $map, $ob) = @_;
469 508
470 $self->{random} 509 if ($map->per_player) {
510 return cf::map::find ("~" . $ob->name . "/" . $map->{path}{path});
511 }
512
513 $map
471} 514}
472 515
473# this is somewhat ugly, but style maps do need special treatment 516# this is somewhat ugly, but style maps do need special treatment
474sub is_style_map { 517sub is_style_map {
475 $_[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";
476} 539}
477 540
478package cf; 541package cf;
479 542
480############################################################################# 543#############################################################################
… …
930=cut 993=cut
931 994
932sub register_extcmd { 995sub register_extcmd {
933 my ($name, $cb) = @_; 996 my ($name, $cb) = @_;
934 997
935 my $caller = caller;
936 #warn "registering extcmd '$name' to '$caller'";
937
938 $EXTCMD{$name} = [$cb, $caller]; 998 $EXTCMD{$name} = $cb;
939} 999}
940 1000
941cf::player->attach ( 1001cf::player->attach (
942 on_command => sub { 1002 on_command => sub {
943 my ($pl, $name, $params) = @_; 1003 my ($pl, $name, $params) = @_;
… …
956 1016
957 my $msg = eval { from_json $buf }; 1017 my $msg = eval { from_json $buf };
958 1018
959 if (ref $msg) { 1019 if (ref $msg) {
960 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1020 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
961 if (my %reply = $cb->[0]->($pl, $msg)) { 1021 if (my %reply = $cb->($pl, $msg)) {
962 $pl->ext_reply ($msg->{msgid}, %reply); 1022 $pl->ext_reply ($msg->{msgid}, %reply);
963 } 1023 }
964 } 1024 }
965 } else { 1025 } else {
966 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1026 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
968 1028
969 cf::override; 1029 cf::override;
970 }, 1030 },
971); 1031);
972 1032
973sub register {
974 my ($base, $pkg) = @_;
975
976 #TODO
977}
978
979sub load_extension { 1033sub load_extension {
980 my ($path) = @_; 1034 my ($path) = @_;
981 1035
982 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1036 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
983 my $base = $1; 1037 my $base = $1;
984 my $pkg = $1; 1038 my $pkg = $1;
985 $pkg =~ s/[^[:word:]]/_/g; 1039 $pkg =~ s/[^[:word:]]/_/g;
986 $pkg = "ext::$pkg"; 1040 $pkg = "ext::$pkg";
987 1041
988 warn "loading '$path' into '$pkg'\n"; 1042 warn "... loading '$path' into '$pkg'\n";
989 1043
990 open my $fh, "<:utf8", $path 1044 open my $fh, "<:utf8", $path
991 or die "$path: $!"; 1045 or die "$path: $!";
992 1046
993 my $source = 1047 my $source =
… …
998 1052
999 eval $source 1053 eval $source
1000 or die $@ ? "$path: $@\n" 1054 or die $@ ? "$path: $@\n"
1001 : "extension disabled.\n"; 1055 : "extension disabled.\n";
1002 1056
1003 push @exts, $pkg; 1057 push @EXTS, $pkg;
1004 $ext_pkg{$base} = $pkg;
1005
1006# no strict 'refs';
1007# @{"$pkg\::ISA"} = ext::;
1008
1009 register $base, $pkg;
1010}
1011
1012sub unload_extension {
1013 my ($pkg) = @_;
1014
1015 warn "removing extension $pkg\n";
1016
1017 # remove hooks
1018 #TODO
1019# for my $idx (0 .. $#PLUGIN_EVENT) {
1020# delete $hook[$idx]{$pkg};
1021# }
1022
1023 # remove commands
1024 for my $name (keys %COMMAND) {
1025 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1026
1027 if (@cb) {
1028 $COMMAND{$name} = \@cb;
1029 } else {
1030 delete $COMMAND{$name};
1031 }
1032 }
1033
1034 # remove extcmds
1035 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1036 delete $EXTCMD{$name};
1037 }
1038
1039 if (my $cb = $pkg->can ("unload")) {
1040 eval {
1041 $cb->($pkg);
1042 1
1043 } or warn "$pkg unloaded, but with errors: $@";
1044 }
1045
1046 Symbol::delete_package $pkg;
1047} 1058}
1048 1059
1049sub load_extensions { 1060sub load_extensions {
1050 for my $ext (<$LIBDIR/*.ext>) { 1061 for my $ext (<$LIBDIR/*.ext>) {
1051 next unless -r $ext; 1062 next unless -r $ext;
… …
1069}; 1080};
1070 1081
1071cf::map->attach (prio => -10000, package => cf::mapsupport::); 1082cf::map->attach (prio => -10000, package => cf::mapsupport::);
1072 1083
1073############################################################################# 1084#############################################################################
1074# load/save perl data associated with player->ob objects
1075
1076sub all_objects(@) {
1077 @_, map all_objects ($_->inv), @_
1078}
1079
1080# TODO: compatibility cruft, remove when no longer needed
1081cf::player->attach (
1082 on_load => sub {
1083 my ($pl, $path) = @_;
1084
1085 for my $o (all_objects $pl->ob) {
1086 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1087 $o->set_ob_key_value ("_perl_data");
1088
1089 %$o = %{ Storable::thaw pack "H*", $value };
1090 }
1091 }
1092 },
1093);
1094
1095#############################################################################
1096 1085
1097=head2 CORE EXTENSIONS 1086=head2 CORE EXTENSIONS
1098 1087
1099Functions and methods that extend core crossfire objects. 1088Functions and methods that extend core crossfire objects.
1100 1089
… …
1225 my @logins; 1214 my @logins;
1226 1215
1227 for my $login (@$dirs) { 1216 for my $login (@$dirs) {
1228 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1217 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1229 aio_read $fh, 0, 512, my $buf, 0 or next; 1218 aio_read $fh, 0, 512, my $buf, 0 or next;
1230 $buf !~ /^password -------------$/ or next; # official not-valid tag 1219 $buf !~ /^password -------------$/m or next; # official not-valid tag
1231 1220
1232 utf8::decode $login; 1221 utf8::decode $login;
1233 push @logins, $login; 1222 push @logins, $login;
1234 } 1223 }
1235 1224
… …
1252 my @paths; 1241 my @paths;
1253 1242
1254 for (@$files) { 1243 for (@$files) {
1255 utf8::decode $_; 1244 utf8::decode $_;
1256 next if /\.(?:pl|pst)$/; 1245 next if /\.(?:pl|pst)$/;
1257 next unless /^$PATH_SEP/; 1246 next unless /^$PATH_SEP/o;
1258 1247
1259 s/$PATH_SEP/\//g;
1260 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_; 1248 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
1261 } 1249 }
1262 1250
1263 \@paths 1251 \@paths
1264} 1252}
… …
1298 1286
1299sub generate_random_map { 1287sub generate_random_map {
1300 my ($path, $rmp) = @_; 1288 my ($path, $rmp) = @_;
1301 1289
1302 # mit "rum" bekleckern, nicht 1290 # mit "rum" bekleckern, nicht
1303 cf::map::_create_random_map 1291 cf::map::_create_random_map (
1304 $path, 1292 $path,
1305 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1293 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1306 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1294 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1307 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1295 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1308 $rmp->{exit_on_final_map}, 1296 $rmp->{exit_on_final_map},
… …
1310 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1298 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1311 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1299 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1312 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1300 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1313 $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},
1314 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1302 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1315 (cf::region::find $rmp->{region}) 1303 (cf::region::find $rmp->{region}), $rmp->{custom}
1304 )
1316} 1305}
1317 1306
1318# and all this just because we cannot iterate over 1307# and all this just because we cannot iterate over
1319# all maps in C++... 1308# all maps in C++...
1320sub change_all_map_light { 1309sub change_all_map_light {
… …
1322 1311
1323 $_->change_map_light ($change) 1312 $_->change_map_light ($change)
1324 for grep $_->outdoor, values %cf::MAP; 1313 for grep $_->outdoor, values %cf::MAP;
1325} 1314}
1326 1315
1327sub try_load_header($) { 1316sub load_map_header($) {
1328 my ($path) = @_; 1317 my ($path) = @_;
1329 1318
1330 utf8::encode $path; 1319 utf8::encode $path;
1331 aio_open $path, O_RDONLY, 0 1320 aio_open $path, O_RDONLY, 0
1332 or return; 1321 or return;
1333 1322
1334 my $map = cf::map::new 1323 my $map = cf::map::new
1335 or return; 1324 or return;
1336 1325
1337 # for better error messages only, will be overwritten 1326 # for better error messages only, will be overwritten later
1338 $map->path ($path); 1327 $map->path ($path);
1339 1328
1340 $map->load_header ($path) 1329 $map->load_header ($path)
1341 or return; 1330 or return;
1342 1331
… …
1358 1347
1359 $cf::MAP{$key} || do { 1348 $cf::MAP{$key} || do {
1360 my $guard = cf::lock_acquire "map_find:$key"; 1349 my $guard = cf::lock_acquire "map_find:$key";
1361 1350
1362 # do it the slow way 1351 # do it the slow way
1363 my $map = try_load_header $path->save_path; 1352 my $map = $path->load_temp;
1364 1353
1365 Coro::cede; 1354 Coro::cede;
1366 1355
1367 if ($map) { 1356 if ($map) {
1368 $map->last_access ((delete $map->{last_access}) 1357 $map->last_access ((delete $map->{last_access})
1369 || $cf::RUNTIME); #d# 1358 || $cf::RUNTIME); #d#
1370 # safety 1359 # safety
1371 $map->{instantiate_time} = $cf::RUNTIME 1360 $map->{instantiate_time} = $cf::RUNTIME
1372 if $map->{instantiate_time} > $cf::RUNTIME; 1361 if $map->{instantiate_time} > $cf::RUNTIME;
1373 } else { 1362 } else {
1374 if (my $rmp = $path->random_map_params) { 1363 $map = $path->load_orig
1375 $map = generate_random_map $key, $rmp;
1376 } else {
1377 $map = try_load_header $path->load_path;
1378 }
1379
1380 $map or return; 1364 or return;
1381 1365
1382 $map->{load_original} = 1; 1366 $map->{load_original} = 1;
1383 $map->{instantiate_time} = $cf::RUNTIME; 1367 $map->{instantiate_time} = $cf::RUNTIME;
1384 $map->last_access ($cf::RUNTIME); 1368 $map->last_access ($cf::RUNTIME);
1385 $map->instantiate; 1369 $map->instantiate;
… …
1437 1421
1438 if ($self->{path}->is_style_map) { 1422 if ($self->{path}->is_style_map) {
1439 $self->{deny_save} = 1; 1423 $self->{deny_save} = 1;
1440 $self->{deny_reset} = 1; 1424 $self->{deny_reset} = 1;
1441 } else { 1425 } else {
1426 $self->decay_objects;
1442 $self->fix_auto_apply; 1427 $self->fix_auto_apply;
1443 $self->decay_objects;
1444 $self->update_buttons; 1428 $self->update_buttons;
1445 $self->set_darkness_map; 1429 $self->set_darkness_map;
1446 $self->difficulty ($self->estimate_difficulty) 1430 $self->difficulty ($self->estimate_difficulty)
1447 unless $self->difficulty; 1431 unless $self->difficulty;
1448 $self->activate; 1432 $self->activate;
… …
1451 Coro::cede; 1435 Coro::cede;
1452 1436
1453 $self->in_memory (cf::MAP_IN_MEMORY); 1437 $self->in_memory (cf::MAP_IN_MEMORY);
1454} 1438}
1455 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
1456sub find_sync { 1464sub find_sync {
1457 my ($path, $origin) = @_; 1465 my ($path, $origin) = @_;
1458 1466
1459 cf::sync_job { cf::map::find $path, $origin } 1467 cf::sync_job { find $path, $origin }
1460} 1468}
1461 1469
1462sub do_load_sync { 1470sub do_load_sync {
1463 my ($map) = @_; 1471 my ($map) = @_;
1464 1472
1465 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 ()
1466} 1506}
1467 1507
1468sub save { 1508sub save {
1469 my ($self) = @_; 1509 my ($self) = @_;
1470 1510
… …
1528 my ($self) = @_; 1568 my ($self) = @_;
1529 1569
1530 $self->reset_at <= $cf::RUNTIME 1570 $self->reset_at <= $cf::RUNTIME
1531} 1571}
1532 1572
1533sub unlink_save {
1534 my ($self) = @_;
1535
1536 utf8::encode (my $save = $self->{path}->save_path);
1537 aioreq_pri 3; IO::AIO::aio_unlink $save;
1538 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1539}
1540
1541sub rename { 1573sub rename {
1542 my ($self, $new_path) = @_; 1574 my ($self, $new_path) = @_;
1543 1575
1544 $self->unlink_save; 1576 $self->{path}->unlink_save;
1545 1577
1546 delete $cf::MAP{$self->path}; 1578 delete $cf::MAP{$self->path};
1547 $self->{path} = new cf::path $new_path; 1579 $self->{path} = new cf::path $new_path;
1548 $self->path ($self->{path}->as_string); 1580 $self->path ($self->{path}->as_string);
1549 $cf::MAP{$self->path} = $self; 1581 $cf::MAP{$self->path} = $self;
… …
1563 1595
1564 delete $cf::MAP{$self->path}; 1596 delete $cf::MAP{$self->path};
1565 1597
1566 $_->clear_links_to ($self) for values %cf::MAP; 1598 $_->clear_links_to ($self) for values %cf::MAP;
1567 1599
1568 $self->unlink_save; 1600 $self->{path}->unlink_save;
1569 $self->destroy; 1601 $self->destroy;
1570} 1602}
1571 1603
1572my $nuke_counter = "aaaa"; 1604my $nuke_counter = "aaaa";
1573 1605
… …
1578 $self->reset_timeout (1); 1610 $self->reset_timeout (1);
1579 $self->rename ("{nuke}/" . ($nuke_counter++)); 1611 $self->rename ("{nuke}/" . ($nuke_counter++));
1580 $self->reset; # polite request, might not happen 1612 $self->reset; # polite request, might not happen
1581} 1613}
1582 1614
1583sub customise_for { 1615=item cf::map::unique_maps
1584 my ($map, $ob) = @_;
1585 1616
1586 if ($map->per_player) { 1617Returns an arrayref of cf::path's of all shared maps that have
1587 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1618instantiated unique items. May block.
1588 }
1589 1619
1590 $map 1620=cut
1591}
1592 1621
1593sub emergency_save { 1622sub unique_maps() {
1594 my $freeze_guard = cf::freeze_mainloop; 1623 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1624 or return;
1595 1625
1596 warn "enter emergency perl save\n"; 1626 my @paths;
1597 1627
1598 cf::sync_job { 1628 for (@$files) {
1599 warn "begin emergency player save\n"; 1629 utf8::decode $_;
1600 $_->save for values %cf::PLAYER; 1630 next if /\.pst$/;
1601 warn "end emergency player save\n"; 1631 next unless /^$PATH_SEP/o;
1602 1632
1603 warn "begin emergency map save\n"; 1633 push @paths, new cf::path $_;
1604 $_->save for values %cf::MAP;
1605 warn "end emergency map save\n";
1606 }; 1634 }
1607 1635
1608 warn "leave emergency perl save\n"; 1636 \@paths
1609} 1637}
1610 1638
1611package cf; 1639package cf;
1612 1640
1613=back 1641=back
1614 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
1615 1669
1616=head3 cf::object::player 1670=head3 cf::object::player
1617 1671
1618=over 4 1672=over 4
1619 1673
… …
1711 # use -1 or undef as default coordinates, not 0, 0 1765 # use -1 or undef as default coordinates, not 0, 0
1712 ($x, $y) = ($map->enter_x, $map->enter_y) 1766 ($x, $y) = ($map->enter_x, $map->enter_y)
1713 if $x <=0 && $y <= 0; 1767 if $x <=0 && $y <= 0;
1714 1768
1715 $map->load; 1769 $map->load;
1770 $map->load_diag;
1716 1771
1717 return unless $self->contr->active; 1772 return unless $self->contr->active;
1718 $self->activate_recursive; 1773 $self->activate_recursive;
1719 $self->enter_map ($map, $x, $y); 1774 $self->enter_map ($map, $x, $y);
1720} 1775}
… …
1757 1812
1758sub cf::object::player::goto { 1813sub cf::object::player::goto {
1759 my ($self, $path, $x, $y) = @_; 1814 my ($self, $path, $x, $y) = @_;
1760 1815
1761 $path = new cf::path $path; 1816 $path = new cf::path $path;
1762 $path ne "/" or Carp::cluck ("oy");#d#
1763 1817
1764 $self->enter_link; 1818 $self->enter_link;
1765 1819
1766 (async { 1820 (async {
1767 my $map = cf::map::find $path->as_string; 1821 my $map = cf::map::find $path->as_string;
1768 $map = $map->customise_for ($self) if $map; 1822 $map = $map->{path}->customise_for ($map, $self) if $map;
1769 1823
1770# warn "entering ", $map->path, " at ($x, $y)\n" 1824# warn "entering ", $map->path, " at ($x, $y)\n"
1771# if $map; 1825# if $map;
1772 1826
1773 $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);
… …
1844 1898
1845 1; 1899 1;
1846 }) { 1900 }) {
1847 $self->message ("Something went wrong deep within the crossfire server. " 1901 $self->message ("Something went wrong deep within the crossfire server. "
1848 . "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. "
1849 . "Please report this to the dungeon master", 1903 . "Please report this to the dungeon master!",
1850 cf::NDI_UNIQUE | cf::NDI_RED); 1904 cf::NDI_UNIQUE | cf::NDI_RED);
1851 1905
1852 warn "ERROR in enter_exit: $@"; 1906 warn "ERROR in enter_exit: $@";
1853 $self->leave_link; 1907 $self->leave_link;
1854 } 1908 }
… …
2207 load_extensions; 2261 load_extensions;
2208 Event::loop; 2262 Event::loop;
2209} 2263}
2210 2264
2211############################################################################# 2265#############################################################################
2212# 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}
2213 2309
2214sub reload() { 2310sub reload() {
2215 # can/must only be called in main 2311 # can/must only be called in main
2216 if ($Coro::current != $Coro::main) { 2312 if ($Coro::current != $Coro::main) {
2217 warn "can only reload from main coroutine\n"; 2313 warn "can only reload from main coroutine\n";
2218 return; 2314 return;
2219 } 2315 }
2220 2316
2221 warn "reloading..."; 2317 warn "reloading...";
2222 2318
2319 warn "freezing server";
2223 my $guard = freeze_mainloop; 2320 my $guard = freeze_mainloop;
2224 cf::emergency_save; 2321 cf::emergency_save;
2225 2322
2323 warn "sync database to disk";
2324 cf::db_sync;
2325 IO::AIO::flush;
2326
2226 eval { 2327 eval {
2227 # 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
2228 2329
2229 # cancel all watchers 2330 warn "cancel all watchers";
2230 for (Event::all_watchers) { 2331 for (Event::all_watchers) {
2231 $_->cancel if $_->data & WF_AUTOCANCEL; 2332 $_->cancel if $_->data & WF_AUTOCANCEL;
2232 } 2333 }
2233 2334
2234 # cancel all extension coros 2335 warn "cancel all extension coros";
2235 $_->cancel for values %EXT_CORO; 2336 $_->cancel for values %EXT_CORO;
2236 %EXT_CORO = (); 2337 %EXT_CORO = ();
2237 2338
2339 warn "remove commands";
2340 %COMMAND = ();
2341
2342 warn "remove ext commands";
2343 %EXTCMD = ();
2344
2238 # unload all extensions 2345 warn "unload/nuke all extensions";
2239 for (@exts) { 2346 for my $pkg (@EXTS) {
2240 warn "unloading <$_>"; 2347 warn "... unloading $pkg";
2241 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: $@";
2242 } 2354 }
2243 2355
2356 warn "... nuking $pkg";
2357 Symbol::delete_package $pkg;
2358 }
2359
2244 # unload all modules loaded from $LIBDIR 2360 warn "unload all perl modules loaded from $LIBDIR";
2245 while (my ($k, $v) = each %INC) { 2361 while (my ($k, $v) = each %INC) {
2246 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2362 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2247 2363
2248 warn "removing <$k>"; 2364 warn "removing <$k>";
2249 delete $INC{$k}; 2365 delete $INC{$k};
… …
2256 } 2372 }
2257 2373
2258 Symbol::delete_package $k; 2374 Symbol::delete_package $k;
2259 } 2375 }
2260 2376
2261 # sync database to disk
2262 cf::db_sync;
2263 IO::AIO::flush;
2264
2265 # get rid of safe::, as good as possible 2377 warn "get rid of safe::, as good as possible";
2266 Symbol::delete_package "safe::$_" 2378 Symbol::delete_package "safe::$_"
2267 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);
2268 2380
2269 # remove register_script_function callbacks
2270 # TODO
2271
2272 # unload cf.pm "a bit" 2381 warn "unload cf.pm \"a bit\"";
2273 delete $INC{"cf.pm"}; 2382 delete $INC{"cf.pm"};
2274 2383
2275 # don't, removes xs symbols, too, 2384 # don't, removes xs symbols, too,
2276 # and global variables created in xs 2385 # and global variables created in xs
2277 #Symbol::delete_package __PACKAGE__; 2386 #Symbol::delete_package __PACKAGE__;
2278 2387
2279 # reload cf.pm
2280 warn "reloading cf.pm"; 2388 warn "reloading cf.pm";
2281 require cf; 2389 require cf;
2282 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2390 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2283 2391
2284 # load config and database again 2392 warn "load config and database again";
2285 cf::cfg_load; 2393 cf::cfg_load;
2286 cf::db_load; 2394 cf::db_load;
2287 2395
2288 # load extensions
2289 warn "load extensions"; 2396 warn "load extensions";
2290 cf::load_extensions; 2397 cf::load_extensions;
2291 2398
2292 # reattach attachments to objects 2399 warn "reattach attachments to objects/players";
2293 warn "reattach";
2294 _global_reattach; 2400 _global_reattach;
2401 warn "reattach attachments to maps";
2295 reattach $_ for values %MAP; 2402 reattach $_ for values %MAP;
2296 }; 2403 };
2297 2404
2298 if ($@) { 2405 if ($@) {
2299 warn $@; 2406 warn $@;
2300 warn "error while reloading, exiting."; 2407 warn "error while reloading, exiting.";
2301 exit 1; 2408 exit 1;
2302 } 2409 }
2303 2410
2304 warn "reloaded successfully"; 2411 warn "reloaded";
2305}; 2412};
2306 2413
2307############################################################################# 2414#############################################################################
2308 2415
2309unless ($LINK_MAP) { 2416unless ($LINK_MAP) {
… …
2345 $LINK_MAP->{deny_reset} = 1; 2452 $LINK_MAP->{deny_reset} = 1;
2346 2453
2347 $cf::MAP{$LINK_MAP->path} = $LINK_MAP; 2454 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2348} 2455}
2349 2456
2350register "<global>", __PACKAGE__;
2351
2352register_command "reload" => sub { 2457register_command "reload" => sub {
2353 my ($who, $arg) = @_; 2458 my ($who, $arg) = @_;
2354 2459
2355 if ($who->flag (FLAG_WIZ)) { 2460 if ($who->flag (FLAG_WIZ)) {
2356 $who->message ("start of reload."); 2461 $who->message ("start of reload.");
… …
2365 reentrant => 0, 2470 reentrant => 0,
2366 prio => 0, 2471 prio => 0,
2367 at => $NEXT_TICK || $TICK, 2472 at => $NEXT_TICK || $TICK,
2368 data => WF_AUTOCANCEL, 2473 data => WF_AUTOCANCEL,
2369 cb => sub { 2474 cb => sub {
2475 $NOW = Event::time;
2476
2370 cf::server_tick; # one server iteration 2477 cf::server_tick; # one server iteration
2371 $RUNTIME += $TICK; 2478 $RUNTIME += $TICK;
2372 $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;
2373 2483
2374 # 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
2375 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2485 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2376 2486
2377 $TICK_WATCHER->at ($NEXT_TICK); 2487 $TICK_WATCHER->at ($NEXT_TICK);

Diff Legend

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