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.169 by root, Sun Jan 14 01:09:46 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;
44our $TICK_WATCHER; 48our $TICK_WATCHER;
49our $AIO_POLL_WATCHER;
50our $WRITE_RUNTIME_WATCHER;
45our $NEXT_TICK; 51our $NEXT_TICK;
46our $NOW; 52our $NOW;
47 53
48our %CFG; 54our %CFG;
49 55
50our $UPTIME; $UPTIME ||= time; 56our $UPTIME; $UPTIME ||= time;
51our $RUNTIME; 57our $RUNTIME;
52 58
53our %PLAYER; # all users 59our %PLAYER; # all users
54our %MAP; # all maps 60our %MAP; # all maps
55our $LINK_MAP; # the special {link} map 61our $LINK_MAP; # the special {link} map, which is always available
56our $RANDOM_MAPS = cf::localdir . "/random"; 62our $RANDOM_MAPS = cf::localdir . "/random";
57our %EXT_CORO; # coroutines bound to extensions 63
64our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
65our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
66
67# used to convert map paths into valid unix filenames by replacing / by ∕
68our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
58 69
59binmode STDOUT; 70binmode STDOUT;
60binmode STDERR; 71binmode STDERR;
61 72
62# read virtual server time, if available 73# read virtual server time, if available
… …
70mkdir cf::localdir . "/" . cf::playerdir; 81mkdir cf::localdir . "/" . cf::playerdir;
71mkdir cf::localdir . "/" . cf::tmpdir; 82mkdir cf::localdir . "/" . cf::tmpdir;
72mkdir cf::localdir . "/" . cf::uniquedir; 83mkdir cf::localdir . "/" . cf::uniquedir;
73mkdir $RANDOM_MAPS; 84mkdir $RANDOM_MAPS;
74 85
75# a special map that is always available
76our $LINK_MAP;
77our $EMERGENCY_POSITION; 86our $EMERGENCY_POSITION;
78 87
79############################################################################# 88#############################################################################
80 89
81=head2 GLOBAL VARIABLES 90=head2 GLOBAL VARIABLES
… …
106 115
107=item %cf::CFG 116=item %cf::CFG
108 117
109Configuration for the server, loaded from C</etc/crossfire/config>, or 118Configuration for the server, loaded from C</etc/crossfire/config>, or
110from wherever your confdir points to. 119from wherever your confdir points to.
120
121=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
122
123These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
124or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
125processing has been done. Call C<< ->wait >> on them to maximise the
126window of cpu time available, or simply to synchronise to the server tick.
111 127
112=back 128=back
113 129
114=cut 130=cut
115 131
… …
146} 162}
147 163
148$Event::DIED = sub { 164$Event::DIED = sub {
149 warn "error in event callback: @_"; 165 warn "error in event callback: @_";
150}; 166};
151
152my %ext_pkg;
153my @exts;
154my @hook;
155 167
156=head2 UTILITY FUNCTIONS 168=head2 UTILITY FUNCTIONS
157 169
158=over 4 170=over 4
159 171
… …
247} 259}
248 260
249sub freeze_mainloop { 261sub freeze_mainloop {
250 return unless $TICK_WATCHER->is_active; 262 return unless $TICK_WATCHER->is_active;
251 263
252 my $guard = Coro::guard { $TICK_WATCHER->start }; 264 my $guard = Coro::guard {
265 $TICK_WATCHER->start;
266 $WRITE_RUNTIME_WATCHER->start;
267 };
268 $WRITE_RUNTIME_WATCHER->stop;
253 $TICK_WATCHER->stop; 269 $TICK_WATCHER->stop;
254 $guard 270 $guard
255} 271}
256 272
257=item cf::async { BLOCK } 273=item cf::async { BLOCK }
… …
309 } 325 }
310} 326}
311 327
312=item $coro = cf::async_ext { BLOCK } 328=item $coro = cf::async_ext { BLOCK }
313 329
314Like async, but this coro is automcatially being canceled when the 330Like async, but this coro is automatically being canceled when the
315extension calling this is being unloaded. 331extension calling this is being unloaded.
316 332
317=cut 333=cut
318 334
319sub async_ext(&) { 335sub async_ext(&) {
… …
352} 368}
353 369
354=back 370=back
355 371
356=cut 372=cut
357
358#############################################################################
359
360package cf::path;
361
362# used to convert map paths into valid unix filenames by repalcing / by ∕
363our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
364
365sub new {
366 my ($class, $path, $base) = @_;
367
368 $path = $path->as_string if ref $path;
369
370 my $self = bless { }, $class;
371
372 # {... are special paths that are not touched
373 # ?xxx/... are special absolute paths
374 # ?random/... random maps
375 # /! non-realised random map exit
376 # /... normal maps
377 # ~/... per-player maps without a specific player (DO NOT USE)
378 # ~user/... per-player map of a specific user
379
380 if ($path =~ /^{/) {
381 # 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 {
386 if ($path =~ s{^~([^/]+)?}{}) {
387 $self->{user_rel} = 1;
388
389 if (defined $1) {
390 $self->{user} = $1;
391 } elsif ($base =~ m{^~([^/]+)/}) {
392 $self->{user} = $1;
393 } else {
394 warn "cannot resolve user-relative path without user <$path,$base>\n";
395 }
396 } elsif ($path =~ /^\//) {
397 # already absolute
398 } else {
399 $base =~ s{[^/]+/?$}{};
400 return $class->new ("$base/$path");
401 }
402
403 for ($path) {
404 redo if s{/\.?/}{/};
405 redo if s{/[^/]+/\.\./}{/};
406 }
407 }
408
409 $self->{path} = $path;
410
411 $self
412}
413
414# the name / primary key / in-game path
415sub as_string {
416 my ($self) = @_;
417
418 $self->{user_rel} ? "~$self->{user}$self->{path}"
419 : $self->{random} ? "?random/$self->{path}"
420 : $self->{path}
421}
422
423# the displayed name, this is a one way mapping
424sub visible_name {
425 my ($self) = @_;
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}
434
435# escape the /'s in the path
436sub _escaped_path {
437 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
438 $path
439}
440
441# the original (read-only) location
442sub load_path {
443 my ($self) = @_;
444
445 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
446}
447
448# the temporary/swap location
449sub save_path {
450 my ($self) = @_;
451
452 $self->{user_rel} ? 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
455}
456
457# the unique path, might be eq to save_path
458sub uniq_path {
459 my ($self) = @_;
460
461 $self->{user_rel} || $self->{random}
462 ? undef
463 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
464}
465
466# return random map parameters, or undef
467sub random_map_params {
468 my ($self) = @_;
469
470 $self->{random}
471}
472
473# this is somewhat ugly, but style maps do need special treatment
474sub is_style_map {
475 $_[0]{path} =~ m{^/styles/}
476}
477
478package cf;
479 373
480############################################################################# 374#############################################################################
481 375
482=head2 ATTACHABLE OBJECTS 376=head2 ATTACHABLE OBJECTS
483 377
… …
789# object support 683# object support
790 684
791sub reattach { 685sub reattach {
792 # basically do the same as instantiate, without calling instantiate 686 # basically do the same as instantiate, without calling instantiate
793 my ($obj) = @_; 687 my ($obj) = @_;
688
689 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
794 690
795 my $registry = $obj->registry; 691 my $registry = $obj->registry;
796 692
797 @$registry = (); 693 @$registry = ();
798 694
… …
930=cut 826=cut
931 827
932sub register_extcmd { 828sub register_extcmd {
933 my ($name, $cb) = @_; 829 my ($name, $cb) = @_;
934 830
935 my $caller = caller;
936 #warn "registering extcmd '$name' to '$caller'";
937
938 $EXTCMD{$name} = [$cb, $caller]; 831 $EXTCMD{$name} = $cb;
939} 832}
940 833
941cf::player->attach ( 834cf::player->attach (
942 on_command => sub { 835 on_command => sub {
943 my ($pl, $name, $params) = @_; 836 my ($pl, $name, $params) = @_;
… …
956 849
957 my $msg = eval { from_json $buf }; 850 my $msg = eval { from_json $buf };
958 851
959 if (ref $msg) { 852 if (ref $msg) {
960 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 853 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
961 if (my %reply = $cb->[0]->($pl, $msg)) { 854 if (my %reply = $cb->($pl, $msg)) {
962 $pl->ext_reply ($msg->{msgid}, %reply); 855 $pl->ext_reply ($msg->{msgid}, %reply);
963 } 856 }
964 } 857 }
965 } else { 858 } else {
966 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 859 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
968 861
969 cf::override; 862 cf::override;
970 }, 863 },
971); 864);
972 865
973sub register {
974 my ($base, $pkg) = @_;
975
976 #TODO
977}
978
979sub load_extension { 866sub load_extension {
980 my ($path) = @_; 867 my ($path) = @_;
981 868
982 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 869 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
983 my $base = $1; 870 my $base = $1;
984 my $pkg = $1; 871 my $pkg = $1;
985 $pkg =~ s/[^[:word:]]/_/g; 872 $pkg =~ s/[^[:word:]]/_/g;
986 $pkg = "ext::$pkg"; 873 $pkg = "ext::$pkg";
987 874
988 warn "loading '$path' into '$pkg'\n"; 875 warn "... loading '$path' into '$pkg'\n";
989 876
990 open my $fh, "<:utf8", $path 877 open my $fh, "<:utf8", $path
991 or die "$path: $!"; 878 or die "$path: $!";
992 879
993 my $source = 880 my $source =
994 "package $pkg; use strict; use utf8;\n" 881 "package $pkg; use strict; use utf8;\n"
995 . "#line 1 \"$path\"\n{\n" 882 . "#line 1 \"$path\"\n{\n"
996 . (do { local $/; <$fh> }) 883 . (do { local $/; <$fh> })
997 . "\n};\n1"; 884 . "\n};\n1";
998 885
999 eval $source 886 unless (eval $source) {
1000 or die $@ ? "$path: $@\n" 887 my $msg = $@ ? "$path: $@\n"
1001 : "extension disabled.\n"; 888 : "extension disabled.\n";
1002 889 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
1003 push @exts, $pkg; 890 warn $@;
1004 $ext_pkg{$base} = $pkg; 891 warn "mandatory extension failed to load, exiting.\n";
1005 892 exit 1;
1006# no strict 'refs'; 893 }
1007# @{"$pkg\::ISA"} = ext::; 894 die $@;
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# } 895 }
1022 896
1023 # remove commands 897 push @EXTS, $pkg;
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} 898}
1048 899
1049sub load_extensions { 900sub load_extensions {
1050 for my $ext (<$LIBDIR/*.ext>) { 901 for my $ext (<$LIBDIR/*.ext>) {
1051 next unless -r $ext; 902 next unless -r $ext;
… …
1055 } or warn "$ext not loaded: $@"; 906 } or warn "$ext not loaded: $@";
1056 } 907 }
1057} 908}
1058 909
1059############################################################################# 910#############################################################################
1060# load/save/clean perl data associated with a map
1061
1062*cf::mapsupport::on_clean = sub {
1063 my ($map) = @_;
1064
1065 my $path = $map->tmpname;
1066 defined $path or return;
1067
1068 unlink "$path.pst";
1069};
1070
1071cf::map->attach (prio => -10000, package => cf::mapsupport::);
1072
1073#############################################################################
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 911
1097=head2 CORE EXTENSIONS 912=head2 CORE EXTENSIONS
1098 913
1099Functions and methods that extend core crossfire objects. 914Functions and methods that extend core crossfire objects.
1100 915
… …
1225 my @logins; 1040 my @logins;
1226 1041
1227 for my $login (@$dirs) { 1042 for my $login (@$dirs) {
1228 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1043 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1229 aio_read $fh, 0, 512, my $buf, 0 or next; 1044 aio_read $fh, 0, 512, my $buf, 0 or next;
1230 $buf !~ /^password -------------$/ or next; # official not-valid tag 1045 $buf !~ /^password -------------$/m or next; # official not-valid tag
1231 1046
1232 utf8::decode $login; 1047 utf8::decode $login;
1233 push @logins, $login; 1048 push @logins, $login;
1234 } 1049 }
1235 1050
1236 \@logins 1051 \@logins
1237} 1052}
1238 1053
1239=item $player->maps 1054=item $player->maps
1240 1055
1241Returns an arrayref of cf::path's of all maps that are private for this 1056Returns an arrayref of map paths that are private for this
1242player. May block. 1057player. May block.
1243 1058
1244=cut 1059=cut
1245 1060
1246sub maps($) { 1061sub maps($) {
… …
1252 my @paths; 1067 my @paths;
1253 1068
1254 for (@$files) { 1069 for (@$files) {
1255 utf8::decode $_; 1070 utf8::decode $_;
1256 next if /\.(?:pl|pst)$/; 1071 next if /\.(?:pl|pst)$/;
1257 next unless /^$PATH_SEP/; 1072 next unless /^$PATH_SEP/o;
1258 1073
1259 s/$PATH_SEP/\//g; 1074 s/\.map$//;
1260 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_; 1075 push @paths, "~" . $pl->ob->name . "/" . $_;
1261 } 1076 }
1262 1077
1263 \@paths 1078 \@paths
1264} 1079}
1265 1080
… …
1291package cf::map; 1106package cf::map;
1292 1107
1293use Fcntl; 1108use Fcntl;
1294use Coro::AIO; 1109use Coro::AIO;
1295 1110
1111use overload
1112 '""' => \&as_string;
1113
1296our $MAX_RESET = 3600; 1114our $MAX_RESET = 3600;
1297our $DEFAULT_RESET = 3000; 1115our $DEFAULT_RESET = 3000;
1298 1116
1299sub generate_random_map { 1117sub generate_random_map {
1300 my ($path, $rmp) = @_; 1118 my ($self, $rmp) = @_;
1301 1119
1302 # mit "rum" bekleckern, nicht 1120 # mit "rum" bekleckern, nicht
1303 cf::map::_create_random_map 1121 $self->_create_random_map (
1304 $path,
1305 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1122 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1306 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1123 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1307 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1124 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1308 $rmp->{exit_on_final_map}, 1125 $rmp->{exit_on_final_map},
1309 $rmp->{xsize}, $rmp->{ysize}, 1126 $rmp->{xsize}, $rmp->{ysize},
1310 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1127 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1311 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1128 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1312 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1129 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1313 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1130 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1314 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1131 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1315 (cf::region::find $rmp->{region}) 1132 (cf::region::find $rmp->{region}), $rmp->{custom}
1133 )
1134}
1135
1136sub register {
1137 my (undef, $regex) = @_;
1138 my $pkg = caller;
1139
1140 no strict;
1141 push @{"$pkg\::ISA"}, __PACKAGE__;
1142
1143 $EXT_MAP{$pkg} = qr<$regex>;
1144}
1145
1146# also paths starting with '/'
1147$EXT_MAP{"cf::map"} = qr{^(?=/)};
1148
1149sub normalise {
1150 my ($path, $base) = @_;
1151
1152 # map plan:
1153 #
1154 # /! non-realised random map exit (special hack!)
1155 # {... are special paths that are not being touched
1156 # ?xxx/... are special absolute paths
1157 # ?random/... random maps
1158 # /... normal maps
1159 # ~user/... per-player map of a specific user
1160
1161 $path =~ s/$PATH_SEP/\//go;
1162
1163 # treat it as relative path if it starts with
1164 # something that looks reasonable
1165 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1166 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1167
1168 $base =~ s{[^/]+/?$}{};
1169 $path = "$base/$path";
1170 }
1171
1172 for ($path) {
1173 redo if s{//}{/};
1174 redo if s{/\.?/}{/};
1175 redo if s{/[^/]+/\.\./}{/};
1176 }
1177
1178 $path
1179}
1180
1181sub new_from_path {
1182 my (undef, $path, $base) = @_;
1183
1184 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1185
1186 $path = normalise $path, $base;
1187
1188 for my $pkg (keys %EXT_MAP) {
1189 if ($path =~ $EXT_MAP{$pkg}) {
1190 my $self = bless cf::map::new, $pkg;
1191 $self->{path} = $path; $self->path ($path);
1192 $self->init; # pass $1 etc.
1193 return $self;
1194 }
1195 }
1196
1197 Carp::carp "unable to resolve path '$path'.";
1198 ()
1199}
1200
1201sub init {
1202 my ($self) = @_;
1203
1204 $self
1205}
1206
1207sub as_string {
1208 my ($self) = @_;
1209
1210 "$self->{path}"
1211}
1212
1213# the displayed name, this is a one way mapping
1214sub visible_name {
1215 &as_string
1216}
1217
1218# the original (read-only) location
1219sub load_path {
1220 my ($self) = @_;
1221
1222 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
1223}
1224
1225# the temporary/swap location
1226sub save_path {
1227 my ($self) = @_;
1228
1229 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1230 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path
1231}
1232
1233# the unique path, undef == no special unique path
1234sub uniq_path {
1235 my ($self) = @_;
1236
1237 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1238 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path
1316} 1239}
1317 1240
1318# and all this just because we cannot iterate over 1241# and all this just because we cannot iterate over
1319# all maps in C++... 1242# all maps in C++...
1320sub change_all_map_light { 1243sub change_all_map_light {
… …
1322 1245
1323 $_->change_map_light ($change) 1246 $_->change_map_light ($change)
1324 for grep $_->outdoor, values %cf::MAP; 1247 for grep $_->outdoor, values %cf::MAP;
1325} 1248}
1326 1249
1250sub unlink_save {
1251 my ($self) = @_;
1252
1253 utf8::encode (my $save = $self->save_path);
1254 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save;
1255 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst";
1256}
1257
1327sub try_load_header($) { 1258sub load_header_from($) {
1328 my ($path) = @_; 1259 my ($self, $path) = @_;
1329 1260
1330 utf8::encode $path; 1261 utf8::encode $path;
1331 aio_open $path, O_RDONLY, 0 1262 aio_open $path, O_RDONLY, 0
1332 or return; 1263 or return;
1333 1264
1334 my $map = cf::map::new 1265 $self->_load_header ($path)
1335 or return; 1266 or return;
1336 1267
1337 # for better error messages only, will be overwritten 1268 $self->{load_path} = $path;
1338 $map->path ($path);
1339 1269
1340 $map->load_header ($path) 1270 1
1271}
1272
1273sub load_orig {
1274 my ($self) = @_;
1275
1276 $self->load_header_from ($self->load_path)
1277}
1278
1279sub load_temp {
1280 my ($self) = @_;
1281
1282 $self->load_header_from ($self->save_path)
1283}
1284
1285sub load_header {
1286 my ($self) = @_;
1287
1288 if ($self->load_temp) {
1289 $self->last_access ((delete $self->{last_access})
1290 || $cf::RUNTIME); #d#
1291 # safety
1292 $self->{instantiate_time} = $cf::RUNTIME
1293 if $self->{instantiate_time} > $cf::RUNTIME;
1294 } else {
1295 $self->load_orig
1341 or return; 1296 or return;
1342 1297
1343 $map->{load_path} = $path; 1298 $self->{load_original} = 1;
1299 $self->{instantiate_time} = $cf::RUNTIME;
1300 $self->last_access ($cf::RUNTIME);
1301 $self->instantiate;
1302 }
1344 1303
1345 $map 1304 1
1346} 1305}
1347 1306
1348sub find; 1307sub find;
1349sub find { 1308sub find {
1350 my ($path, $origin) = @_; 1309 my ($path, $origin) = @_;
1351 1310
1352 #warn "find<$path,$origin>\n";#d#
1353
1354 $path = new cf::path $path, $origin && $origin->path; 1311 $path = normalise $path, $origin && $origin->path;
1355 my $key = $path->as_string;
1356 1312
1357 cf::lock_wait "map_find:$key"; 1313 cf::lock_wait "map_find:$path";
1358 1314
1359 $cf::MAP{$key} || do { 1315 $cf::MAP{$path} || do {
1360 my $guard = cf::lock_acquire "map_find:$key"; 1316 my $guard = cf::lock_acquire "map_find:$path";
1361 1317 my $map = new_from_path cf::map $path
1362 # do it the slow way
1363 my $map = try_load_header $path->save_path;
1364
1365 Coro::cede;
1366
1367 if ($map) {
1368 $map->last_access ((delete $map->{last_access})
1369 || $cf::RUNTIME); #d#
1370 # safety
1371 $map->{instantiate_time} = $cf::RUNTIME
1372 if $map->{instantiate_time} > $cf::RUNTIME;
1373 } else {
1374 if (my $rmp = $path->random_map_params) {
1375 $map = generate_random_map $key, $rmp;
1376 } else {
1377 $map = try_load_header $path->load_path;
1378 }
1379
1380 $map or return; 1318 or return;
1381 1319
1382 $map->{load_original} = 1;
1383 $map->{instantiate_time} = $cf::RUNTIME;
1384 $map->last_access ($cf::RUNTIME);
1385 $map->instantiate;
1386
1387 # per-player maps become, after loading, normal maps
1388 $map->per_player (0) if $path->{user_rel};
1389 }
1390
1391 $map->path ($key);
1392 $map->{path} = $path;
1393 $map->{last_save} = $cf::RUNTIME; 1320 $map->{last_save} = $cf::RUNTIME;
1394 1321
1395 Coro::cede; 1322 $map->load_header
1323 or return;
1396 1324
1397 if ($map->should_reset) { 1325 if ($map->should_reset) {
1398 $map->reset; 1326 $map->reset;
1399 undef $guard; 1327 undef $guard;
1400 $map = find $path 1328 $map = find $path
1401 or return; 1329 or return;
1402 } 1330 }
1403 1331
1404 $cf::MAP{$key} = $map 1332 $cf::MAP{$path} = $map
1405 } 1333 }
1406} 1334}
1407 1335
1408sub load { 1336sub load {
1409 my ($self) = @_; 1337 my ($self) = @_;
1410 1338
1411 my $path = $self->{path}; 1339 my $path = $self->{path};
1412 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1340 my $guard = cf::lock_acquire "map_load:$path";
1413 1341
1414 return if $self->in_memory != cf::MAP_SWAPPED; 1342 return if $self->in_memory != cf::MAP_SWAPPED;
1415 1343
1416 $self->in_memory (cf::MAP_LOADING); 1344 $self->in_memory (cf::MAP_LOADING);
1417 1345
1418 $self->alloc; 1346 $self->alloc;
1419 $self->load_objects ($self->{load_path}, 1) 1347 $self->_load_objects ($self->{load_path}, 1)
1420 or return; 1348 or return;
1421 1349
1422 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1350 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1423 if delete $self->{load_original}; 1351 if delete $self->{load_original};
1424 1352
1425 if (my $uniq = $path->uniq_path) { 1353 if (my $uniq = $self->uniq_path) {
1426 utf8::encode $uniq; 1354 utf8::encode $uniq;
1427 if (aio_open $uniq, O_RDONLY, 0) { 1355 if (aio_open $uniq, O_RDONLY, 0) {
1428 $self->clear_unique_items; 1356 $self->clear_unique_items;
1429 $self->load_objects ($uniq, 0); 1357 $self->_load_objects ($uniq, 0);
1430 } 1358 }
1431 } 1359 }
1432 1360
1433 Coro::cede; 1361 Coro::cede;
1434 1362
1435 # now do the right thing for maps 1363 # now do the right thing for maps
1436 $self->link_multipart_objects; 1364 $self->link_multipart_objects;
1437 1365
1438 if ($self->{path}->is_style_map) { 1366 unless ($self->{deny_activate}) {
1439 $self->{deny_save} = 1; 1367 $self->decay_objects;
1440 $self->{deny_reset} = 1;
1441 } else {
1442 $self->fix_auto_apply; 1368 $self->fix_auto_apply;
1443 $self->decay_objects;
1444 $self->update_buttons; 1369 $self->update_buttons;
1370 Coro::cede;
1445 $self->set_darkness_map; 1371 $self->set_darkness_map;
1446 $self->difficulty ($self->estimate_difficulty) 1372 $self->difficulty ($self->estimate_difficulty)
1447 unless $self->difficulty; 1373 unless $self->difficulty;
1374 Coro::cede;
1448 $self->activate; 1375 $self->activate;
1449 } 1376 }
1450 1377
1451 Coro::cede;
1452
1453 $self->in_memory (cf::MAP_IN_MEMORY); 1378 $self->in_memory (cf::MAP_IN_MEMORY);
1379}
1380
1381sub customise_for {
1382 my ($self, $ob) = @_;
1383
1384 return find "~" . $ob->name . "/" . $self->{path}
1385 if $self->per_player;
1386
1387 $self
1388}
1389
1390# find and load all maps in the 3x3 area around a map
1391sub load_diag {
1392 my ($map) = @_;
1393
1394 my @diag; # diagonal neighbours
1395
1396 for (0 .. 3) {
1397 my $neigh = $map->tile_path ($_)
1398 or next;
1399 $neigh = find $neigh, $map
1400 or next;
1401 $neigh->load;
1402
1403 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1404 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1405 }
1406
1407 for (@diag) {
1408 my $neigh = find @$_
1409 or next;
1410 $neigh->load;
1411 }
1454} 1412}
1455 1413
1456sub find_sync { 1414sub find_sync {
1457 my ($path, $origin) = @_; 1415 my ($path, $origin) = @_;
1458 1416
1459 cf::sync_job { cf::map::find $path, $origin } 1417 cf::sync_job { find $path, $origin }
1460} 1418}
1461 1419
1462sub do_load_sync { 1420sub do_load_sync {
1463 my ($map) = @_; 1421 my ($map) = @_;
1464 1422
1465 cf::sync_job { $map->load }; 1423 cf::sync_job { $map->load };
1466} 1424}
1467 1425
1426our %MAP_PREFETCH;
1427our $MAP_PREFETCHER = Coro::async {
1428 while () {
1429 for my $path (keys %MAP_PREFETCH) {
1430 my $map = find $path
1431 or next;
1432 $map->load;
1433
1434 delete $MAP_PREFETCH{$path};
1435 }
1436 Coro::schedule;
1437 }
1438};
1439
1440sub find_async {
1441 my ($path, $origin) = @_;
1442
1443 $path = normalise $path, $origin && $origin->{path};
1444
1445 if (my $map = $cf::MAP{$path}) {
1446 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1447 }
1448
1449 $MAP_PREFETCH{$path} = 0;
1450 $MAP_PREFETCHER->ready;
1451
1452 ()
1453}
1454
1468sub save { 1455sub save {
1469 my ($self) = @_; 1456 my ($self) = @_;
1470 1457
1471 my $lock = cf::lock_acquire "map_data:" . $self->path; 1458 my $lock = cf::lock_acquire "map_data:" . $self->path;
1472 1459
1473 $self->{last_save} = $cf::RUNTIME; 1460 $self->{last_save} = $cf::RUNTIME;
1474 1461
1475 return unless $self->dirty; 1462 return unless $self->dirty;
1476 1463
1477 my $save = $self->{path}->save_path; utf8::encode $save; 1464 my $save = $self->save_path; utf8::encode $save;
1478 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1465 my $uniq = $self->uniq_path; utf8::encode $uniq;
1479 1466
1480 $self->{load_path} = $save; 1467 $self->{load_path} = $save;
1481 1468
1482 return if $self->{deny_save}; 1469 return if $self->{deny_save};
1483 1470
… …
1486 cf::async { 1473 cf::async {
1487 $_->contr->save for $self->players; 1474 $_->contr->save for $self->players;
1488 }; 1475 };
1489 1476
1490 if ($uniq) { 1477 if ($uniq) {
1491 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1478 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1492 $self->save_objects ($uniq, cf::IO_UNIQUES); 1479 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1493 } else { 1480 } else {
1494 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 1481 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1495 } 1482 }
1496} 1483}
1497 1484
1498sub swap_out { 1485sub swap_out {
1499 my ($self) = @_; 1486 my ($self) = @_;
… …
1513 1500
1514sub reset_at { 1501sub reset_at {
1515 my ($self) = @_; 1502 my ($self) = @_;
1516 1503
1517 # TODO: safety, remove and allow resettable per-player maps 1504 # TODO: safety, remove and allow resettable per-player maps
1518 return 1e99 if $self->{path}{user_rel}; 1505 return 1e99 if $self->isa ("ext::map_per_player");#d#
1519 return 1e99 if $self->{deny_reset}; 1506 return 1e99 if $self->{deny_reset};
1520 1507
1521 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1508 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1522 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1509 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1523 1510
… …
1528 my ($self) = @_; 1515 my ($self) = @_;
1529 1516
1530 $self->reset_at <= $cf::RUNTIME 1517 $self->reset_at <= $cf::RUNTIME
1531} 1518}
1532 1519
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 { 1520sub rename {
1542 my ($self, $new_path) = @_; 1521 my ($self, $new_path) = @_;
1543 1522
1523 normalise $new_path;
1524
1544 $self->unlink_save; 1525 $self->unlink_save;
1545 1526
1546 delete $cf::MAP{$self->path}; 1527 delete $cf::MAP{$self->path};
1547 $self->{path} = new cf::path $new_path; 1528 $self->{path} = $new_path; $self->path ($self->{path});
1548 $self->path ($self->{path}->as_string);
1549 $cf::MAP{$self->path} = $self; 1529 $cf::MAP{$self->path} = $self;
1550 1530
1551 $self->save; 1531 $self->save;
1552} 1532}
1553 1533
1554sub reset { 1534sub reset {
1555 my ($self) = @_; 1535 my ($self) = @_;
1556 1536
1557 my $lock = cf::lock_acquire "map_data:" . $self->path; 1537 my $lock = cf::lock_acquire "map_data:$self->{path}";
1558 1538
1559 return if $self->players; 1539 return if $self->players;
1560 return if $self->{path}{user_rel};#d# 1540 return if $self->isa ("ext::map_per_player");#d#
1561 1541
1562 warn "resetting map ", $self->path;#d# 1542 warn "resetting map ", $self->path;#d#
1563 1543
1564 delete $cf::MAP{$self->path}; 1544 delete $cf::MAP{$self->path};
1545
1546 $self->in_memory (cf::MAP_SWAPPED);
1547 $self->clear;
1565 1548
1566 $_->clear_links_to ($self) for values %cf::MAP; 1549 $_->clear_links_to ($self) for values %cf::MAP;
1567 1550
1568 $self->unlink_save; 1551 $self->unlink_save;
1569 $self->destroy; 1552 $self->destroy;
… …
1578 $self->reset_timeout (1); 1561 $self->reset_timeout (1);
1579 $self->rename ("{nuke}/" . ($nuke_counter++)); 1562 $self->rename ("{nuke}/" . ($nuke_counter++));
1580 $self->reset; # polite request, might not happen 1563 $self->reset; # polite request, might not happen
1581} 1564}
1582 1565
1583sub customise_for { 1566=item cf::map::unique_maps
1584 my ($map, $ob) = @_;
1585 1567
1586 if ($map->per_player) { 1568Returns an arrayref of paths of all shared maps that have
1587 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1569instantiated unique items. May block.
1588 }
1589 1570
1590 $map 1571=cut
1591}
1592 1572
1593sub emergency_save { 1573sub unique_maps() {
1594 my $freeze_guard = cf::freeze_mainloop; 1574 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1575 or return;
1595 1576
1596 warn "enter emergency perl save\n"; 1577 my @paths;
1597 1578
1598 cf::sync_job { 1579 for (@$files) {
1599 warn "begin emergency player save\n"; 1580 utf8::decode $_;
1600 $_->save for values %cf::PLAYER; 1581 next if /\.pst$/;
1601 warn "end emergency player save\n"; 1582 next unless /^$PATH_SEP/o;
1602 1583
1603 warn "begin emergency map save\n"; 1584 s/\.map$//;
1604 $_->save for values %cf::MAP; 1585 push @paths, $_;
1605 warn "end emergency map save\n";
1606 }; 1586 }
1607 1587
1608 warn "leave emergency perl save\n"; 1588 \@paths
1609} 1589}
1610 1590
1611package cf; 1591package cf;
1612 1592
1613=back 1593=back
1614 1594
1595=head3 cf::object
1596
1597=cut
1598
1599package cf::object;
1600
1601=over 4
1602
1603=item $ob->inv_recursive
1604
1605Returns the inventory of the object _and_ their inventories, recursively.
1606
1607=cut
1608
1609sub inv_recursive_;
1610sub inv_recursive_ {
1611 map { $_, inv_recursive_ $_->inv } @_
1612}
1613
1614sub inv_recursive {
1615 inv_recursive_ inv $_[0]
1616}
1617
1618package cf;
1619
1620=back
1615 1621
1616=head3 cf::object::player 1622=head3 cf::object::player
1617 1623
1618=over 4 1624=over 4
1619 1625
… …
1659 1665
1660=item $player_object->enter_link 1666=item $player_object->enter_link
1661 1667
1662Freezes the player and moves him/her to a special map (C<{link}>). 1668Freezes the player and moves him/her to a special map (C<{link}>).
1663 1669
1664The player should be reaosnably safe there for short amounts of time. You 1670The player should be reasonably safe there for short amounts of time. You
1665I<MUST> call C<leave_link> as soon as possible, though. 1671I<MUST> call C<leave_link> as soon as possible, though.
1666 1672
1673Will never block.
1674
1667=item $player_object->leave_link ($map, $x, $y) 1675=item $player_object->leave_link ($map, $x, $y)
1668 1676
1669Moves the player out of the specila link map onto the given map. If the 1677Moves the player out of the special C<{link}> map onto the specified
1670map is not valid (or omitted), the player will be moved back to the 1678map. If the map is not valid (or omitted), the player will be moved back
1671location he/she was before the call to C<enter_link>, or, if that fails, 1679to the location he/she was before the call to C<enter_link>, or, if that
1672to the emergency map position. 1680fails, to the emergency map position.
1673 1681
1674Might block. 1682Might block.
1675 1683
1676=cut 1684=cut
1685
1686sub link_map {
1687 unless ($LINK_MAP) {
1688 $LINK_MAP = cf::map::find "{link}"
1689 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 };
1690 $LINK_MAP->load;
1691 }
1692
1693 $LINK_MAP
1694}
1677 1695
1678sub cf::object::player::enter_link { 1696sub cf::object::player::enter_link {
1679 my ($self) = @_; 1697 my ($self) = @_;
1680 1698
1681 $self->deactivate_recursive; 1699 $self->deactivate_recursive;
1682 1700
1683 return if $self->map == $LINK_MAP; 1701 return if UNIVERSAL::isa $self->map, "ext::map_link";
1684 1702
1685 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 1703 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1686 if $self->map; 1704 if $self->map;
1687 1705
1688 $self->enter_map ($LINK_MAP, 20, 20); 1706 $self->enter_map ($LINK_MAP || link_map, 20, 20);
1689} 1707}
1690 1708
1691sub cf::object::player::leave_link { 1709sub cf::object::player::leave_link {
1692 my ($self, $map, $x, $y) = @_; 1710 my ($self, $map, $x, $y) = @_;
1693 1711
… …
1711 # use -1 or undef as default coordinates, not 0, 0 1729 # use -1 or undef as default coordinates, not 0, 0
1712 ($x, $y) = ($map->enter_x, $map->enter_y) 1730 ($x, $y) = ($map->enter_x, $map->enter_y)
1713 if $x <=0 && $y <= 0; 1731 if $x <=0 && $y <= 0;
1714 1732
1715 $map->load; 1733 $map->load;
1734 $map->load_diag;
1716 1735
1717 return unless $self->contr->active; 1736 return unless $self->contr->active;
1718 $self->activate_recursive; 1737 $self->activate_recursive;
1719 $self->enter_map ($map, $x, $y); 1738 $self->enter_map ($map, $x, $y);
1720} 1739}
… …
1756=cut 1775=cut
1757 1776
1758sub cf::object::player::goto { 1777sub cf::object::player::goto {
1759 my ($self, $path, $x, $y) = @_; 1778 my ($self, $path, $x, $y) = @_;
1760 1779
1761 $path = new cf::path $path;
1762 $path ne "/" or Carp::cluck ("oy");#d#
1763
1764 $self->enter_link; 1780 $self->enter_link;
1765 1781
1766 (async { 1782 (async {
1767 my $map = cf::map::find $path->as_string; 1783 my $map = cf::map::find $path;
1768 $map = $map->customise_for ($self) if $map; 1784 $map = $map->customise_for ($self) if $map;
1769 1785
1770# warn "entering ", $map->path, " at ($x, $y)\n" 1786# warn "entering ", $map->path, " at ($x, $y)\n"
1771# if $map; 1787# if $map;
1772 1788
… …
1837 $self->deactivate_recursive; # just to be sure 1853 $self->deactivate_recursive; # just to be sure
1838 unless (eval { 1854 unless (eval {
1839 prepare_random_map $exit 1855 prepare_random_map $exit
1840 if $exit->slaying eq "/!"; 1856 if $exit->slaying eq "/!";
1841 1857
1842 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path; 1858 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1843 $self->goto ($path, $exit->stats->hp, $exit->stats->sp); 1859 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1844 1860
1845 1; 1861 1;
1846 }) { 1862 }) {
1847 $self->message ("Something went wrong deep within the crossfire server. " 1863 $self->message ("Something went wrong deep within the crossfire server. "
1848 . "I'll try to bring you back to the map you were before. " 1864 . "I'll try to bring you back to the map you were before. "
1849 . "Please report this to the dungeon master", 1865 . "Please report this to the dungeon master!",
1850 cf::NDI_UNIQUE | cf::NDI_RED); 1866 cf::NDI_UNIQUE | cf::NDI_RED);
1851 1867
1852 warn "ERROR in enter_exit: $@"; 1868 warn "ERROR in enter_exit: $@";
1853 $self->leave_link; 1869 $self->leave_link;
1854 } 1870 }
… …
2207 load_extensions; 2223 load_extensions;
2208 Event::loop; 2224 Event::loop;
2209} 2225}
2210 2226
2211############################################################################# 2227#############################################################################
2212# initialisation 2228# initialisation and cleanup
2229
2230# install some emergency cleanup handlers
2231BEGIN {
2232 for my $signal (qw(INT HUP TERM)) {
2233 Event->signal (
2234 data => WF_AUTOCANCEL,
2235 signal => $signal,
2236 cb => sub {
2237 cf::cleanup "SIG$signal";
2238 },
2239 );
2240 }
2241}
2242
2243sub emergency_save() {
2244 my $freeze_guard = cf::freeze_mainloop;
2245
2246 warn "enter emergency perl save\n";
2247
2248 cf::sync_job {
2249 # use a peculiar iteration method to avoid tripping on perl
2250 # refcount bugs in for. also avoids problems with players
2251 # and maps saved/destroyed asynchronously.
2252 warn "begin emergency player save\n";
2253 for my $login (keys %cf::PLAYER) {
2254 my $pl = $cf::PLAYER{$login} or next;
2255 $pl->valid or next;
2256 $pl->save;
2257 }
2258 warn "end emergency player save\n";
2259
2260 warn "begin emergency map save\n";
2261 for my $path (keys %cf::MAP) {
2262 my $map = $cf::MAP{$path} or next;
2263 $map->valid or next;
2264 $map->save;
2265 }
2266 warn "end emergency map save\n";
2267 };
2268
2269 warn "leave emergency perl save\n";
2270}
2213 2271
2214sub reload() { 2272sub reload() {
2215 # can/must only be called in main 2273 # can/must only be called in main
2216 if ($Coro::current != $Coro::main) { 2274 if ($Coro::current != $Coro::main) {
2217 warn "can only reload from main coroutine\n"; 2275 warn "can only reload from main coroutine\n";
2218 return; 2276 return;
2219 } 2277 }
2220 2278
2221 warn "reloading..."; 2279 warn "reloading...";
2222 2280
2281 warn "freezing server";
2223 my $guard = freeze_mainloop; 2282 my $guard = freeze_mainloop;
2224 cf::emergency_save; 2283 cf::emergency_save;
2225 2284
2285 warn "sync database to disk";
2286 cf::db_sync;
2287 IO::AIO::flush;
2288
2226 eval { 2289 eval {
2227 # if anything goes wrong in here, we should simply crash as we already saved 2290 # if anything goes wrong in here, we should simply crash as we already saved
2228 2291
2229 # cancel all watchers 2292 warn "cancel all watchers";
2230 for (Event::all_watchers) { 2293 for (Event::all_watchers) {
2231 $_->cancel if $_->data & WF_AUTOCANCEL; 2294 $_->cancel if $_->data & WF_AUTOCANCEL;
2232 } 2295 }
2233 2296
2234 # cancel all extension coros 2297 warn "cancel all extension coros";
2235 $_->cancel for values %EXT_CORO; 2298 $_->cancel for values %EXT_CORO;
2236 %EXT_CORO = (); 2299 %EXT_CORO = ();
2237 2300
2301 warn "remove commands";
2302 %COMMAND = ();
2303
2304 warn "remove ext commands";
2305 %EXTCMD = ();
2306
2238 # unload all extensions 2307 warn "unload/nuke all extensions";
2239 for (@exts) { 2308 for my $pkg (@EXTS) {
2240 warn "unloading <$_>"; 2309 warn "... unloading $pkg";
2241 unload_extension $_; 2310
2311 if (my $cb = $pkg->can ("unload")) {
2312 eval {
2313 $cb->($pkg);
2314 1
2315 } or warn "$pkg unloaded, but with errors: $@";
2242 } 2316 }
2243 2317
2318 warn "... nuking $pkg";
2319 Symbol::delete_package $pkg;
2320 }
2321
2244 # unload all modules loaded from $LIBDIR 2322 warn "unload all perl modules loaded from $LIBDIR";
2245 while (my ($k, $v) = each %INC) { 2323 while (my ($k, $v) = each %INC) {
2246 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2324 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2247 2325
2248 warn "removing <$k>"; 2326 warn "removing <$k>";
2249 delete $INC{$k}; 2327 delete $INC{$k};
… …
2256 } 2334 }
2257 2335
2258 Symbol::delete_package $k; 2336 Symbol::delete_package $k;
2259 } 2337 }
2260 2338
2261 # sync database to disk
2262 cf::db_sync;
2263 IO::AIO::flush;
2264
2265 # get rid of safe::, as good as possible 2339 warn "get rid of safe::, as good as possible";
2266 Symbol::delete_package "safe::$_" 2340 Symbol::delete_package "safe::$_"
2267 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2341 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2268 2342
2269 # remove register_script_function callbacks
2270 # TODO
2271
2272 # unload cf.pm "a bit" 2343 warn "unload cf.pm \"a bit\"";
2273 delete $INC{"cf.pm"}; 2344 delete $INC{"cf.pm"};
2274 2345
2275 # don't, removes xs symbols, too, 2346 # don't, removes xs symbols, too,
2276 # and global variables created in xs 2347 # and global variables created in xs
2277 #Symbol::delete_package __PACKAGE__; 2348 #Symbol::delete_package __PACKAGE__;
2278 2349
2279 # reload cf.pm
2280 warn "reloading cf.pm"; 2350 warn "reloading cf.pm";
2281 require cf; 2351 require cf;
2282 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2352 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2283 2353
2284 # load config and database again 2354 warn "load config and database again";
2285 cf::cfg_load; 2355 cf::cfg_load;
2286 cf::db_load; 2356 cf::db_load;
2287 2357
2288 # load extensions
2289 warn "load extensions"; 2358 warn "load extensions";
2290 cf::load_extensions; 2359 cf::load_extensions;
2291 2360
2292 # reattach attachments to objects 2361 warn "reattach attachments to objects/players";
2293 warn "reattach";
2294 _global_reattach; 2362 _global_reattach;
2363 warn "reattach attachments to maps";
2295 reattach $_ for values %MAP; 2364 reattach $_ for values %MAP;
2296 }; 2365 };
2297 2366
2298 if ($@) { 2367 if ($@) {
2299 warn $@; 2368 warn $@;
2300 warn "error while reloading, exiting."; 2369 warn "error while reloading, exiting.";
2301 exit 1; 2370 exit 1;
2302 } 2371 }
2303 2372
2304 warn "reloaded successfully"; 2373 warn "reloaded";
2305}; 2374};
2306
2307#############################################################################
2308
2309unless ($LINK_MAP) {
2310 $LINK_MAP = cf::map::new;
2311
2312 $LINK_MAP->width (41);
2313 $LINK_MAP->height (41);
2314 $LINK_MAP->alloc;
2315 $LINK_MAP->path ("{link}");
2316 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2317 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2318
2319 # dirty hack because... archetypes are not yet loaded
2320 Event->timer (
2321 after => 10,
2322 cb => sub {
2323 $_[0]->w->cancel;
2324
2325 # provide some exits "home"
2326 my $exit = cf::object::new "exit";
2327
2328 $exit->slaying ($EMERGENCY_POSITION->[0]);
2329 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2330 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2331
2332 $LINK_MAP->insert ($exit->clone, 19, 19);
2333 $LINK_MAP->insert ($exit->clone, 19, 20);
2334 $LINK_MAP->insert ($exit->clone, 19, 21);
2335 $LINK_MAP->insert ($exit->clone, 20, 19);
2336 $LINK_MAP->insert ($exit->clone, 20, 21);
2337 $LINK_MAP->insert ($exit->clone, 21, 19);
2338 $LINK_MAP->insert ($exit->clone, 21, 20);
2339 $LINK_MAP->insert ($exit->clone, 21, 21);
2340
2341 $exit->destroy;
2342 });
2343
2344 $LINK_MAP->{deny_save} = 1;
2345 $LINK_MAP->{deny_reset} = 1;
2346
2347 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2348}
2349
2350register "<global>", __PACKAGE__;
2351 2375
2352register_command "reload" => sub { 2376register_command "reload" => sub {
2353 my ($who, $arg) = @_; 2377 my ($who, $arg) = @_;
2354 2378
2355 if ($who->flag (FLAG_WIZ)) { 2379 if ($who->flag (FLAG_WIZ)) {
… …
2365 reentrant => 0, 2389 reentrant => 0,
2366 prio => 0, 2390 prio => 0,
2367 at => $NEXT_TICK || $TICK, 2391 at => $NEXT_TICK || $TICK,
2368 data => WF_AUTOCANCEL, 2392 data => WF_AUTOCANCEL,
2369 cb => sub { 2393 cb => sub {
2394 $NOW = Event::time;
2395
2370 cf::server_tick; # one server iteration 2396 cf::server_tick; # one server iteration
2371 $RUNTIME += $TICK; 2397 $RUNTIME += $TICK;
2372 $NEXT_TICK += $TICK; 2398 $NEXT_TICK += $TICK;
2399
2400 $WAIT_FOR_TICK->broadcast;
2401 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2373 2402
2374 # if we are delayed by four ticks or more, skip them all 2403 # if we are delayed by four ticks or more, skip them all
2375 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2404 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2376 2405
2377 $TICK_WATCHER->at ($NEXT_TICK); 2406 $TICK_WATCHER->at ($NEXT_TICK);
… …
2379 }, 2408 },
2380); 2409);
2381 2410
2382IO::AIO::max_poll_time $TICK * 0.2; 2411IO::AIO::max_poll_time $TICK * 0.2;
2383 2412
2384Event->io ( 2413$AIO_POLL_WATCHER = Event->io (
2385 fd => IO::AIO::poll_fileno, 2414 fd => IO::AIO::poll_fileno,
2386 poll => 'r', 2415 poll => 'r',
2387 prio => 5, 2416 prio => 5,
2388 data => WF_AUTOCANCEL, 2417 data => WF_AUTOCANCEL,
2389 cb => \&IO::AIO::poll_cb, 2418 cb => \&IO::AIO::poll_cb,
2390); 2419);
2391 2420
2392Event->timer ( 2421$WRITE_RUNTIME_WATCHER = Event->timer (
2393 data => WF_AUTOCANCEL, 2422 data => WF_AUTOCANCEL,
2394 after => 0, 2423 after => 0,
2395 interval => 10, 2424 interval => 10,
2396 cb => sub { 2425 cb => sub {
2397 (Coro::unblock_sub { 2426 (Coro::unblock_sub {

Diff Legend

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