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.106 by root, Sun Dec 31 17:29:22 2006 UTC vs.
Revision 1.148 by root, Mon Jan 8 12:39:16 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 Digest::MD5;
20use Fcntl; 21use Fcntl;
21use IO::AIO 2.31 (); 22use IO::AIO 2.32 ();
22use YAML::Syck (); 23use YAML::Syck ();
23use Time::HiRes; 24use Time::HiRes;
24 25
25use Event; $Event::Eval = 1; # no idea why this is required, but it is 26use Event; $Event::Eval = 1; # no idea why this is required, but it is
26 27
27# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
28$YAML::Syck::ImplicitUnicode = 1; 29$YAML::Syck::ImplicitUnicode = 1;
29 30
30$Coro::main->prio (2); # run main coroutine ("the server") with very high priority 31$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
31 32
32sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
33 34
34our %COMMAND = (); 35our %COMMAND = ();
35our %COMMAND_TIME = (); 36our %COMMAND_TIME = ();
46our %CFG; 47our %CFG;
47 48
48our $UPTIME; $UPTIME ||= time; 49our $UPTIME; $UPTIME ||= time;
49our $RUNTIME; 50our $RUNTIME;
50 51
52our %PLAYER; # all users
51our %MAP; # all maps 53our %MAP; # all maps
52our $LINK_MAP; # the special {link} map 54our $LINK_MAP; # the special {link} map
53our $FREEZE; 55our $RANDOM_MAPS = cf::localdir . "/random";
56our %EXT_CORO; # coroutines bound to extensions
54 57
55binmode STDOUT; 58binmode STDOUT;
56binmode STDERR; 59binmode STDERR;
57 60
58# read virtual server time, if available 61# read virtual server time, if available
64 67
65mkdir cf::localdir; 68mkdir cf::localdir;
66mkdir cf::localdir . "/" . cf::playerdir; 69mkdir cf::localdir . "/" . cf::playerdir;
67mkdir cf::localdir . "/" . cf::tmpdir; 70mkdir cf::localdir . "/" . cf::tmpdir;
68mkdir cf::localdir . "/" . cf::uniquedir; 71mkdir cf::localdir . "/" . cf::uniquedir;
72mkdir $RANDOM_MAPS;
69 73
70our %EXT_CORO; 74# a special map that is always available
75our $LINK_MAP;
76our $EMERGENCY_POSITION;
71 77
72############################################################################# 78#############################################################################
73 79
74=head2 GLOBAL VARIABLES 80=head2 GLOBAL VARIABLES
75 81
112 utf8::encode $msg; 118 utf8::encode $msg;
113 119
114 $msg .= "\n" 120 $msg .= "\n"
115 unless $msg =~ /\n$/; 121 unless $msg =~ /\n$/;
116 122
117 LOG llevError, "cfperl: $msg"; 123 LOG llevError, $msg;
118 }; 124 };
119} 125}
120 126
121@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 127@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
122@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 128@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
174sub to_json($) { 180sub to_json($) {
175 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 181 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
176 JSON::Syck::Dump $_[0] 182 JSON::Syck::Dump $_[0]
177} 183}
178 184
185=item cf::lock_wait $string
186
187Wait until the given lock is available. See cf::lock_acquire.
188
189=item my $lock = cf::lock_acquire $string
190
191Wait until the given lock is available and then acquires it and returns
192a Coro::guard object. If the guard object gets destroyed (goes out of scope,
193for example when the coroutine gets canceled), the lock is automatically
194returned.
195
196Lock names should begin with a unique identifier (for example, cf::map::find
197uses map_find and cf::map::load uses map_load).
198
199=cut
200
201our %LOCK;
202
203sub lock_wait($) {
204 my ($key) = @_;
205
206 # wait for lock, if any
207 while ($LOCK{$key}) {
208 push @{ $LOCK{$key} }, $Coro::current;
209 Coro::schedule;
210 }
211}
212
213sub lock_acquire($) {
214 my ($key) = @_;
215
216 # wait, to be sure we are not locked
217 lock_wait $key;
218
219 $LOCK{$key} = [];
220
221 Coro::guard {
222 # wake up all waiters, to be on the safe side
223 $_->ready for @{ delete $LOCK{$key} };
224 }
225}
226
227sub freeze_mainloop {
228 return unless $TICK_WATCHER->is_active;
229
230 my $guard = Coro::guard { $TICK_WATCHER->start };
231 $TICK_WATCHER->stop;
232 $guard
233}
234
235=item cf::async { BLOCK }
236
237Currently the same as Coro::async_pool, meaning you cannot use
238C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
239thing you are allowed to do is call C<prio> on it.
240
241=cut
242
243BEGIN { *async = \&Coro::async_pool }
244
179=item cf::sync_job { BLOCK } 245=item cf::sync_job { BLOCK }
180 246
181The design of crossfire+ requires that the main coro ($Coro::main) is 247The design of crossfire+ requires that the main coro ($Coro::main) is
182always able to handle events or runnable, as crossfire+ is only partly 248always able to handle events or runnable, as crossfire+ is only partly
183reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 249reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
190=cut 256=cut
191 257
192sub sync_job(&) { 258sub sync_job(&) {
193 my ($job) = @_; 259 my ($job) = @_;
194 260
195 my $busy = 1;
196 my @res;
197
198 # TODO: use suspend/resume instead
199 local $FREEZE = 1;
200
201 my $coro = Coro::async {
202 @res = eval { $job->() };
203 warn $@ if $@;
204 undef $busy;
205 };
206
207 if ($Coro::current == $Coro::main) { 261 if ($Coro::current == $Coro::main) {
262 # this is the main coro, too bad, we have to block
263 # till the operation succeeds, freezing the server :/
264
265 # TODO: use suspend/resume instead
266 # (but this is cancel-safe)
267 my $freeze_guard = freeze_mainloop;
268
269 my $busy = 1;
270 my @res;
271
272 (async {
273 @res = eval { $job->() };
274 warn $@ if $@;
275 undef $busy;
208 $coro->prio (Coro::PRIO_MAX); 276 })->prio (Coro::PRIO_MAX);
277
209 while ($busy) { 278 while ($busy) {
210 Coro::cede_notself; 279 Coro::cede or Event::one_event;
211 Event::one_event unless Coro::nready;
212 } 280 }
281
282 wantarray ? @res : $res[0]
213 } else { 283 } else {
214 $coro->join; 284 # we are in another coroutine, how wonderful, everything just works
285
286 $job->()
215 } 287 }
216
217 wantarray ? @res : $res[0]
218} 288}
219 289
220=item $coro = cf::coro { BLOCK } 290=item $coro = cf::async_ext { BLOCK }
221 291
222Creates and returns a new coro. This coro is automcatially being canceled 292Like async, but this coro is automcatially being canceled when the
223when the extension calling this is being unloaded. 293extension calling this is being unloaded.
224 294
225=cut 295=cut
226 296
227sub coro(&) { 297sub async_ext(&) {
228 my $cb = shift; 298 my $cb = shift;
229 299
230 my $coro; $coro = async { 300 my $coro = &Coro::async ($cb);
231 eval {
232 $cb->();
233 };
234 warn $@ if $@;
235 };
236 301
237 $coro->on_destroy (sub { 302 $coro->on_destroy (sub {
238 delete $EXT_CORO{$coro+0}; 303 delete $EXT_CORO{$coro+0};
239 }); 304 });
240 $EXT_CORO{$coro+0} = $coro; 305 $EXT_CORO{$coro+0} = $coro;
241 306
242 $coro 307 $coro
243} 308}
244 309
310sub write_runtime {
311 my $runtime = cf::localdir . "/runtime";
312
313 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
314 or return;
315
316 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock
317 (aio_write $fh, 0, (length $value), $value, 0) <= 0
318 and return;
319
320 aio_fsync $fh
321 and return;
322
323 close $fh
324 or return;
325
326 aio_rename "$runtime~", $runtime
327 and return;
328
329 1
330}
331
245=back 332=back
246 333
247=cut 334=cut
335
336#############################################################################
337
338package cf::path;
339
340sub new {
341 my ($class, $path, $base) = @_;
342
343 $path = $path->as_string if ref $path;
344
345 my $self = bless { }, $class;
346
347 # {... are special paths that are not touched
348 # ?xxx/... are special absolute paths
349 # ?random/... random maps
350 # /! non-realised random map exit
351 # /... normal maps
352 # ~/... per-player maps without a specific player (DO NOT USE)
353 # ~user/... per-player map of a specific user
354
355 if ($path =~ /^{/) {
356 # fine as it is
357 } elsif ($path =~ s{^\?random/}{}) {
358 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
359 $self->{random} = cf::from_json $data;
360 } else {
361 if ($path =~ s{^~([^/]+)?}{}) {
362 $self->{user_rel} = 1;
363
364 if (defined $1) {
365 $self->{user} = $1;
366 } elsif ($base =~ m{^~([^/]+)/}) {
367 $self->{user} = $1;
368 } else {
369 warn "cannot resolve user-relative path without user <$path,$base>\n";
370 }
371 } elsif ($path =~ /^\//) {
372 # already absolute
373 } else {
374 $base =~ s{[^/]+/?$}{};
375 return $class->new ("$base/$path");
376 }
377
378 for ($path) {
379 redo if s{/\.?/}{/};
380 redo if s{/[^/]+/\.\./}{/};
381 }
382 }
383
384 $self->{path} = $path;
385
386 $self
387}
388
389# the name / primary key / in-game path
390sub as_string {
391 my ($self) = @_;
392
393 $self->{user_rel} ? "~$self->{user}$self->{path}"
394 : $self->{random} ? "?random/$self->{path}"
395 : $self->{path}
396}
397
398# the displayed name, this is a one way mapping
399sub visible_name {
400 my ($self) = @_;
401
402# if (my $rmp = $self->{random}) {
403# # todo: be more intelligent about this
404# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
405# } else {
406 $self->as_string
407# }
408}
409
410# escape the /'s in the path
411sub _escaped_path {
412 # ∕ is U+2215
413 (my $path = $_[0]{path}) =~ s/\//∕/g;
414 $path
415}
416
417# the original (read-only) location
418sub load_path {
419 my ($self) = @_;
420
421 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
422}
423
424# the temporary/swap location
425sub save_path {
426 my ($self) = @_;
427
428 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
429 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
430 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
431}
432
433# the unique path, might be eq to save_path
434sub uniq_path {
435 my ($self) = @_;
436
437 $self->{user_rel} || $self->{random}
438 ? undef
439 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
440}
441
442# return random map parameters, or undef
443sub random_map_params {
444 my ($self) = @_;
445
446 $self->{random}
447}
448
449# this is somewhat ugly, but style maps do need special treatment
450sub is_style_map {
451 $_[0]{path} =~ m{^/styles/}
452}
453
454package cf;
248 455
249############################################################################# 456#############################################################################
250 457
251=head2 ATTACHABLE OBJECTS 458=head2 ATTACHABLE OBJECTS
252 459
660 or return; 867 or return;
661 868
662 unless (aio_stat "$filename.pst") { 869 unless (aio_stat "$filename.pst") {
663 (aio_load "$filename.pst", $av) >= 0 870 (aio_load "$filename.pst", $av) >= 0
664 or return; 871 or return;
665 $av = eval { (Storable::thaw <$av>)->{objs} }; 872 $av = eval { (Storable::thaw $av)->{objs} };
666 } 873 }
667 874
875 warn sprintf "loading %s (%d)\n",
876 $filename, length $data, scalar @{$av || []};#d#
668 return ($data, $av); 877 return ($data, $av);
669} 878}
670 879
671############################################################################# 880#############################################################################
672# command handling &c 881# command handling &c
863 1072
864=head2 CORE EXTENSIONS 1073=head2 CORE EXTENSIONS
865 1074
866Functions and methods that extend core crossfire objects. 1075Functions and methods that extend core crossfire objects.
867 1076
1077=cut
1078
1079package cf::player;
1080
868=head3 cf::player 1081=head3 cf::player
869 1082
870=over 4 1083=over 4
871 1084
872=item cf::player::exists $login 1085=item cf::player::find $login
873 1086
874Returns true when the given account exists. 1087Returns the given player object, loading it if necessary (might block).
875 1088
876=cut 1089=cut
877 1090
878sub cf::player::exists($) { 1091sub playerdir($) {
879 cf::player::find $_[0] 1092 cf::localdir
880 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 1093 . "/"
1094 . cf::playerdir
1095 . "/"
1096 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1097}
1098
1099sub path($) {
1100 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1101
1102 (playerdir $login) . "/$login.pl"
1103}
1104
1105sub find_active($) {
1106 $cf::PLAYER{$_[0]}
1107 and $cf::PLAYER{$_[0]}->active
1108 and $cf::PLAYER{$_[0]}
1109}
1110
1111sub exists($) {
1112 my ($login) = @_;
1113
1114 $cf::PLAYER{$login}
1115 or cf::sync_job { !aio_stat $login }
1116}
1117
1118sub find($) {
1119 return $cf::PLAYER{$_[0]} || do {
1120 my $login = $_[0];
1121
1122 my $guard = cf::lock_acquire "user_find:$login";
1123
1124 $cf::PLAYER{$login} ||= (load_pl path $login or return);
1125 };
1126}
1127
1128sub save($) {
1129 my ($pl) = @_;
1130
1131 return if $pl->{deny_save};
1132
1133 my $path = path $pl;
1134 my $guard = cf::lock_acquire "user_save:$path";
1135
1136 return if $pl->{deny_save};
1137
1138 Coro::AIO::aio_mkdir playerdir $pl, 0770;
1139 $pl->{last_save} = $cf::RUNTIME;
1140
1141 $pl->save_pl ($path);
1142 Coro::cede;
1143}
1144
1145sub new($) {
1146 my ($login) = @_;
1147
1148 my $self = create;
1149
1150 $self->ob->name ($login);
1151 $self->{deny_save} = 1;
1152
1153 $cf::PLAYER{$login} = $self;
1154
1155 $self
1156}
1157
1158sub quit_character {
1159 my ($pl) = @_;
1160
1161 $pl->{deny_save} = 1;
1162 $pl->password ("*"); # this should lock out the player until we nuked the dir
1163
1164 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1165 $pl->deactivate;
1166 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1167 $pl->ns->destroy if $pl->ns;
1168
1169 my $path = playerdir $pl;
1170 my $temp = "$path~$cf::RUNTIME~deleting~";
1171 IO::AIO::aio_rename $path, $temp, sub {
1172 delete $cf::PLAYER{$pl->ob->name};
1173 $pl->destroy;
1174
1175 IO::AIO::aio_rmtree $temp;
1176 };
881} 1177}
882 1178
883=item $player->ext_reply ($msgid, $msgtype, %msg) 1179=item $player->ext_reply ($msgid, $msgtype, %msg)
884 1180
885Sends an ext reply to the player. 1181Sends an ext reply to the player.
886 1182
887=cut 1183=cut
888 1184
889sub cf::player::ext_reply($$$%) { 1185sub ext_reply($$$%) {
890 my ($self, $id, %msg) = @_; 1186 my ($self, $id, %msg) = @_;
891 1187
892 $msg{msgid} = $id; 1188 $msg{msgid} = $id;
893 1189
894 $self->send ("ext " . to_json \%msg); 1190 $self->send ("ext " . cf::to_json \%msg);
895} 1191}
1192
1193package cf;
896 1194
897=back 1195=back
1196
1197
1198=head3 cf::map
1199
1200=over 4
1201
1202=cut
1203
1204package cf::map;
1205
1206use Fcntl;
1207use Coro::AIO;
1208
1209our $MAX_RESET = 3600;
1210our $DEFAULT_RESET = 3000;
1211
1212sub generate_random_map {
1213 my ($path, $rmp) = @_;
1214
1215 # mit "rum" bekleckern, nicht
1216 cf::map::_create_random_map
1217 $path,
1218 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1219 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1220 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1221 $rmp->{exit_on_final_map},
1222 $rmp->{xsize}, $rmp->{ysize},
1223 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1224 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1225 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1226 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1227 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1228 (cf::region::find $rmp->{region})
1229}
1230
1231# and all this just because we cannot iterate over
1232# all maps in C++...
1233sub change_all_map_light {
1234 my ($change) = @_;
1235
1236 $_->change_map_light ($change)
1237 for grep $_->outdoor, values %cf::MAP;
1238}
1239
1240sub try_load_header($) {
1241 my ($path) = @_;
1242
1243 utf8::encode $path;
1244 aio_open $path, O_RDONLY, 0
1245 or return;
1246
1247 my $map = cf::map::new
1248 or return;
1249
1250 # for better error messages only, will be overwritten
1251 $map->path ($path);
1252
1253 $map->load_header ($path)
1254 or return;
1255
1256 $map->{load_path} = $path;
1257
1258 $map
1259}
1260
1261sub find;
1262sub find {
1263 my ($path, $origin) = @_;
1264
1265 #warn "find<$path,$origin>\n";#d#
1266
1267 $path = new cf::path $path, $origin && $origin->path;
1268 my $key = $path->as_string;
1269
1270 cf::lock_wait "map_find:$key";
1271
1272 $cf::MAP{$key} || do {
1273 my $guard = cf::lock_acquire "map_find:$key";
1274
1275 # do it the slow way
1276 my $map = try_load_header $path->save_path;
1277
1278 Coro::cede;
1279
1280 if ($map) {
1281 $map->last_access ((delete $map->{last_access})
1282 || $cf::RUNTIME); #d#
1283 # safety
1284 $map->{instantiate_time} = $cf::RUNTIME
1285 if $map->{instantiate_time} > $cf::RUNTIME;
1286 } else {
1287 if (my $rmp = $path->random_map_params) {
1288 $map = generate_random_map $key, $rmp;
1289 } else {
1290 $map = try_load_header $path->load_path;
1291 }
1292
1293 $map or return;
1294
1295 $map->{load_original} = 1;
1296 $map->{instantiate_time} = $cf::RUNTIME;
1297 $map->last_access ($cf::RUNTIME);
1298 $map->instantiate;
1299
1300 # per-player maps become, after loading, normal maps
1301 $map->per_player (0) if $path->{user_rel};
1302 }
1303
1304 $map->path ($key);
1305 $map->{path} = $path;
1306 $map->{last_save} = $cf::RUNTIME;
1307
1308 Coro::cede;
1309
1310 if ($map->should_reset) {
1311 $map->reset;
1312 undef $guard;
1313 $map = find $path
1314 or return;
1315 }
1316
1317 $cf::MAP{$key} = $map
1318 }
1319}
1320
1321sub load {
1322 my ($self) = @_;
1323
1324 my $path = $self->{path};
1325 my $guard = cf::lock_acquire "map_load:" . $path->as_string;
1326
1327 return if $self->in_memory != cf::MAP_SWAPPED;
1328
1329 $self->in_memory (cf::MAP_LOADING);
1330
1331 $self->alloc;
1332 $self->load_objects ($self->{load_path}, 1)
1333 or return;
1334
1335 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1336 if delete $self->{load_original};
1337
1338 if (my $uniq = $path->uniq_path) {
1339 utf8::encode $uniq;
1340 if (aio_open $uniq, O_RDONLY, 0) {
1341 $self->clear_unique_items;
1342 $self->load_objects ($uniq, 0);
1343 }
1344 }
1345
1346 Coro::cede;
1347
1348 # now do the right thing for maps
1349 $self->link_multipart_objects;
1350
1351 if ($self->{path}->is_style_map) {
1352 $self->{deny_save} = 1;
1353 $self->{deny_reset} = 1;
1354 } else {
1355 $self->fix_auto_apply;
1356 $self->decay_objects;
1357 $self->update_buttons;
1358 $self->set_darkness_map;
1359 $self->difficulty ($self->estimate_difficulty)
1360 unless $self->difficulty;
1361 $self->activate;
1362 }
1363
1364 Coro::cede;
1365
1366 $self->in_memory (cf::MAP_IN_MEMORY);
1367}
1368
1369sub find_sync {
1370 my ($path, $origin) = @_;
1371
1372 cf::sync_job { cf::map::find $path, $origin }
1373}
1374
1375sub do_load_sync {
1376 my ($map) = @_;
1377
1378 cf::sync_job { $map->load };
1379}
1380
1381sub save {
1382 my ($self) = @_;
1383
1384 my $lock = cf::lock_acquire "map_data:" . $self->path;
1385
1386 $self->{last_save} = $cf::RUNTIME;
1387
1388 return unless $self->dirty;
1389
1390 my $save = $self->{path}->save_path; utf8::encode $save;
1391 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
1392
1393 $self->{load_path} = $save;
1394
1395 return if $self->{deny_save};
1396
1397 local $self->{last_access} = $self->last_access;#d#
1398
1399 cf::async {
1400 $_->contr->save for $self->players;
1401 };
1402
1403 if ($uniq) {
1404 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1405 $self->save_objects ($uniq, cf::IO_UNIQUES);
1406 } else {
1407 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1408 }
1409}
1410
1411sub swap_out {
1412 my ($self) = @_;
1413
1414 # save first because save cedes
1415 $self->save;
1416
1417 my $lock = cf::lock_acquire "map_data:" . $self->path;
1418
1419 return if $self->players;
1420 return if $self->in_memory != cf::MAP_IN_MEMORY;
1421 return if $self->{deny_save};
1422
1423 $self->clear;
1424 $self->in_memory (cf::MAP_SWAPPED);
1425}
1426
1427sub reset_at {
1428 my ($self) = @_;
1429
1430 # TODO: safety, remove and allow resettable per-player maps
1431 return 1e99 if $self->{path}{user_rel};
1432 return 1e99 if $self->{deny_reset};
1433
1434 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1435 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1436
1437 $time + $to
1438}
1439
1440sub should_reset {
1441 my ($self) = @_;
1442
1443 $self->reset_at <= $cf::RUNTIME
1444}
1445
1446sub unlink_save {
1447 my ($self) = @_;
1448
1449 utf8::encode (my $save = $self->{path}->save_path);
1450 aioreq_pri 3; IO::AIO::aio_unlink $save;
1451 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1452}
1453
1454sub rename {
1455 my ($self, $new_path) = @_;
1456
1457 $self->unlink_save;
1458
1459 delete $cf::MAP{$self->path};
1460 $self->{path} = new cf::path $new_path;
1461 $self->path ($self->{path}->as_string);
1462 $cf::MAP{$self->path} = $self;
1463
1464 $self->save;
1465}
1466
1467sub reset {
1468 my ($self) = @_;
1469
1470 my $lock = cf::lock_acquire "map_data:" . $self->path;
1471
1472 return if $self->players;
1473 return if $self->{path}{user_rel};#d#
1474
1475 warn "resetting map ", $self->path;#d#
1476
1477 delete $cf::MAP{$self->path};
1478
1479 $_->clear_links_to ($self) for values %cf::MAP;
1480
1481 $self->unlink_save;
1482 $self->destroy;
1483}
1484
1485my $nuke_counter = "aaaa";
1486
1487sub nuke {
1488 my ($self) = @_;
1489
1490 $self->{deny_save} = 1;
1491 $self->reset_timeout (1);
1492 $self->rename ("{nuke}/" . ($nuke_counter++));
1493 $self->reset; # polite request, might not happen
1494}
1495
1496sub customise_for {
1497 my ($map, $ob) = @_;
1498
1499 if ($map->per_player) {
1500 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path};
1501 }
1502
1503 $map
1504}
1505
1506sub emergency_save {
1507 my $freeze_guard = cf::freeze_mainloop;
1508
1509 warn "enter emergency perl save\n";
1510
1511 cf::sync_job {
1512 warn "begin emergency player save\n";
1513 $_->save for values %cf::PLAYER;
1514 warn "end emergency player save\n";
1515
1516 warn "begin emergency map save\n";
1517 $_->save for values %cf::MAP;
1518 warn "end emergency map save\n";
1519 };
1520
1521 warn "leave emergency perl save\n";
1522}
1523
1524package cf;
1525
1526=back
1527
898 1528
899=head3 cf::object::player 1529=head3 cf::object::player
900 1530
901=over 4 1531=over 4
902 1532
938 (ref $cf::CFG{"may_$access"} 1568 (ref $cf::CFG{"may_$access"}
939 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 1569 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
940 : $cf::CFG{"may_$access"}) 1570 : $cf::CFG{"may_$access"})
941} 1571}
942 1572
1573=item $player_object->enter_link
1574
1575Freezes the player and moves him/her to a special map (C<{link}>).
1576
1577The player should be reaosnably safe there for short amounts of time. You
1578I<MUST> call C<leave_link> as soon as possible, though.
1579
1580=item $player_object->leave_link ($map, $x, $y)
1581
1582Moves the player out of the specila link map onto the given map. If the
1583map is not valid (or omitted), the player will be moved back to the
1584location he/she was before the call to C<enter_link>, or, if that fails,
1585to the emergency map position.
1586
1587Might block.
1588
1589=cut
1590
1591sub cf::object::player::enter_link {
1592 my ($self) = @_;
1593
1594 $self->deactivate_recursive;
1595
1596 return if $self->map == $LINK_MAP;
1597
1598 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1599 if $self->map;
1600
1601 $self->enter_map ($LINK_MAP, 20, 20);
1602}
1603
1604sub cf::object::player::leave_link {
1605 my ($self, $map, $x, $y) = @_;
1606
1607 my $link_pos = delete $self->{_link_pos};
1608
1609 unless ($map) {
1610 # restore original map position
1611 ($map, $x, $y) = @{ $link_pos || [] };
1612 $map = cf::map::find $map;
1613
1614 unless ($map) {
1615 ($map, $x, $y) = @$EMERGENCY_POSITION;
1616 $map = cf::map::find $map
1617 or die "FATAL: cannot load emergency map\n";
1618 }
1619 }
1620
1621 ($x, $y) = (-1, -1)
1622 unless (defined $x) && (defined $y);
1623
1624 # use -1 or undef as default coordinates, not 0, 0
1625 ($x, $y) = ($map->enter_x, $map->enter_y)
1626 if $x <=0 && $y <= 0;
1627
1628 $map->load;
1629
1630 return unless $self->contr->active;
1631 $self->activate_recursive;
1632 $self->enter_map ($map, $x, $y);
1633}
1634
1635cf::player->attach (
1636 on_logout => sub {
1637 my ($pl) = @_;
1638
1639 # abort map switching before logout
1640 if ($pl->ob->{_link_pos}) {
1641 cf::sync_job {
1642 $pl->ob->leave_link
1643 };
1644 }
1645 },
1646 on_login => sub {
1647 my ($pl) = @_;
1648
1649 # try to abort aborted map switching on player login :)
1650 # should happen only on crashes
1651 if ($pl->ob->{_link_pos}) {
1652 $pl->ob->enter_link;
1653 (async {
1654 # we need this sleep as the login has a concurrent enter_exit running
1655 # and this sleep increases chances of the player not ending up in scorn
1656 $pl->ob->reply (undef,
1657 "There was an internal problem at your last logout, "
1658 . "the server will try to bring you to your intended destination in a second.",
1659 cf::NDI_RED);
1660 Coro::Timer::sleep 1;
1661 $pl->ob->leave_link;
1662 })->prio (2);
1663 }
1664 },
1665);
1666
1667=item $player_object->goto ($path, $x, $y)
1668
1669=cut
1670
1671sub cf::object::player::goto {
1672 my ($self, $path, $x, $y) = @_;
1673
1674 $self->enter_link;
1675
1676 (async {
1677 $path = new cf::path $path;
1678
1679 my $map = cf::map::find $path->as_string;
1680 $map = $map->customise_for ($self) if $map;
1681
1682# warn "entering ", $map->path, " at ($x, $y)\n"
1683# if $map;
1684
1685 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1686
1687 $self->leave_link ($map, $x, $y);
1688 })->prio (1);
1689}
1690
1691=item $player_object->enter_exit ($exit_object)
1692
1693=cut
1694
1695sub parse_random_map_params {
1696 my ($spec) = @_;
1697
1698 my $rmp = { # defaults
1699 xsize => 10,
1700 ysize => 10,
1701 };
1702
1703 for (split /\n/, $spec) {
1704 my ($k, $v) = split /\s+/, $_, 2;
1705
1706 $rmp->{lc $k} = $v if (length $k) && (length $v);
1707 }
1708
1709 $rmp
1710}
1711
1712sub prepare_random_map {
1713 my ($exit) = @_;
1714
1715 # all this does is basically replace the /! path by
1716 # a new random map path (?random/...) with a seed
1717 # that depends on the exit object
1718
1719 my $rmp = parse_random_map_params $exit->msg;
1720
1721 if ($exit->map) {
1722 $rmp->{region} = $exit->map->region_name;
1723 $rmp->{origin_map} = $exit->map->path;
1724 $rmp->{origin_x} = $exit->x;
1725 $rmp->{origin_y} = $exit->y;
1726 }
1727
1728 $rmp->{random_seed} ||= $exit->random_seed;
1729
1730 my $data = cf::to_json $rmp;
1731 my $md5 = Digest::MD5::md5_hex $data;
1732
1733 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) {
1734 aio_write $fh, 0, (length $data), $data, 0;
1735
1736 $exit->slaying ("?random/$md5");
1737 $exit->msg (undef);
1738 }
1739}
1740
1741sub cf::object::player::enter_exit {
1742 my ($self, $exit) = @_;
1743
1744 return unless $self->type == cf::PLAYER;
1745
1746 $self->enter_link;
1747
1748 (async {
1749 $self->deactivate_recursive; # just to be sure
1750 unless (eval {
1751 prepare_random_map $exit
1752 if $exit->slaying eq "/!";
1753
1754 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1755 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1756
1757 1;
1758 }) {
1759 $self->message ("Something went wrong deep within the crossfire server. "
1760 . "I'll try to bring you back to the map you were before. "
1761 . "Please report this to the dungeon master",
1762 cf::NDI_UNIQUE | cf::NDI_RED);
1763
1764 warn "ERROR in enter_exit: $@";
1765 $self->leave_link;
1766 }
1767 })->prio (1);
1768}
1769
943=head3 cf::client 1770=head3 cf::client
944 1771
945=over 4 1772=over 4
946 1773
947=item $client->send_drawinfo ($text, $flags) 1774=item $client->send_drawinfo ($text, $flags)
990 on_reply => sub { 1817 on_reply => sub {
991 my ($ns, $msg) = @_; 1818 my ($ns, $msg) = @_;
992 1819
993 # this weird shuffling is so that direct followup queries 1820 # this weird shuffling is so that direct followup queries
994 # get handled first 1821 # get handled first
995 my $queue = delete $ns->{query_queue}; 1822 my $queue = delete $ns->{query_queue}
1823 or return; # be conservative, not sure how that can happen, but we saw a crash here
996 1824
997 (shift @$queue)->[1]->($msg); 1825 (shift @$queue)->[1]->($msg);
998 1826
999 push @{ $ns->{query_queue} }, @$queue; 1827 push @{ $ns->{query_queue} }, @$queue;
1000 1828
1006 } 1834 }
1007 } 1835 }
1008 }, 1836 },
1009); 1837);
1010 1838
1011=item $client->coro (\&cb) 1839=item $client->async (\&cb)
1012 1840
1013Create a new coroutine, running the specified callback. The coroutine will 1841Create a new coroutine, running the specified callback. The coroutine will
1014be automatically cancelled when the client gets destroyed (e.g. on logout, 1842be automatically cancelled when the client gets destroyed (e.g. on logout,
1015or loss of connection). 1843or loss of connection).
1016 1844
1017=cut 1845=cut
1018 1846
1019sub cf::client::coro { 1847sub cf::client::async {
1020 my ($self, $cb) = @_; 1848 my ($self, $cb) = @_;
1021 1849
1022 my $coro; $coro = async { 1850 my $coro = &Coro::async ($cb);
1023 eval {
1024 $cb->();
1025 };
1026 warn $@ if $@;
1027 };
1028 1851
1029 $coro->on_destroy (sub { 1852 $coro->on_destroy (sub {
1030 delete $self->{_coro}{$coro+0}; 1853 delete $self->{_coro}{$coro+0};
1031 }); 1854 });
1032 1855
1204 2027
1205{ 2028{
1206 my $path = cf::localdir . "/database.pst"; 2029 my $path = cf::localdir . "/database.pst";
1207 2030
1208 sub db_load() { 2031 sub db_load() {
1209 warn "loading database $path\n";#d# remove later
1210 $DB = stat $path ? Storable::retrieve $path : { }; 2032 $DB = stat $path ? Storable::retrieve $path : { };
1211 } 2033 }
1212 2034
1213 my $pid; 2035 my $pid;
1214 2036
1215 sub db_save() { 2037 sub db_save() {
1216 warn "saving database $path\n";#d# remove later
1217 waitpid $pid, 0 if $pid; 2038 waitpid $pid, 0 if $pid;
1218 if (0 == ($pid = fork)) { 2039 if (0 == ($pid = fork)) {
1219 $DB->{_meta}{version} = 1; 2040 $DB->{_meta}{version} = 1;
1220 Storable::nstore $DB, "$path~"; 2041 Storable::nstore $DB, "$path~";
1221 rename "$path~", $path; 2042 rename "$path~", $path;
1269 open my $fh, "<:utf8", cf::confdir . "/config" 2090 open my $fh, "<:utf8", cf::confdir . "/config"
1270 or return; 2091 or return;
1271 2092
1272 local $/; 2093 local $/;
1273 *CFG = YAML::Syck::Load <$fh>; 2094 *CFG = YAML::Syck::Load <$fh>;
2095
2096 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2097
2098 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2099 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2100
2101 if (exists $CFG{mlockall}) {
2102 eval {
2103 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2104 and die "WARNING: m(un)lockall failed: $!\n";
2105 };
2106 warn $@ if $@;
2107 }
1274} 2108}
1275 2109
1276sub main { 2110sub main {
2111 # we must not ever block the main coroutine
2112 local $Coro::idle = sub {
2113 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2114 async { Event::one_event };
2115 };
2116
1277 cfg_load; 2117 cfg_load;
1278 db_load; 2118 db_load;
1279 load_extensions; 2119 load_extensions;
1280 Event::loop; 2120 Event::loop;
1281} 2121}
1282 2122
1283############################################################################# 2123#############################################################################
1284# initialisation 2124# initialisation
1285 2125
1286sub _perl_reload() { 2126sub reload() {
1287 # can/must only be called in main 2127 # can/must only be called in main
1288 if ($Coro::current != $Coro::main) { 2128 if ($Coro::current != $Coro::main) {
1289 warn "can only reload from main coroutine\n"; 2129 warn "can only reload from main coroutine\n";
1290 return; 2130 return;
1291 } 2131 }
1292 2132
1293 warn "reloading..."; 2133 warn "reloading...";
1294 2134
1295 local $FREEZE = 1; 2135 my $guard = freeze_mainloop;
1296 cf::emergency_save; 2136 cf::emergency_save;
1297 2137
1298 eval { 2138 eval {
1299 # if anything goes wrong in here, we should simply crash as we already saved 2139 # if anything goes wrong in here, we should simply crash as we already saved
1300 2140
1362 cf::load_extensions; 2202 cf::load_extensions;
1363 2203
1364 # reattach attachments to objects 2204 # reattach attachments to objects
1365 warn "reattach"; 2205 warn "reattach";
1366 _global_reattach; 2206 _global_reattach;
2207 reattach $_ for values %MAP;
1367 }; 2208 };
1368 2209
1369 if ($@) { 2210 if ($@) {
1370 warn $@; 2211 warn $@;
1371 warn "error while reloading, exiting."; 2212 warn "error while reloading, exiting.";
1373 } 2214 }
1374 2215
1375 warn "reloaded successfully"; 2216 warn "reloaded successfully";
1376}; 2217};
1377 2218
1378sub perl_reload() { 2219#############################################################################
1379 _perl_reload; 2220
2221unless ($LINK_MAP) {
2222 $LINK_MAP = cf::map::new;
2223
2224 $LINK_MAP->width (41);
2225 $LINK_MAP->height (41);
2226 $LINK_MAP->alloc;
2227 $LINK_MAP->path ("{link}");
2228 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2229 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2230
2231 # dirty hack because... archetypes are not yet loaded
2232 Event->timer (
2233 after => 10,
2234 cb => sub {
2235 $_[0]->w->cancel;
2236
2237 # provide some exits "home"
2238 my $exit = cf::object::new "exit";
2239
2240 $exit->slaying ($EMERGENCY_POSITION->[0]);
2241 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2242 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2243
2244 $LINK_MAP->insert ($exit->clone, 19, 19);
2245 $LINK_MAP->insert ($exit->clone, 19, 20);
2246 $LINK_MAP->insert ($exit->clone, 19, 21);
2247 $LINK_MAP->insert ($exit->clone, 20, 19);
2248 $LINK_MAP->insert ($exit->clone, 20, 21);
2249 $LINK_MAP->insert ($exit->clone, 21, 19);
2250 $LINK_MAP->insert ($exit->clone, 21, 20);
2251 $LINK_MAP->insert ($exit->clone, 21, 21);
2252
2253 $exit->destroy;
2254 });
2255
2256 $LINK_MAP->{deny_save} = 1;
2257 $LINK_MAP->{deny_reset} = 1;
2258
2259 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
1380} 2260}
1381 2261
1382register "<global>", __PACKAGE__; 2262register "<global>", __PACKAGE__;
1383 2263
1384register_command "perl-reload" => sub { 2264register_command "reload" => sub {
1385 my ($who, $arg) = @_; 2265 my ($who, $arg) = @_;
1386 2266
1387 if ($who->flag (FLAG_WIZ)) { 2267 if ($who->flag (FLAG_WIZ)) {
2268 $who->message ("start of reload.");
2269 reload;
1388 $who->message ("reloading..."); 2270 $who->message ("end of reload.");
1389 _perl_reload;
1390 } 2271 }
1391}; 2272};
1392 2273
1393unshift @INC, $LIBDIR; 2274unshift @INC, $LIBDIR;
1394 2275
1396 reentrant => 0, 2277 reentrant => 0,
1397 prio => 0, 2278 prio => 0,
1398 at => $NEXT_TICK || $TICK, 2279 at => $NEXT_TICK || $TICK,
1399 data => WF_AUTOCANCEL, 2280 data => WF_AUTOCANCEL,
1400 cb => sub { 2281 cb => sub {
1401 unless ($FREEZE) {
1402 cf::server_tick; # one server iteration 2282 cf::server_tick; # one server iteration
1403 $RUNTIME += $TICK; 2283 $RUNTIME += $TICK;
1404 }
1405
1406 $NEXT_TICK += $TICK; 2284 $NEXT_TICK += $TICK;
1407 2285
1408 # if we are delayed by four ticks or more, skip them all 2286 # if we are delayed by four ticks or more, skip them all
1409 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2287 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1410 2288
1413 }, 2291 },
1414); 2292);
1415 2293
1416IO::AIO::max_poll_time $TICK * 0.2; 2294IO::AIO::max_poll_time $TICK * 0.2;
1417 2295
2296Event->io (
1418Event->io (fd => IO::AIO::poll_fileno, 2297 fd => IO::AIO::poll_fileno,
1419 poll => 'r', 2298 poll => 'r',
1420 prio => 5, 2299 prio => 5,
1421 data => WF_AUTOCANCEL, 2300 data => WF_AUTOCANCEL,
1422 cb => \&IO::AIO::poll_cb); 2301 cb => \&IO::AIO::poll_cb,
2302);
1423 2303
1424# we must not ever block the main coroutine 2304Event->timer (
1425$Coro::idle = sub { 2305 data => WF_AUTOCANCEL,
1426 #Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d# 2306 after => 0,
1427 warn "FATAL: Coro::idle was called, major BUG\n"; 2307 interval => 10,
2308 cb => sub {
1428 (Coro::unblock_sub { 2309 (Coro::unblock_sub {
1429 Event::one_event; 2310 write_runtime
2311 or warn "ERROR: unable to write runtime file: $!";
1430 })->(); 2312 })->();
1431}; 2313 },
2314);
2315
2316END { cf::emergency_save }
1432 2317
14331 23181
1434 2319

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines