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.123 by root, Tue Jan 2 19:18:33 2007 UTC vs.
Revision 1.158 by root, Wed Jan 10 19:52:43 2007 UTC

8use Storable; 8use Storable;
9use Opcode; 9use Opcode;
10use Safe; 10use Safe;
11use Safe::Hole; 11use Safe::Hole;
12 12
13use Coro 3.3; 13use Coro 3.3 ();
14use Coro::Event; 14use Coro::Event;
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.31 (); 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 (2); # 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
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34 35
35our %COMMAND = (); 36our %COMMAND = ();
36our %COMMAND_TIME = (); 37our %COMMAND_TIME = ();
37our %EXTCMD = (); 38our %EXTCMD = ();
38 39
47our %CFG; 48our %CFG;
48 49
49our $UPTIME; $UPTIME ||= time; 50our $UPTIME; $UPTIME ||= time;
50our $RUNTIME; 51our $RUNTIME;
51 52
53our %PLAYER; # all users
52our %MAP; # all maps 54our %MAP; # all maps
53our $LINK_MAP; # the special {link} map 55our $LINK_MAP; # the special {link} map
54our $FREEZE;
55our $RANDOM_MAPS = cf::localdir . "/random"; 56our $RANDOM_MAPS = cf::localdir . "/random";
56our %EXT_CORO; 57our %EXT_CORO; # coroutines bound to extensions
58
59our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
60our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
57 61
58binmode STDOUT; 62binmode STDOUT;
59binmode STDERR; 63binmode STDERR;
60 64
61# read virtual server time, if available 65# read virtual server time, if available
71mkdir cf::localdir . "/" . cf::uniquedir; 75mkdir cf::localdir . "/" . cf::uniquedir;
72mkdir $RANDOM_MAPS; 76mkdir $RANDOM_MAPS;
73 77
74# a special map that is always available 78# a special map that is always available
75our $LINK_MAP; 79our $LINK_MAP;
76 80our $EMERGENCY_POSITION;
77our $EMERGENCY_POSITION = $cf::CFG{emergency_position} || ["/world/world_105_115", 5, 37];
78 81
79############################################################################# 82#############################################################################
80 83
81=head2 GLOBAL VARIABLES 84=head2 GLOBAL VARIABLES
82 85
106 109
107=item %cf::CFG 110=item %cf::CFG
108 111
109Configuration for the server, loaded from C</etc/crossfire/config>, or 112Configuration for the server, loaded from C</etc/crossfire/config>, or
110from wherever your confdir points to. 113from wherever your confdir points to.
114
115=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
116
117These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
118or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
119processing has been done. Call C<< ->wait >> on them to maximise the
120window of cpu time available, or simply to synchronise to the server tick.
111 121
112=back 122=back
113 123
114=cut 124=cut
115 125
119 utf8::encode $msg; 129 utf8::encode $msg;
120 130
121 $msg .= "\n" 131 $msg .= "\n"
122 unless $msg =~ /\n$/; 132 unless $msg =~ /\n$/;
123 133
124 LOG llevError, "cfperl: $msg"; 134 LOG llevError, $msg;
125 }; 135 };
126} 136}
127 137
128@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 138@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
129@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 139@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
155 165
156=head2 UTILITY FUNCTIONS 166=head2 UTILITY FUNCTIONS
157 167
158=over 4 168=over 4
159 169
170=item dumpval $ref
171
160=cut 172=cut
173
174sub dumpval {
175 eval {
176 local $SIG{__DIE__};
177 my $d;
178 if (1) {
179 $d = new Data::Dumper([$_[0]], ["*var"]);
180 $d->Terse(1);
181 $d->Indent(2);
182 $d->Quotekeys(0);
183 $d->Useqq(1);
184 #$d->Bless(...);
185 $d->Seen($_[1]) if @_ > 1;
186 $d = $d->Dump();
187 }
188 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
189 $d
190 } || "[unable to dump $_[0]: '$@']";
191}
161 192
162use JSON::Syck (); # TODO# replace by JSON::PC once working 193use JSON::Syck (); # TODO# replace by JSON::PC once working
163 194
164=item $ref = cf::from_json $json 195=item $ref = cf::from_json $json
165 196
181sub to_json($) { 212sub to_json($) {
182 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 213 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
183 JSON::Syck::Dump $_[0] 214 JSON::Syck::Dump $_[0]
184} 215}
185 216
186=item my $guard = cf::guard { BLOCK }
187
188Run the given callback when the guard object gets destroyed (useful for
189coroutine cancellations).
190
191You can call C<< ->cancel >> on the guard object to stop the block from
192being executed.
193
194=cut
195
196sub guard(&) {
197 bless \(my $cb = $_[0]), cf::guard::;
198}
199
200sub cf::guard::cancel {
201 ${$_[0]} = sub { };
202}
203
204sub cf::guard::DESTROY {
205 ${$_[0]}->();
206}
207
208=item cf::lock_wait $string 217=item cf::lock_wait $string
209 218
210Wait until the given lock is available. See cf::lock_acquire. 219Wait until the given lock is available. See cf::lock_acquire.
211 220
212=item my $lock = cf::lock_acquire $string 221=item my $lock = cf::lock_acquire $string
213 222
214Wait until the given lock is available and then acquires it and returns 223Wait until the given lock is available and then acquires it and returns
215a guard object. If the guard object gets destroyed (goes out of scope, 224a Coro::guard object. If the guard object gets destroyed (goes out of scope,
216for example when the coroutine gets canceled), the lock is automatically 225for example when the coroutine gets canceled), the lock is automatically
217returned. 226returned.
218 227
219Lock names should begin with a unique identifier (for example, find_map 228Lock names should begin with a unique identifier (for example, cf::map::find
220uses map_find and load_map uses map_load). 229uses map_find and cf::map::load uses map_load).
221 230
222=cut 231=cut
223 232
224our %LOCK; 233our %LOCK;
225 234
239 # wait, to be sure we are not locked 248 # wait, to be sure we are not locked
240 lock_wait $key; 249 lock_wait $key;
241 250
242 $LOCK{$key} = []; 251 $LOCK{$key} = [];
243 252
244 cf::guard { 253 Coro::guard {
245 # wake up all waiters, to be on the safe side 254 # wake up all waiters, to be on the safe side
246 $_->ready for @{ delete $LOCK{$key} }; 255 $_->ready for @{ delete $LOCK{$key} };
247 } 256 }
248} 257}
258
259sub freeze_mainloop {
260 return unless $TICK_WATCHER->is_active;
261
262 my $guard = Coro::guard { $TICK_WATCHER->start };
263 $TICK_WATCHER->stop;
264 $guard
265}
266
267=item cf::async { BLOCK }
268
269Currently the same as Coro::async_pool, meaning you cannot use
270C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
271thing you are allowed to do is call C<prio> on it.
272
273=cut
274
275BEGIN { *async = \&Coro::async_pool }
249 276
250=item cf::sync_job { BLOCK } 277=item cf::sync_job { BLOCK }
251 278
252The design of crossfire+ requires that the main coro ($Coro::main) is 279The design of crossfire+ requires that the main coro ($Coro::main) is
253always able to handle events or runnable, as crossfire+ is only partly 280always able to handle events or runnable, as crossfire+ is only partly
267 # this is the main coro, too bad, we have to block 294 # this is the main coro, too bad, we have to block
268 # till the operation succeeds, freezing the server :/ 295 # till the operation succeeds, freezing the server :/
269 296
270 # TODO: use suspend/resume instead 297 # TODO: use suspend/resume instead
271 # (but this is cancel-safe) 298 # (but this is cancel-safe)
272 local $FREEZE = 1; 299 my $freeze_guard = freeze_mainloop;
273 300
274 my $busy = 1; 301 my $busy = 1;
275 my @res; 302 my @res;
276 303
277 (Coro::async { 304 (async {
278 @res = eval { $job->() }; 305 @res = eval { $job->() };
279 warn $@ if $@; 306 warn $@ if $@;
280 undef $busy; 307 undef $busy;
281 })->prio (Coro::PRIO_MAX); 308 })->prio (Coro::PRIO_MAX);
282 309
283 while ($busy) { 310 while ($busy) {
284 Coro::cede_notself; 311 Coro::cede or Event::one_event;
285 Event::one_event unless Coro::nready;
286 } 312 }
287 313
288 wantarray ? @res : $res[0] 314 wantarray ? @res : $res[0]
289 } else { 315 } else {
290 # we are in another coroutine, how wonderful, everything just works 316 # we are in another coroutine, how wonderful, everything just works
291 317
292 $job->() 318 $job->()
293 } 319 }
294} 320}
295 321
296=item $coro = cf::coro { BLOCK } 322=item $coro = cf::async_ext { BLOCK }
297 323
298Creates and returns a new coro. This coro is automcatially being canceled 324Like async, but this coro is automcatially being canceled when the
299when the extension calling this is being unloaded. 325extension calling this is being unloaded.
300 326
301=cut 327=cut
302 328
303sub coro(&) { 329sub async_ext(&) {
304 my $cb = shift; 330 my $cb = shift;
305 331
306 my $coro; $coro = async { 332 my $coro = &Coro::async ($cb);
307 eval {
308 $cb->();
309 };
310 warn $@ if $@;
311 };
312 333
313 $coro->on_destroy (sub { 334 $coro->on_destroy (sub {
314 delete $EXT_CORO{$coro+0}; 335 delete $EXT_CORO{$coro+0};
315 }); 336 });
316 $EXT_CORO{$coro+0} = $coro; 337 $EXT_CORO{$coro+0} = $coro;
345=cut 366=cut
346 367
347############################################################################# 368#############################################################################
348 369
349package cf::path; 370package cf::path;
371
372use overload
373 '""' => \&as_string;
374
375# used to convert map paths into valid unix filenames by repalcing / by ∕
376our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
350 377
351sub new { 378sub new {
352 my ($class, $path, $base) = @_; 379 my ($class, $path, $base) = @_;
353 380
354 $path = $path->as_string if ref $path; 381 $path = $path->as_string if ref $path;
360 # ?random/... random maps 387 # ?random/... random maps
361 # /! non-realised random map exit 388 # /! non-realised random map exit
362 # /... normal maps 389 # /... normal maps
363 # ~/... per-player maps without a specific player (DO NOT USE) 390 # ~/... per-player maps without a specific player (DO NOT USE)
364 # ~user/... per-player map of a specific user 391 # ~user/... per-player map of a specific user
392
393 $path =~ s/$PATH_SEP/\//go;
365 394
366 if ($path =~ /^{/) { 395 if ($path =~ /^{/) {
367 # fine as it is 396 # fine as it is
368 } elsif ($path =~ s{^\?random/}{}) { 397 } elsif ($path =~ s{^\?random/}{}) {
369 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data; 398 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
418# } 447# }
419} 448}
420 449
421# escape the /'s in the path 450# escape the /'s in the path
422sub _escaped_path { 451sub _escaped_path {
423 # ∕ is U+2215
424 (my $path = $_[0]{path}) =~ s/\///g; 452 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
425 $path 453 $path
426} 454}
427 455
428# the original (read-only) location 456# the original (read-only) location
429sub load_path { 457sub load_path {
1056}; 1084};
1057 1085
1058cf::map->attach (prio => -10000, package => cf::mapsupport::); 1086cf::map->attach (prio => -10000, package => cf::mapsupport::);
1059 1087
1060############################################################################# 1088#############################################################################
1061# load/save perl data associated with player->ob objects
1062
1063sub all_objects(@) {
1064 @_, map all_objects ($_->inv), @_
1065}
1066
1067# TODO: compatibility cruft, remove when no longer needed
1068cf::player->attach (
1069 on_load => sub {
1070 my ($pl, $path) = @_;
1071
1072 for my $o (all_objects $pl->ob) {
1073 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1074 $o->set_ob_key_value ("_perl_data");
1075
1076 %$o = %{ Storable::thaw pack "H*", $value };
1077 }
1078 }
1079 },
1080);
1081
1082#############################################################################
1083 1089
1084=head2 CORE EXTENSIONS 1090=head2 CORE EXTENSIONS
1085 1091
1086Functions and methods that extend core crossfire objects. 1092Functions and methods that extend core crossfire objects.
1087 1093
1094=cut
1095
1096package cf::player;
1097
1098use Coro::AIO;
1099
1088=head3 cf::player 1100=head3 cf::player
1089 1101
1090=over 4 1102=over 4
1091 1103
1092=item cf::player::exists $login 1104=item cf::player::find $login
1093 1105
1094Returns true when the given account exists. 1106Returns the given player object, loading it if necessary (might block).
1095 1107
1096=cut 1108=cut
1097 1109
1098sub cf::player::exists($) { 1110sub playerdir($) {
1099 cf::player::find $_[0] 1111 cf::localdir
1100 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 1112 . "/"
1113 . cf::playerdir
1114 . "/"
1115 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1116}
1117
1118sub path($) {
1119 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1120
1121 (playerdir $login) . "/$login.pl"
1122}
1123
1124sub find_active($) {
1125 $cf::PLAYER{$_[0]}
1126 and $cf::PLAYER{$_[0]}->active
1127 and $cf::PLAYER{$_[0]}
1128}
1129
1130sub exists($) {
1131 my ($login) = @_;
1132
1133 $cf::PLAYER{$login}
1134 or cf::sync_job { !aio_stat $login }
1135}
1136
1137sub find($) {
1138 return $cf::PLAYER{$_[0]} || do {
1139 my $login = $_[0];
1140
1141 my $guard = cf::lock_acquire "user_find:$login";
1142
1143 $cf::PLAYER{$_[0]} || do {
1144 my $pl = load_pl path $login
1145 or return;
1146 $cf::PLAYER{$login} = $pl
1147 }
1148 }
1149}
1150
1151sub save($) {
1152 my ($pl) = @_;
1153
1154 return if $pl->{deny_save};
1155
1156 my $path = path $pl;
1157 my $guard = cf::lock_acquire "user_save:$path";
1158
1159 return if $pl->{deny_save};
1160
1161 aio_mkdir playerdir $pl, 0770;
1162 $pl->{last_save} = $cf::RUNTIME;
1163
1164 $pl->save_pl ($path);
1165 Coro::cede;
1166}
1167
1168sub new($) {
1169 my ($login) = @_;
1170
1171 my $self = create;
1172
1173 $self->ob->name ($login);
1174 $self->{deny_save} = 1;
1175
1176 $cf::PLAYER{$login} = $self;
1177
1178 $self
1179}
1180
1181=item $pl->quit_character
1182
1183Nukes the player without looking back. If logged in, the connection will
1184be destroyed. May block for a long time.
1185
1186=cut
1187
1188sub quit_character {
1189 my ($pl) = @_;
1190
1191 $pl->{deny_save} = 1;
1192 $pl->password ("*"); # this should lock out the player until we nuked the dir
1193
1194 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1195 $pl->deactivate;
1196 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1197 $pl->ns->destroy if $pl->ns;
1198
1199 my $path = playerdir $pl;
1200 my $temp = "$path~$cf::RUNTIME~deleting~";
1201 aio_rename $path, $temp;
1202 delete $cf::PLAYER{$pl->ob->name};
1203 $pl->destroy;
1204 IO::AIO::aio_rmtree $temp;
1205}
1206
1207=item cf::player::list_logins
1208
1209Returns am arrayref of all valid playernames in the system, can take a
1210while and may block, so not sync_job-capable, ever.
1211
1212=cut
1213
1214sub list_logins {
1215 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1216 or return [];
1217
1218 my @logins;
1219
1220 for my $login (@$dirs) {
1221 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1222 aio_read $fh, 0, 512, my $buf, 0 or next;
1223 $buf !~ /^password -------------$/m or next; # official not-valid tag
1224
1225 utf8::decode $login;
1226 push @logins, $login;
1227 }
1228
1229 \@logins
1230}
1231
1232=item $player->maps
1233
1234Returns an arrayref of cf::path's of all maps that are private for this
1235player. May block.
1236
1237=cut
1238
1239sub maps($) {
1240 my ($pl) = @_;
1241
1242 my $files = aio_readdir playerdir $pl
1243 or return;
1244
1245 my @paths;
1246
1247 for (@$files) {
1248 utf8::decode $_;
1249 next if /\.(?:pl|pst)$/;
1250 next unless /^$PATH_SEP/o;
1251
1252 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
1253 }
1254
1255 \@paths
1101} 1256}
1102 1257
1103=item $player->ext_reply ($msgid, $msgtype, %msg) 1258=item $player->ext_reply ($msgid, $msgtype, %msg)
1104 1259
1105Sends an ext reply to the player. 1260Sends an ext reply to the player.
1106 1261
1107=cut 1262=cut
1108 1263
1109sub cf::player::ext_reply($$$%) { 1264sub ext_reply($$$%) {
1110 my ($self, $id, %msg) = @_; 1265 my ($self, $id, %msg) = @_;
1111 1266
1112 $msg{msgid} = $id; 1267 $msg{msgid} = $id;
1113 1268
1114 $self->send ("ext " . to_json \%msg); 1269 $self->send ("ext " . cf::to_json \%msg);
1115} 1270}
1271
1272package cf;
1116 1273
1117=back 1274=back
1118 1275
1119 1276
1120=head3 cf::map 1277=head3 cf::map
1126package cf::map; 1283package cf::map;
1127 1284
1128use Fcntl; 1285use Fcntl;
1129use Coro::AIO; 1286use Coro::AIO;
1130 1287
1131our $MAX_RESET = 7200; 1288our $MAX_RESET = 3600;
1132our $DEFAULT_RESET = 3600; 1289our $DEFAULT_RESET = 3000;
1133 1290
1134sub generate_random_map { 1291sub generate_random_map {
1135 my ($path, $rmp) = @_; 1292 my ($path, $rmp) = @_;
1136 1293
1137 # mit "rum" bekleckern, nicht 1294 # mit "rum" bekleckern, nicht
1167 or return; 1324 or return;
1168 1325
1169 my $map = cf::map::new 1326 my $map = cf::map::new
1170 or return; 1327 or return;
1171 1328
1329 # for better error messages only, will be overwritten
1330 $map->path ($path);
1331
1172 $map->load_header ($path) 1332 $map->load_header ($path)
1173 or return; 1333 or return;
1174 1334
1175 $map->{load_path} = $path; 1335 $map->{load_path} = $path;
1176 1336
1177 $map 1337 $map
1178} 1338}
1179 1339
1340sub find;
1180sub find_map { 1341sub find {
1181 my ($path, $origin) = @_; 1342 my ($path, $origin) = @_;
1182 1343
1183 #warn "find_map<$path,$origin>\n";#d# 1344 #warn "find<$path,$origin>\n";#d#
1184 1345
1185 $path = new cf::path $path, $origin && $origin->path; 1346 $path = new cf::path $path, $origin && $origin->path;
1186 my $key = $path->as_string; 1347 my $key = $path->as_string;
1187 1348
1188 cf::lock_wait "map_find:$key"; 1349 cf::lock_wait "map_find:$key";
1191 my $guard = cf::lock_acquire "map_find:$key"; 1352 my $guard = cf::lock_acquire "map_find:$key";
1192 1353
1193 # do it the slow way 1354 # do it the slow way
1194 my $map = try_load_header $path->save_path; 1355 my $map = try_load_header $path->save_path;
1195 1356
1357 Coro::cede;
1358
1196 if ($map) { 1359 if ($map) {
1360 $map->last_access ((delete $map->{last_access})
1361 || $cf::RUNTIME); #d#
1197 # safety 1362 # safety
1198 $map->{instantiate_time} = $cf::RUNTIME 1363 $map->{instantiate_time} = $cf::RUNTIME
1199 if $map->{instantiate_time} > $cf::RUNTIME; 1364 if $map->{instantiate_time} > $cf::RUNTIME;
1200 } else { 1365 } else {
1201 if (my $rmp = $path->random_map_params) { 1366 if (my $rmp = $path->random_map_params) {
1206 1371
1207 $map or return; 1372 $map or return;
1208 1373
1209 $map->{load_original} = 1; 1374 $map->{load_original} = 1;
1210 $map->{instantiate_time} = $cf::RUNTIME; 1375 $map->{instantiate_time} = $cf::RUNTIME;
1376 $map->last_access ($cf::RUNTIME);
1211 $map->instantiate; 1377 $map->instantiate;
1212 1378
1213 # per-player maps become, after loading, normal maps 1379 # per-player maps become, after loading, normal maps
1214 $map->per_player (0) if $path->{user_rel}; 1380 $map->per_player (0) if $path->{user_rel};
1215 } 1381 }
1216 1382
1217 $map->path ($key); 1383 $map->path ($key);
1218 $map->{path} = $path; 1384 $map->{path} = $path;
1219 $map->{last_save} = $cf::RUNTIME; 1385 $map->{last_save} = $cf::RUNTIME;
1220 $map->last_access ($cf::RUNTIME); 1386
1387 Coro::cede;
1221 1388
1222 if ($map->should_reset) { 1389 if ($map->should_reset) {
1223 $map->reset; 1390 $map->reset;
1224 undef $guard; 1391 undef $guard;
1225 $map = find_map $path; 1392 $map = find $path
1393 or return;
1226 } 1394 }
1227 1395
1228 $cf::MAP{$key} = $map 1396 $cf::MAP{$key} = $map
1229 } 1397 }
1230} 1398}
1251 if (aio_open $uniq, O_RDONLY, 0) { 1419 if (aio_open $uniq, O_RDONLY, 0) {
1252 $self->clear_unique_items; 1420 $self->clear_unique_items;
1253 $self->load_objects ($uniq, 0); 1421 $self->load_objects ($uniq, 0);
1254 } 1422 }
1255 } 1423 }
1424
1425 Coro::cede;
1256 1426
1257 # now do the right thing for maps 1427 # now do the right thing for maps
1258 $self->link_multipart_objects; 1428 $self->link_multipart_objects;
1259 1429
1260 if ($self->{path}->is_style_map) { 1430 if ($self->{path}->is_style_map) {
1268 $self->difficulty ($self->estimate_difficulty) 1438 $self->difficulty ($self->estimate_difficulty)
1269 unless $self->difficulty; 1439 unless $self->difficulty;
1270 $self->activate; 1440 $self->activate;
1271 } 1441 }
1272 1442
1443 Coro::cede;
1444
1273 $self->in_memory (cf::MAP_IN_MEMORY); 1445 $self->in_memory (cf::MAP_IN_MEMORY);
1274} 1446}
1275 1447
1276sub load_map_sync { 1448# find and load all maps in the 3x3 area around a map
1449sub load_diag {
1450 my ($map) = @_;
1451
1452 my @diag; # diagonal neighbours
1453
1454 for (0 .. 3) {
1455 my $neigh = $map->tile_path ($_)
1456 or next;
1457 $neigh = find $neigh, $map
1458 or next;
1459 $neigh->load;
1460
1461 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1462 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1463 }
1464
1465 for (@diag) {
1466 my $neigh = find @$_
1467 or next;
1468 $neigh->load;
1469 }
1470}
1471
1472sub find_sync {
1277 my ($path, $origin) = @_; 1473 my ($path, $origin) = @_;
1278 1474
1279 #warn "load_map_sync<$path, $origin>\n";#d# 1475 cf::sync_job { find $path, $origin }
1476}
1280 1477
1281 cf::sync_job { 1478sub do_load_sync {
1282 my $map = cf::map::find_map $path, $origin 1479 my ($map) = @_;
1480
1481 cf::sync_job { $map->load };
1482}
1483
1484our %MAP_PREFETCH;
1485our $MAP_PREFETCHER = Coro::async {
1486 while () {
1487 while (%MAP_PREFETCH) {
1488 my $key = each %MAP_PREFETCH
1283 or return; 1489 or next;
1490 my $path = delete $MAP_PREFETCH{$key};
1491
1492 my $map = find $path
1493 or next;
1284 $map->load; 1494 $map->load;
1285 $map 1495 }
1496 Coro::schedule;
1286 } 1497 }
1498};
1499
1500sub find_async {
1501 my ($path, $origin) = @_;
1502
1503 $path = new cf::path $path, $origin && $origin->path;
1504 my $key = $path->as_string;
1505
1506 if (my $map = $cf::MAP{$key}) {
1507 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1508 }
1509
1510 $MAP_PREFETCH{$key} = $path;
1511 $MAP_PREFETCHER->ready;
1512
1513 ()
1287} 1514}
1288 1515
1289sub save { 1516sub save {
1290 my ($self) = @_; 1517 my ($self) = @_;
1291 1518
1519 my $lock = cf::lock_acquire "map_data:" . $self->path;
1520
1292 $self->{last_save} = $cf::RUNTIME; 1521 $self->{last_save} = $cf::RUNTIME;
1293 1522
1294 return unless $self->dirty; 1523 return unless $self->dirty;
1295 1524
1296 my $save = $self->{path}->save_path; utf8::encode $save; 1525 my $save = $self->{path}->save_path; utf8::encode $save;
1297 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1526 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
1298 1527
1299 $self->{load_path} = $save; 1528 $self->{load_path} = $save;
1300 1529
1301 return if $self->{deny_save}; 1530 return if $self->{deny_save};
1531
1532 local $self->{last_access} = $self->last_access;#d#
1533
1534 cf::async {
1535 $_->contr->save for $self->players;
1536 };
1302 1537
1303 if ($uniq) { 1538 if ($uniq) {
1304 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1539 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1305 $self->save_objects ($uniq, cf::IO_UNIQUES); 1540 $self->save_objects ($uniq, cf::IO_UNIQUES);
1306 } else { 1541 } else {
1309} 1544}
1310 1545
1311sub swap_out { 1546sub swap_out {
1312 my ($self) = @_; 1547 my ($self) = @_;
1313 1548
1549 # save first because save cedes
1550 $self->save;
1551
1552 my $lock = cf::lock_acquire "map_data:" . $self->path;
1553
1314 return if $self->players; 1554 return if $self->players;
1315 return if $self->in_memory != cf::MAP_IN_MEMORY; 1555 return if $self->in_memory != cf::MAP_IN_MEMORY;
1316 return if $self->{deny_save}; 1556 return if $self->{deny_save};
1317 1557
1318 $self->save;
1319 $self->clear; 1558 $self->clear;
1320 $self->in_memory (cf::MAP_SWAPPED); 1559 $self->in_memory (cf::MAP_SWAPPED);
1321} 1560}
1322 1561
1323sub reset_at { 1562sub reset_at {
1361} 1600}
1362 1601
1363sub reset { 1602sub reset {
1364 my ($self) = @_; 1603 my ($self) = @_;
1365 1604
1605 my $lock = cf::lock_acquire "map_data:" . $self->path;
1606
1366 return if $self->players; 1607 return if $self->players;
1367 return if $self->{path}{user_rel};#d# 1608 return if $self->{path}{user_rel};#d#
1368 1609
1369 warn "resetting map ", $self->path;#d# 1610 warn "resetting map ", $self->path;#d#
1370 1611
1389 1630
1390sub customise_for { 1631sub customise_for {
1391 my ($map, $ob) = @_; 1632 my ($map, $ob) = @_;
1392 1633
1393 if ($map->per_player) { 1634 if ($map->per_player) {
1394 return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path}; 1635 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path};
1395 } 1636 }
1396 1637
1397 $map 1638 $map
1398} 1639}
1399 1640
1400sub emergency_save { 1641=item cf::map::unique_maps
1401 local $cf::FREEZE = 1;
1402 1642
1403 warn "enter emergency map save\n"; 1643Returns an arrayref of cf::path's of all shared maps that have
1644instantiated unique items. May block.
1404 1645
1405 cf::sync_job { 1646=cut
1406 warn "begin emergency map save\n"; 1647
1407 $_->save for values %cf::MAP; 1648sub unique_maps() {
1649 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1650 or return;
1651
1652 my @paths;
1653
1654 for (@$files) {
1655 utf8::decode $_;
1656 next if /\.pst$/;
1657 next unless /^$PATH_SEP/o;
1658
1659 push @paths, new cf::path $_;
1408 }; 1660 }
1409 1661
1410 warn "end emergency map save\n"; 1662 \@paths
1411} 1663}
1412 1664
1413package cf; 1665package cf;
1414 1666
1415=back 1667=back
1416 1668
1669=head3 cf::object
1670
1671=cut
1672
1673package cf::object;
1674
1675=over 4
1676
1677=item $ob->inv_recursive
1678
1679Returns the inventory of the object _and_ their inventories, recursively.
1680
1681=cut
1682
1683sub inv_recursive_;
1684sub inv_recursive_ {
1685 map { $_, inv_recursive_ $_->inv } @_
1686}
1687
1688sub inv_recursive {
1689 inv_recursive_ inv $_[0]
1690}
1691
1692package cf;
1693
1694=back
1417 1695
1418=head3 cf::object::player 1696=head3 cf::object::player
1419 1697
1420=over 4 1698=over 4
1421 1699
1496 my $link_pos = delete $self->{_link_pos}; 1774 my $link_pos = delete $self->{_link_pos};
1497 1775
1498 unless ($map) { 1776 unless ($map) {
1499 # restore original map position 1777 # restore original map position
1500 ($map, $x, $y) = @{ $link_pos || [] }; 1778 ($map, $x, $y) = @{ $link_pos || [] };
1501 $map = cf::map::find_map $map; 1779 $map = cf::map::find $map;
1502 1780
1503 unless ($map) { 1781 unless ($map) {
1504 ($map, $x, $y) = @$EMERGENCY_POSITION; 1782 ($map, $x, $y) = @$EMERGENCY_POSITION;
1505 $map = cf::map::find_map $map 1783 $map = cf::map::find $map
1506 or die "FATAL: cannot load emergency map\n"; 1784 or die "FATAL: cannot load emergency map\n";
1507 } 1785 }
1508 } 1786 }
1509 1787
1510 ($x, $y) = (-1, -1) 1788 ($x, $y) = (-1, -1)
1513 # use -1 or undef as default coordinates, not 0, 0 1791 # use -1 or undef as default coordinates, not 0, 0
1514 ($x, $y) = ($map->enter_x, $map->enter_y) 1792 ($x, $y) = ($map->enter_x, $map->enter_y)
1515 if $x <=0 && $y <= 0; 1793 if $x <=0 && $y <= 0;
1516 1794
1517 $map->load; 1795 $map->load;
1796 $map->load_diag;
1518 1797
1798 return unless $self->contr->active;
1519 $self->activate_recursive; 1799 $self->activate_recursive;
1520 $self->enter_map ($map, $x, $y); 1800 $self->enter_map ($map, $x, $y);
1521} 1801}
1522 1802
1523cf::player->attach ( 1803cf::player->attach (
1536 1816
1537 # try to abort aborted map switching on player login :) 1817 # try to abort aborted map switching on player login :)
1538 # should happen only on crashes 1818 # should happen only on crashes
1539 if ($pl->ob->{_link_pos}) { 1819 if ($pl->ob->{_link_pos}) {
1540 $pl->ob->enter_link; 1820 $pl->ob->enter_link;
1541 Coro::async { 1821 (async {
1542 # we need this sleep as the login has a concurrent enter_exit running 1822 # we need this sleep as the login has a concurrent enter_exit running
1543 # and this sleep increases chances of the player not ending up in scorn 1823 # and this sleep increases chances of the player not ending up in scorn
1824 $pl->ob->reply (undef,
1825 "There was an internal problem at your last logout, "
1826 . "the server will try to bring you to your intended destination in a second.",
1827 cf::NDI_RED);
1544 Coro::Timer::sleep 1; 1828 Coro::Timer::sleep 1;
1545 $pl->ob->leave_link; 1829 $pl->ob->leave_link;
1546 }; 1830 })->prio (2);
1547 } 1831 }
1548 }, 1832 },
1549); 1833);
1550 1834
1551=item $player_object->goto_map ($path, $x, $y) 1835=item $player_object->goto ($path, $x, $y)
1552 1836
1553=cut 1837=cut
1554 1838
1555sub cf::object::player::goto_map { 1839sub cf::object::player::goto {
1556 my ($self, $path, $x, $y) = @_; 1840 my ($self, $path, $x, $y) = @_;
1557 1841
1842 $path = new cf::path $path;
1843
1558 $self->enter_link; 1844 $self->enter_link;
1559 1845
1560 (Coro::async { 1846 (async {
1561 $path = new cf::path $path;
1562
1563 my $map = cf::map::find_map $path->as_string; 1847 my $map = cf::map::find $path->as_string;
1564 $map = $map->customise_for ($self) if $map; 1848 $map = $map->customise_for ($self) if $map;
1565 1849
1566# warn "entering ", $map->path, " at ($x, $y)\n" 1850# warn "entering ", $map->path, " at ($x, $y)\n"
1567# if $map; 1851# if $map;
1568 1852
1569 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1853 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1570 1854
1571 $self->leave_link ($map, $x, $y); 1855 $self->leave_link ($map, $x, $y);
1572 })->prio (1); 1856 })->prio (1);
1573} 1857}
1574 1858
1627 1911
1628 return unless $self->type == cf::PLAYER; 1912 return unless $self->type == cf::PLAYER;
1629 1913
1630 $self->enter_link; 1914 $self->enter_link;
1631 1915
1632 (Coro::async { 1916 (async {
1917 $self->deactivate_recursive; # just to be sure
1633 unless (eval { 1918 unless (eval {
1634
1635 prepare_random_map $exit 1919 prepare_random_map $exit
1636 if $exit->slaying eq "/!"; 1920 if $exit->slaying eq "/!";
1637 1921
1638 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path; 1922 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1639 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp); 1923 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1640 1924
1641 1; 1925 1;
1642 }) { 1926 }) {
1643 $self->message ("Something went wrong deep within the crossfire server. " 1927 $self->message ("Something went wrong deep within the crossfire server. "
1644 . "I'll try to bring you back to the map you were before. " 1928 . "I'll try to bring you back to the map you were before. "
1645 . "Please report this to the dungeon master", 1929 . "Please report this to the dungeon master!",
1646 cf::NDI_UNIQUE | cf::NDI_RED); 1930 cf::NDI_UNIQUE | cf::NDI_RED);
1647 1931
1648 warn "ERROR in enter_exit: $@"; 1932 warn "ERROR in enter_exit: $@";
1649 $self->leave_link; 1933 $self->leave_link;
1650 } 1934 }
1701 on_reply => sub { 1985 on_reply => sub {
1702 my ($ns, $msg) = @_; 1986 my ($ns, $msg) = @_;
1703 1987
1704 # this weird shuffling is so that direct followup queries 1988 # this weird shuffling is so that direct followup queries
1705 # get handled first 1989 # get handled first
1706 my $queue = delete $ns->{query_queue}; 1990 my $queue = delete $ns->{query_queue}
1991 or return; # be conservative, not sure how that can happen, but we saw a crash here
1707 1992
1708 (shift @$queue)->[1]->($msg); 1993 (shift @$queue)->[1]->($msg);
1709 1994
1710 push @{ $ns->{query_queue} }, @$queue; 1995 push @{ $ns->{query_queue} }, @$queue;
1711 1996
1717 } 2002 }
1718 } 2003 }
1719 }, 2004 },
1720); 2005);
1721 2006
1722=item $client->coro (\&cb) 2007=item $client->async (\&cb)
1723 2008
1724Create a new coroutine, running the specified callback. The coroutine will 2009Create a new coroutine, running the specified callback. The coroutine will
1725be automatically cancelled when the client gets destroyed (e.g. on logout, 2010be automatically cancelled when the client gets destroyed (e.g. on logout,
1726or loss of connection). 2011or loss of connection).
1727 2012
1728=cut 2013=cut
1729 2014
1730sub cf::client::coro { 2015sub cf::client::async {
1731 my ($self, $cb) = @_; 2016 my ($self, $cb) = @_;
1732 2017
1733 my $coro; $coro = async { 2018 my $coro = &Coro::async ($cb);
1734 eval {
1735 $cb->();
1736 };
1737 warn $@ if $@;
1738 };
1739 2019
1740 $coro->on_destroy (sub { 2020 $coro->on_destroy (sub {
1741 delete $self->{_coro}{$coro+0}; 2021 delete $self->{_coro}{$coro+0};
1742 }); 2022 });
1743 2023
1978 open my $fh, "<:utf8", cf::confdir . "/config" 2258 open my $fh, "<:utf8", cf::confdir . "/config"
1979 or return; 2259 or return;
1980 2260
1981 local $/; 2261 local $/;
1982 *CFG = YAML::Syck::Load <$fh>; 2262 *CFG = YAML::Syck::Load <$fh>;
2263
2264 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2265
2266 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2267 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2268
2269 if (exists $CFG{mlockall}) {
2270 eval {
2271 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2272 and die "WARNING: m(un)lockall failed: $!\n";
2273 };
2274 warn $@ if $@;
2275 }
1983} 2276}
1984 2277
1985sub main { 2278sub main {
1986 # we must not ever block the main coroutine 2279 # we must not ever block the main coroutine
1987 local $Coro::idle = sub { 2280 local $Coro::idle = sub {
1988 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2281 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1989 (Coro::unblock_sub {
1990 Event::one_event; 2282 async { Event::one_event };
1991 })->();
1992 }; 2283 };
1993 2284
1994 cfg_load; 2285 cfg_load;
1995 db_load; 2286 db_load;
1996 load_extensions; 2287 load_extensions;
1997 Event::loop; 2288 Event::loop;
1998} 2289}
1999 2290
2000############################################################################# 2291#############################################################################
2001# initialisation 2292# initialisation and cleanup
2293
2294# install some emergency cleanup handlers
2295BEGIN {
2296 for my $signal (qw(INT HUP TERM)) {
2297 Event->signal (
2298 data => WF_AUTOCANCEL,
2299 signal => $signal,
2300 cb => sub {
2301 cf::cleanup "SIG$signal";
2302 },
2303 );
2304 }
2305}
2306
2307sub emergency_save() {
2308 my $freeze_guard = cf::freeze_mainloop;
2309
2310 warn "enter emergency perl save\n";
2311
2312 cf::sync_job {
2313 # use a peculiar iteration method to avoid tripping on perl
2314 # refcount bugs in for. also avoids problems with players
2315 # and maps saved/Destroyed asynchronously.
2316 warn "begin emergency player save\n";
2317 for my $login (keys %cf::PLAYER) {
2318 my $pl = $cf::PLAYER{$login} or next;
2319 $pl->valid or next;
2320 $pl->save;
2321 }
2322 warn "end emergency player save\n";
2323
2324 warn "begin emergency map save\n";
2325 for my $path (keys %cf::MAP) {
2326 my $map = $cf::MAP{$path} or next;
2327 $map->valid or next;
2328 $map->save;
2329 }
2330 warn "end emergency map save\n";
2331 };
2332
2333 warn "leave emergency perl save\n";
2334}
2002 2335
2003sub reload() { 2336sub reload() {
2004 # can/must only be called in main 2337 # can/must only be called in main
2005 if ($Coro::current != $Coro::main) { 2338 if ($Coro::current != $Coro::main) {
2006 warn "can only reload from main coroutine\n"; 2339 warn "can only reload from main coroutine\n";
2007 return; 2340 return;
2008 } 2341 }
2009 2342
2010 warn "reloading..."; 2343 warn "reloading...";
2011 2344
2012 local $FREEZE = 1; 2345 my $guard = freeze_mainloop;
2013 cf::emergency_save; 2346 cf::emergency_save;
2014 2347
2015 eval { 2348 eval {
2016 # if anything goes wrong in here, we should simply crash as we already saved 2349 # if anything goes wrong in here, we should simply crash as we already saved
2017 2350
2079 cf::load_extensions; 2412 cf::load_extensions;
2080 2413
2081 # reattach attachments to objects 2414 # reattach attachments to objects
2082 warn "reattach"; 2415 warn "reattach";
2083 _global_reattach; 2416 _global_reattach;
2417 reattach $_ for values %MAP;
2084 }; 2418 };
2085 2419
2086 if ($@) { 2420 if ($@) {
2087 warn $@; 2421 warn $@;
2088 warn "error while reloading, exiting."; 2422 warn "error while reloading, exiting.";
2104 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path"; 2438 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2105 $LINK_MAP->in_memory (MAP_IN_MEMORY); 2439 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2106 2440
2107 # dirty hack because... archetypes are not yet loaded 2441 # dirty hack because... archetypes are not yet loaded
2108 Event->timer ( 2442 Event->timer (
2109 after => 2, 2443 after => 10,
2110 cb => sub { 2444 cb => sub {
2111 $_[0]->w->cancel; 2445 $_[0]->w->cancel;
2112 2446
2113 # provide some exits "home" 2447 # provide some exits "home"
2114 my $exit = cf::object::new "exit"; 2448 my $exit = cf::object::new "exit";
2153 reentrant => 0, 2487 reentrant => 0,
2154 prio => 0, 2488 prio => 0,
2155 at => $NEXT_TICK || $TICK, 2489 at => $NEXT_TICK || $TICK,
2156 data => WF_AUTOCANCEL, 2490 data => WF_AUTOCANCEL,
2157 cb => sub { 2491 cb => sub {
2158 unless ($FREEZE) {
2159 cf::server_tick; # one server iteration 2492 cf::server_tick; # one server iteration
2160 $RUNTIME += $TICK; 2493 $RUNTIME += $TICK;
2161 }
2162
2163 $NEXT_TICK += $TICK; 2494 $NEXT_TICK += $TICK;
2495
2496 $WAIT_FOR_TICK->broadcast;
2497 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2164 2498
2165 # if we are delayed by four ticks or more, skip them all 2499 # if we are delayed by four ticks or more, skip them all
2166 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2500 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2167 2501
2168 $TICK_WATCHER->at ($NEXT_TICK); 2502 $TICK_WATCHER->at ($NEXT_TICK);
2190 or warn "ERROR: unable to write runtime file: $!"; 2524 or warn "ERROR: unable to write runtime file: $!";
2191 })->(); 2525 })->();
2192 }, 2526 },
2193); 2527);
2194 2528
2529END { cf::emergency_save }
2530
21951 25311
2196 2532

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines