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.102 by root, Wed Dec 27 15:20:54 2006 UTC vs.
Revision 1.129 by root, Wed Jan 3 00:41:19 2007 UTC

8use Storable; 8use Storable;
9use Opcode; 9use Opcode;
10use Safe; 10use Safe;
11use Safe::Hole; 11use Safe::Hole;
12 12
13use Coro; 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;
18 19
20use Digest::MD5;
21use Fcntl;
19use IO::AIO 2.3; 22use IO::AIO 2.31 ();
20use YAML::Syck (); 23use YAML::Syck ();
21use Time::HiRes; 24use Time::HiRes;
22 25
23use 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
24 27
25# 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?
26$YAML::Syck::ImplicitUnicode = 1; 29$YAML::Syck::ImplicitUnicode = 1;
27 30
28$Coro::main->prio (Coro::PRIO_MIN); 31$Coro::main->prio (2); # run main coroutine ("the server") with very high priority
29 32
30sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
31 34
32our %COMMAND = (); 35our %COMMAND = ();
33our %COMMAND_TIME = (); 36our %COMMAND_TIME = ();
37our $LIBDIR = datadir . "/ext"; 40our $LIBDIR = datadir . "/ext";
38 41
39our $TICK = MAX_TIME * 1e-6; 42our $TICK = MAX_TIME * 1e-6;
40our $TICK_WATCHER; 43our $TICK_WATCHER;
41our $NEXT_TICK; 44our $NEXT_TICK;
45our $NOW;
42 46
43our %CFG; 47our %CFG;
44 48
45our $UPTIME; $UPTIME ||= time; 49our $UPTIME; $UPTIME ||= time;
50our $RUNTIME;
51
52our %MAP; # all maps
53our $LINK_MAP; # the special {link} map
54our $FREEZE;
55our $RANDOM_MAPS = cf::localdir . "/random";
56our %EXT_CORO;
57
58binmode STDOUT;
59binmode STDERR;
60
61# read virtual server time, if available
62unless ($RUNTIME || !-e cf::localdir . "/runtime") {
63 open my $fh, "<", cf::localdir . "/runtime"
64 or die "unable to read runtime file: $!";
65 $RUNTIME = <$fh> + 0.;
66}
67
68mkdir cf::localdir;
69mkdir cf::localdir . "/" . cf::playerdir;
70mkdir cf::localdir . "/" . cf::tmpdir;
71mkdir cf::localdir . "/" . cf::uniquedir;
72mkdir $RANDOM_MAPS;
73
74# a special map that is always available
75our $LINK_MAP;
76
77our $EMERGENCY_POSITION = $cf::CFG{emergency_position} || ["/world/world_105_115", 5, 37];
46 78
47############################################################################# 79#############################################################################
48 80
49=head2 GLOBAL VARIABLES 81=head2 GLOBAL VARIABLES
50 82
51=over 4 83=over 4
52 84
53=item $cf::UPTIME 85=item $cf::UPTIME
54 86
55The timestamp of the server start (so not actually an uptime). 87The timestamp of the server start (so not actually an uptime).
88
89=item $cf::RUNTIME
90
91The time this server has run, starts at 0 and is increased by $cf::TICK on
92every server tick.
56 93
57=item $cf::LIBDIR 94=item $cf::LIBDIR
58 95
59The perl library directory, where extensions and cf-specific modules can 96The perl library directory, where extensions and cf-specific modules can
60be found. It will be added to C<@INC> automatically. 97be found. It will be added to C<@INC> automatically.
98
99=item $cf::NOW
100
101The time of the last (current) server tick.
61 102
62=item $cf::TICK 103=item $cf::TICK
63 104
64The interval between server ticks, in seconds. 105The interval between server ticks, in seconds.
65 106
73=cut 114=cut
74 115
75BEGIN { 116BEGIN {
76 *CORE::GLOBAL::warn = sub { 117 *CORE::GLOBAL::warn = sub {
77 my $msg = join "", @_; 118 my $msg = join "", @_;
119 utf8::encode $msg;
120
78 $msg .= "\n" 121 $msg .= "\n"
79 unless $msg =~ /\n$/; 122 unless $msg =~ /\n$/;
80 123
81 print STDERR "cfperl: $msg";
82 LOG llevError, "cfperl: $msg"; 124 LOG llevError, "cfperl: $msg";
83 }; 125 };
84} 126}
85 127
86@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 128@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
139sub to_json($) { 181sub to_json($) {
140 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 182 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
141 JSON::Syck::Dump $_[0] 183 JSON::Syck::Dump $_[0]
142} 184}
143 185
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
209
210Wait until the given lock is available. See cf::lock_acquire.
211
212=item my $lock = cf::lock_acquire $string
213
214Wait 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,
216for example when the coroutine gets canceled), the lock is automatically
217returned.
218
219Lock names should begin with a unique identifier (for example, find_map
220uses map_find and load_map uses map_load).
221
222=cut
223
224our %LOCK;
225
226sub lock_wait($) {
227 my ($key) = @_;
228
229 # wait for lock, if any
230 while ($LOCK{$key}) {
231 push @{ $LOCK{$key} }, $Coro::current;
232 Coro::schedule;
233 }
234}
235
236sub lock_acquire($) {
237 my ($key) = @_;
238
239 # wait, to be sure we are not locked
240 lock_wait $key;
241
242 $LOCK{$key} = [];
243
244 cf::guard {
245 # wake up all waiters, to be on the safe side
246 $_->ready for @{ delete $LOCK{$key} };
247 }
248}
249
250=item cf::async { BLOCK }
251
252Like C<Coro::async>, but runs the given BLOCK in an eval and only logs the
253error instead of exiting the server in case of a problem.
254
255=cut
256
257sub async(&) {
258 my ($cb) = @_;
259
260 Coro::async {
261 eval { $cb->() };
262 warn $@ if $@;
263 }
264}
265
266=item cf::sync_job { BLOCK }
267
268The design of crossfire+ requires that the main coro ($Coro::main) is
269always able to handle events or runnable, as crossfire+ is only partly
270reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
271
272If it must be done, put the blocking parts into C<sync_job>. This will run
273the given BLOCK in another coroutine while waiting for the result. The
274server will be frozen during this time, so the block should either finish
275fast or be very important.
276
277=cut
278
279sub sync_job(&) {
280 my ($job) = @_;
281
282 if ($Coro::current == $Coro::main) {
283 # this is the main coro, too bad, we have to block
284 # till the operation succeeds, freezing the server :/
285
286 # TODO: use suspend/resume instead
287 # (but this is cancel-safe)
288 local $FREEZE = 1;
289
290 my $busy = 1;
291 my @res;
292
293 (Coro::async {
294 @res = eval { $job->() };
295 warn $@ if $@;
296 undef $busy;
297 })->prio (Coro::PRIO_MAX);
298
299 while ($busy) {
300 Coro::cede_notself;
301 Event::one_event unless Coro::nready;
302 }
303
304 wantarray ? @res : $res[0]
305 } else {
306 # we are in another coroutine, how wonderful, everything just works
307
308 $job->()
309 }
310}
311
312=item $coro = cf::coro { BLOCK }
313
314Creates and returns a new coro. This coro is automcatially being canceled
315when the extension calling this is being unloaded.
316
317=cut
318
319sub coro(&) {
320 my $cb = shift;
321
322 my $coro = &cf::async ($cb);
323
324 $coro->on_destroy (sub {
325 delete $EXT_CORO{$coro+0};
326 });
327 $EXT_CORO{$coro+0} = $coro;
328
329 $coro
330}
331
332sub write_runtime {
333 my $runtime = cf::localdir . "/runtime";
334
335 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
336 or return;
337
338 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock
339 (aio_write $fh, 0, (length $value), $value, 0) <= 0
340 and return;
341
342 aio_fsync $fh
343 and return;
344
345 close $fh
346 or return;
347
348 aio_rename "$runtime~", $runtime
349 and return;
350
351 1
352}
353
144=back 354=back
145 355
146=cut 356=cut
357
358#############################################################################
359
360package cf::path;
361
362sub new {
363 my ($class, $path, $base) = @_;
364
365 $path = $path->as_string if ref $path;
366
367 my $self = bless { }, $class;
368
369 # {... are special paths that are not touched
370 # ?xxx/... are special absolute paths
371 # ?random/... random maps
372 # /! non-realised random map exit
373 # /... normal maps
374 # ~/... per-player maps without a specific player (DO NOT USE)
375 # ~user/... per-player map of a specific user
376
377 if ($path =~ /^{/) {
378 # fine as it is
379 } elsif ($path =~ s{^\?random/}{}) {
380 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
381 $self->{random} = cf::from_json $data;
382 } else {
383 if ($path =~ s{^~([^/]+)?}{}) {
384 $self->{user_rel} = 1;
385
386 if (defined $1) {
387 $self->{user} = $1;
388 } elsif ($base =~ m{^~([^/]+)/}) {
389 $self->{user} = $1;
390 } else {
391 warn "cannot resolve user-relative path without user <$path,$base>\n";
392 }
393 } elsif ($path =~ /^\//) {
394 # already absolute
395 } else {
396 $base =~ s{[^/]+/?$}{};
397 return $class->new ("$base/$path");
398 }
399
400 for ($path) {
401 redo if s{/\.?/}{/};
402 redo if s{/[^/]+/\.\./}{/};
403 }
404 }
405
406 $self->{path} = $path;
407
408 $self
409}
410
411# the name / primary key / in-game path
412sub as_string {
413 my ($self) = @_;
414
415 $self->{user_rel} ? "~$self->{user}$self->{path}"
416 : $self->{random} ? "?random/$self->{path}"
417 : $self->{path}
418}
419
420# the displayed name, this is a one way mapping
421sub visible_name {
422 my ($self) = @_;
423
424# if (my $rmp = $self->{random}) {
425# # todo: be more intelligent about this
426# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
427# } else {
428 $self->as_string
429# }
430}
431
432# escape the /'s in the path
433sub _escaped_path {
434 # ∕ is U+2215
435 (my $path = $_[0]{path}) =~ s/\//∕/g;
436 $path
437}
438
439# the original (read-only) location
440sub load_path {
441 my ($self) = @_;
442
443 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
444}
445
446# the temporary/swap location
447sub save_path {
448 my ($self) = @_;
449
450 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
451 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
452 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
453}
454
455# the unique path, might be eq to save_path
456sub uniq_path {
457 my ($self) = @_;
458
459 $self->{user_rel} || $self->{random}
460 ? undef
461 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
462}
463
464# return random map parameters, or undef
465sub random_map_params {
466 my ($self) = @_;
467
468 $self->{random}
469}
470
471# this is somewhat ugly, but style maps do need special treatment
472sub is_style_map {
473 $_[0]{path} =~ m{^/styles/}
474}
475
476package cf;
147 477
148############################################################################# 478#############################################################################
149 479
150=head2 ATTACHABLE OBJECTS 480=head2 ATTACHABLE OBJECTS
151 481
505); 835);
506 836
507sub object_freezer_save { 837sub object_freezer_save {
508 my ($filename, $rdata, $objs) = @_; 838 my ($filename, $rdata, $objs) = @_;
509 839
840 sync_job {
510 if (length $$rdata) { 841 if (length $$rdata) {
511 warn sprintf "saving %s (%d,%d)\n", 842 warn sprintf "saving %s (%d,%d)\n",
512 $filename, length $$rdata, scalar @$objs; 843 $filename, length $$rdata, scalar @$objs;
513 844
514 if (open my $fh, ">:raw", "$filename~") { 845 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
515 chmod SAVE_MODE, $fh;
516 syswrite $fh, $$rdata;
517 close $fh;
518
519 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
520 chmod SAVE_MODE, $fh; 846 chmod SAVE_MODE, $fh;
521 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 847 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
848 aio_fsync $fh;
522 close $fh; 849 close $fh;
850
851 if (@$objs) {
852 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
853 chmod SAVE_MODE, $fh;
854 my $data = Storable::nfreeze { version => 1, objs => $objs };
855 aio_write $fh, 0, (length $data), $data, 0;
856 aio_fsync $fh;
857 close $fh;
523 rename "$filename.pst~", "$filename.pst"; 858 aio_rename "$filename.pst~", "$filename.pst";
859 }
860 } else {
861 aio_unlink "$filename.pst";
862 }
863
864 aio_rename "$filename~", $filename;
524 } else { 865 } else {
525 unlink "$filename.pst"; 866 warn "FATAL: $filename~: $!\n";
526 } 867 }
527
528 rename "$filename~", $filename;
529 } else { 868 } else {
530 warn "FATAL: $filename~: $!\n";
531 }
532 } else {
533 unlink $filename; 869 aio_unlink $filename;
534 unlink "$filename.pst"; 870 aio_unlink "$filename.pst";
871 }
535 } 872 }
536} 873}
537 874
538sub object_freezer_as_string { 875sub object_freezer_as_string {
539 my ($rdata, $objs) = @_; 876 my ($rdata, $objs) = @_;
544} 881}
545 882
546sub object_thawer_load { 883sub object_thawer_load {
547 my ($filename) = @_; 884 my ($filename) = @_;
548 885
549 local $/; 886 my ($data, $av);
550 887
551 my $av; 888 (aio_load $filename, $data) >= 0
889 or return;
552 890
553 #TODO: use sysread etc. 891 unless (aio_stat "$filename.pst") {
554 if (open my $data, "<:raw:perlio", $filename) { 892 (aio_load "$filename.pst", $av) >= 0
555 $data = <$data>; 893 or return;
556 if (open my $pst, "<:raw:perlio", "$filename.pst") {
557 $av = eval { (Storable::thaw <$pst>)->{objs} }; 894 $av = eval { (Storable::thaw $av)->{objs} };
558 } 895 }
896
897 warn sprintf "loading %s (%d)\n",
898 $filename, length $data, scalar @{$av || []};#d#
559 return ($data, $av); 899 return ($data, $av);
560 }
561
562 ()
563} 900}
564 901
565############################################################################# 902#############################################################################
566# command handling &c 903# command handling &c
567 904
788 $self->send ("ext " . to_json \%msg); 1125 $self->send ("ext " . to_json \%msg);
789} 1126}
790 1127
791=back 1128=back
792 1129
1130
1131=head3 cf::map
1132
1133=over 4
1134
1135=cut
1136
1137package cf::map;
1138
1139use Fcntl;
1140use Coro::AIO;
1141
1142our $MAX_RESET = 7200;
1143our $DEFAULT_RESET = 3600;
1144
1145sub generate_random_map {
1146 my ($path, $rmp) = @_;
1147
1148 # mit "rum" bekleckern, nicht
1149 cf::map::_create_random_map
1150 $path,
1151 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1152 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1153 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1154 $rmp->{exit_on_final_map},
1155 $rmp->{xsize}, $rmp->{ysize},
1156 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1157 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1158 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1159 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1160 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1161 (cf::region::find $rmp->{region})
1162}
1163
1164# and all this just because we cannot iterate over
1165# all maps in C++...
1166sub change_all_map_light {
1167 my ($change) = @_;
1168
1169 $_->change_map_light ($change)
1170 for grep $_->outdoor, values %cf::MAP;
1171}
1172
1173sub try_load_header($) {
1174 my ($path) = @_;
1175
1176 utf8::encode $path;
1177 aio_open $path, O_RDONLY, 0
1178 or return;
1179
1180 my $map = cf::map::new
1181 or return;
1182
1183 $map->load_header ($path)
1184 or return;
1185
1186 $map->{load_path} = $path;
1187
1188 $map
1189}
1190
1191sub find_map;
1192sub find_map {
1193 my ($path, $origin) = @_;
1194
1195 #warn "find_map<$path,$origin>\n";#d#
1196
1197 $path = new cf::path $path, $origin && $origin->path;
1198 my $key = $path->as_string;
1199
1200 cf::lock_wait "map_find:$key";
1201
1202 $cf::MAP{$key} || do {
1203 my $guard = cf::lock_acquire "map_find:$key";
1204
1205 # do it the slow way
1206 my $map = try_load_header $path->save_path;
1207
1208 if ($map) {
1209 # safety
1210 $map->{instantiate_time} = $cf::RUNTIME
1211 if $map->{instantiate_time} > $cf::RUNTIME;
1212 } else {
1213 if (my $rmp = $path->random_map_params) {
1214 $map = generate_random_map $key, $rmp;
1215 } else {
1216 $map = try_load_header $path->load_path;
1217 }
1218
1219 $map or return;
1220
1221 $map->{load_original} = 1;
1222 $map->{instantiate_time} = $cf::RUNTIME;
1223 $map->instantiate;
1224
1225 # per-player maps become, after loading, normal maps
1226 $map->per_player (0) if $path->{user_rel};
1227 }
1228
1229 $map->path ($key);
1230 $map->{path} = $path;
1231 $map->{last_save} = $cf::RUNTIME;
1232 $map->last_access ($cf::RUNTIME);
1233
1234 if ($map->should_reset) {
1235 $map->reset;
1236 undef $guard;
1237 $map = find_map $path
1238 or return;
1239 }
1240
1241 $cf::MAP{$key} = $map
1242 }
1243}
1244
1245sub load {
1246 my ($self) = @_;
1247
1248 my $path = $self->{path};
1249 my $guard = cf::lock_acquire "map_load:" . $path->as_string;
1250
1251 return if $self->in_memory != cf::MAP_SWAPPED;
1252
1253 $self->in_memory (cf::MAP_LOADING);
1254
1255 $self->alloc;
1256 $self->load_objects ($self->{load_path}, 1)
1257 or return;
1258
1259 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1260 if delete $self->{load_original};
1261
1262 if (my $uniq = $path->uniq_path) {
1263 utf8::encode $uniq;
1264 if (aio_open $uniq, O_RDONLY, 0) {
1265 $self->clear_unique_items;
1266 $self->load_objects ($uniq, 0);
1267 }
1268 }
1269
1270 # now do the right thing for maps
1271 $self->link_multipart_objects;
1272
1273 if ($self->{path}->is_style_map) {
1274 $self->{deny_save} = 1;
1275 $self->{deny_reset} = 1;
1276 } else {
1277 $self->fix_auto_apply;
1278 $self->decay_objects;
1279 $self->update_buttons;
1280 $self->set_darkness_map;
1281 $self->difficulty ($self->estimate_difficulty)
1282 unless $self->difficulty;
1283 $self->activate;
1284 }
1285
1286 $self->in_memory (cf::MAP_IN_MEMORY);
1287}
1288
1289sub load_map_sync {
1290 my ($path, $origin) = @_;
1291
1292 #warn "load_map_sync<$path, $origin>\n";#d#
1293
1294 cf::sync_job {
1295 my $map = cf::map::find_map $path, $origin
1296 or return;
1297 $map->load;
1298 $map
1299 }
1300}
1301
1302sub save {
1303 my ($self) = @_;
1304
1305 $self->{last_save} = $cf::RUNTIME;
1306
1307 return unless $self->dirty;
1308
1309 my $save = $self->{path}->save_path; utf8::encode $save;
1310 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
1311
1312 $self->{load_path} = $save;
1313
1314 return if $self->{deny_save};
1315
1316 if ($uniq) {
1317 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1318 $self->save_objects ($uniq, cf::IO_UNIQUES);
1319 } else {
1320 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1321 }
1322}
1323
1324sub swap_out {
1325 my ($self) = @_;
1326
1327 return if $self->players;
1328 return if $self->in_memory != cf::MAP_IN_MEMORY;
1329 return if $self->{deny_save};
1330
1331 $self->save;
1332 $self->clear;
1333 $self->in_memory (cf::MAP_SWAPPED);
1334}
1335
1336sub reset_at {
1337 my ($self) = @_;
1338
1339 # TODO: safety, remove and allow resettable per-player maps
1340 return 1e99 if $self->{path}{user_rel};
1341 return 1e99 if $self->{deny_reset};
1342
1343 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1344 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1345
1346 $time + $to
1347}
1348
1349sub should_reset {
1350 my ($self) = @_;
1351
1352 $self->reset_at <= $cf::RUNTIME
1353}
1354
1355sub unlink_save {
1356 my ($self) = @_;
1357
1358 utf8::encode (my $save = $self->{path}->save_path);
1359 aioreq_pri 3; IO::AIO::aio_unlink $save;
1360 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1361}
1362
1363sub rename {
1364 my ($self, $new_path) = @_;
1365
1366 $self->unlink_save;
1367
1368 delete $cf::MAP{$self->path};
1369 $self->{path} = new cf::path $new_path;
1370 $self->path ($self->{path}->as_string);
1371 $cf::MAP{$self->path} = $self;
1372
1373 $self->save;
1374}
1375
1376sub reset {
1377 my ($self) = @_;
1378
1379 return if $self->players;
1380 return if $self->{path}{user_rel};#d#
1381
1382 warn "resetting map ", $self->path;#d#
1383
1384 delete $cf::MAP{$self->path};
1385
1386 $_->clear_links_to ($self) for values %cf::MAP;
1387
1388 $self->unlink_save;
1389 $self->destroy;
1390}
1391
1392my $nuke_counter = "aaaa";
1393
1394sub nuke {
1395 my ($self) = @_;
1396
1397 $self->{deny_save} = 1;
1398 $self->reset_timeout (1);
1399 $self->rename ("{nuke}/" . ($nuke_counter++));
1400 $self->reset; # polite request, might not happen
1401}
1402
1403sub customise_for {
1404 my ($map, $ob) = @_;
1405
1406 if ($map->per_player) {
1407 return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path};
1408 }
1409
1410 $map
1411}
1412
1413sub emergency_save {
1414 local $cf::FREEZE = 1;
1415
1416 warn "enter emergency map save\n";
1417
1418 cf::sync_job {
1419 warn "begin emergency map save\n";
1420 $_->save for values %cf::MAP;
1421 };
1422
1423 warn "end emergency map save\n";
1424}
1425
1426package cf;
1427
1428=back
1429
1430
793=head3 cf::object::player 1431=head3 cf::object::player
794 1432
795=over 4 1433=over 4
796 1434
797=item $player_object->reply ($npc, $msg[, $flags]) 1435=item $player_object->reply ($npc, $msg[, $flags])
832 (ref $cf::CFG{"may_$access"} 1470 (ref $cf::CFG{"may_$access"}
833 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 1471 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
834 : $cf::CFG{"may_$access"}) 1472 : $cf::CFG{"may_$access"})
835} 1473}
836 1474
1475=item $player_object->enter_link
1476
1477Freezes the player and moves him/her to a special map (C<{link}>).
1478
1479The player should be reaosnably safe there for short amounts of time. You
1480I<MUST> call C<leave_link> as soon as possible, though.
1481
1482=item $player_object->leave_link ($map, $x, $y)
1483
1484Moves the player out of the specila link map onto the given map. If the
1485map is not valid (or omitted), the player will be moved back to the
1486location he/she was before the call to C<enter_link>, or, if that fails,
1487to the emergency map position.
1488
1489Might block.
1490
1491=cut
1492
1493sub cf::object::player::enter_link {
1494 my ($self) = @_;
1495
1496 $self->deactivate_recursive;
1497
1498 return if $self->map == $LINK_MAP;
1499
1500 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1501 if $self->map;
1502
1503 $self->enter_map ($LINK_MAP, 20, 20);
1504}
1505
1506sub cf::object::player::leave_link {
1507 my ($self, $map, $x, $y) = @_;
1508
1509 my $link_pos = delete $self->{_link_pos};
1510
1511 unless ($map) {
1512 # restore original map position
1513 ($map, $x, $y) = @{ $link_pos || [] };
1514 $map = cf::map::find_map $map;
1515
1516 unless ($map) {
1517 ($map, $x, $y) = @$EMERGENCY_POSITION;
1518 $map = cf::map::find_map $map
1519 or die "FATAL: cannot load emergency map\n";
1520 }
1521 }
1522
1523 ($x, $y) = (-1, -1)
1524 unless (defined $x) && (defined $y);
1525
1526 # use -1 or undef as default coordinates, not 0, 0
1527 ($x, $y) = ($map->enter_x, $map->enter_y)
1528 if $x <=0 && $y <= 0;
1529
1530 $map->load;
1531
1532 $self->activate_recursive;
1533 $self->enter_map ($map, $x, $y);
1534}
1535
1536cf::player->attach (
1537 on_logout => sub {
1538 my ($pl) = @_;
1539
1540 # abort map switching before logout
1541 if ($pl->ob->{_link_pos}) {
1542 cf::sync_job {
1543 $pl->ob->leave_link
1544 };
1545 }
1546 },
1547 on_login => sub {
1548 my ($pl) = @_;
1549
1550 # try to abort aborted map switching on player login :)
1551 # should happen only on crashes
1552 if ($pl->ob->{_link_pos}) {
1553 $pl->ob->enter_link;
1554 cf::async {
1555 # we need this sleep as the login has a concurrent enter_exit running
1556 # and this sleep increases chances of the player not ending up in scorn
1557 Coro::Timer::sleep 1;
1558 $pl->ob->leave_link;
1559 };
1560 }
1561 },
1562);
1563
1564=item $player_object->goto_map ($path, $x, $y)
1565
1566=cut
1567
1568sub cf::object::player::goto_map {
1569 my ($self, $path, $x, $y) = @_;
1570
1571 $self->enter_link;
1572
1573 (cf::async {
1574 $path = new cf::path $path;
1575
1576 my $map = cf::map::find_map $path->as_string;
1577 $map = $map->customise_for ($self) if $map;
1578
1579# warn "entering ", $map->path, " at ($x, $y)\n"
1580# if $map;
1581
1582 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1583
1584 $self->leave_link ($map, $x, $y);
1585 })->prio (1);
1586}
1587
1588=item $player_object->enter_exit ($exit_object)
1589
1590=cut
1591
1592sub parse_random_map_params {
1593 my ($spec) = @_;
1594
1595 my $rmp = { # defaults
1596 xsize => 10,
1597 ysize => 10,
1598 };
1599
1600 for (split /\n/, $spec) {
1601 my ($k, $v) = split /\s+/, $_, 2;
1602
1603 $rmp->{lc $k} = $v if (length $k) && (length $v);
1604 }
1605
1606 $rmp
1607}
1608
1609sub prepare_random_map {
1610 my ($exit) = @_;
1611
1612 # all this does is basically replace the /! path by
1613 # a new random map path (?random/...) with a seed
1614 # that depends on the exit object
1615
1616 my $rmp = parse_random_map_params $exit->msg;
1617
1618 if ($exit->map) {
1619 $rmp->{region} = $exit->map->region_name;
1620 $rmp->{origin_map} = $exit->map->path;
1621 $rmp->{origin_x} = $exit->x;
1622 $rmp->{origin_y} = $exit->y;
1623 }
1624
1625 $rmp->{random_seed} ||= $exit->random_seed;
1626
1627 my $data = cf::to_json $rmp;
1628 my $md5 = Digest::MD5::md5_hex $data;
1629
1630 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) {
1631 aio_write $fh, 0, (length $data), $data, 0;
1632
1633 $exit->slaying ("?random/$md5");
1634 $exit->msg (undef);
1635 }
1636}
1637
1638sub cf::object::player::enter_exit {
1639 my ($self, $exit) = @_;
1640
1641 return unless $self->type == cf::PLAYER;
1642
1643 $self->enter_link;
1644
1645 (cf::async {
1646 unless (eval {
1647 prepare_random_map $exit
1648 if $exit->slaying eq "/!";
1649
1650 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1651 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
1652
1653 1;
1654 }) {
1655 $self->message ("Something went wrong deep within the crossfire server. "
1656 . "I'll try to bring you back to the map you were before. "
1657 . "Please report this to the dungeon master",
1658 cf::NDI_UNIQUE | cf::NDI_RED);
1659
1660 warn "ERROR in enter_exit: $@";
1661 $self->leave_link;
1662 }
1663 })->prio (1);
1664}
1665
837=head3 cf::client 1666=head3 cf::client
838 1667
839=over 4 1668=over 4
840 1669
841=item $client->send_drawinfo ($text, $flags) 1670=item $client->send_drawinfo ($text, $flags)
884 on_reply => sub { 1713 on_reply => sub {
885 my ($ns, $msg) = @_; 1714 my ($ns, $msg) = @_;
886 1715
887 # this weird shuffling is so that direct followup queries 1716 # this weird shuffling is so that direct followup queries
888 # get handled first 1717 # get handled first
889 my $queue = delete $ns->{query_queue}; 1718 my $queue = delete $ns->{query_queue}
1719 or return; # be conservative, not sure how that can happen, but we saw a crash here
890 1720
891 (shift @$queue)->[1]->($msg); 1721 (shift @$queue)->[1]->($msg);
892 1722
893 push @{ $ns->{query_queue} }, @$queue; 1723 push @{ $ns->{query_queue} }, @$queue;
894 1724
911=cut 1741=cut
912 1742
913sub cf::client::coro { 1743sub cf::client::coro {
914 my ($self, $cb) = @_; 1744 my ($self, $cb) = @_;
915 1745
916 my $coro; $coro = async { 1746 my $coro = &cf::async ($cb);
917 eval { 1747
918 $cb->(); 1748 $coro->on_destroy (sub {
919 };
920 warn $@ if $@;
921 delete $self->{_coro}{$coro+0}; 1749 delete $self->{_coro}{$coro+0};
922 }; 1750 });
923 1751
924 $self->{_coro}{$coro+0} = $coro; 1752 $self->{_coro}{$coro+0} = $coro;
1753
1754 $coro
925} 1755}
926 1756
927cf::client->attach ( 1757cf::client->attach (
928 on_destroy => sub { 1758 on_destroy => sub {
929 my ($ns) = @_; 1759 my ($ns) = @_;
1093 1923
1094{ 1924{
1095 my $path = cf::localdir . "/database.pst"; 1925 my $path = cf::localdir . "/database.pst";
1096 1926
1097 sub db_load() { 1927 sub db_load() {
1098 warn "loading database $path\n";#d# remove later
1099 $DB = stat $path ? Storable::retrieve $path : { }; 1928 $DB = stat $path ? Storable::retrieve $path : { };
1100 } 1929 }
1101 1930
1102 my $pid; 1931 my $pid;
1103 1932
1104 sub db_save() { 1933 sub db_save() {
1105 warn "saving database $path\n";#d# remove later
1106 waitpid $pid, 0 if $pid; 1934 waitpid $pid, 0 if $pid;
1107 if (0 == ($pid = fork)) { 1935 if (0 == ($pid = fork)) {
1108 $DB->{_meta}{version} = 1; 1936 $DB->{_meta}{version} = 1;
1109 Storable::nstore $DB, "$path~"; 1937 Storable::nstore $DB, "$path~";
1110 rename "$path~", $path; 1938 rename "$path~", $path;
1161 local $/; 1989 local $/;
1162 *CFG = YAML::Syck::Load <$fh>; 1990 *CFG = YAML::Syck::Load <$fh>;
1163} 1991}
1164 1992
1165sub main { 1993sub main {
1994 # we must not ever block the main coroutine
1995 local $Coro::idle = sub {
1996 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1997 (Coro::unblock_sub {
1998 Event::one_event;
1999 })->();
2000 };
2001
1166 cfg_load; 2002 cfg_load;
1167 db_load; 2003 db_load;
1168 load_extensions; 2004 load_extensions;
1169 Event::loop; 2005 Event::loop;
1170} 2006}
1171 2007
1172############################################################################# 2008#############################################################################
1173# initialisation 2009# initialisation
1174 2010
1175sub _perl_reload(&) { 2011sub reload() {
1176 my ($msg) = @_; 2012 # can/must only be called in main
2013 if ($Coro::current != $Coro::main) {
2014 warn "can only reload from main coroutine\n";
2015 return;
2016 }
1177 2017
1178 $msg->("reloading..."); 2018 warn "reloading...";
2019
2020 local $FREEZE = 1;
2021 cf::emergency_save;
1179 2022
1180 eval { 2023 eval {
2024 # if anything goes wrong in here, we should simply crash as we already saved
2025
1181 # cancel all watchers 2026 # cancel all watchers
1182 for (Event::all_watchers) { 2027 for (Event::all_watchers) {
1183 $_->cancel if $_->data & WF_AUTOCANCEL; 2028 $_->cancel if $_->data & WF_AUTOCANCEL;
1184 } 2029 }
1185 2030
2031 # cancel all extension coros
2032 $_->cancel for values %EXT_CORO;
2033 %EXT_CORO = ();
2034
1186 # unload all extensions 2035 # unload all extensions
1187 for (@exts) { 2036 for (@exts) {
1188 $msg->("unloading <$_>"); 2037 warn "unloading <$_>";
1189 unload_extension $_; 2038 unload_extension $_;
1190 } 2039 }
1191 2040
1192 # unload all modules loaded from $LIBDIR 2041 # unload all modules loaded from $LIBDIR
1193 while (my ($k, $v) = each %INC) { 2042 while (my ($k, $v) = each %INC) {
1194 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2043 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1195 2044
1196 $msg->("removing <$k>"); 2045 warn "removing <$k>";
1197 delete $INC{$k}; 2046 delete $INC{$k};
1198 2047
1199 $k =~ s/\.pm$//; 2048 $k =~ s/\.pm$//;
1200 $k =~ s/\//::/g; 2049 $k =~ s/\//::/g;
1201 2050
1206 Symbol::delete_package $k; 2055 Symbol::delete_package $k;
1207 } 2056 }
1208 2057
1209 # sync database to disk 2058 # sync database to disk
1210 cf::db_sync; 2059 cf::db_sync;
2060 IO::AIO::flush;
1211 2061
1212 # get rid of safe::, as good as possible 2062 # get rid of safe::, as good as possible
1213 Symbol::delete_package "safe::$_" 2063 Symbol::delete_package "safe::$_"
1214 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region); 2064 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1215 2065
1216 # remove register_script_function callbacks 2066 # remove register_script_function callbacks
1217 # TODO 2067 # TODO
1218 2068
1219 # unload cf.pm "a bit" 2069 # unload cf.pm "a bit"
1222 # don't, removes xs symbols, too, 2072 # don't, removes xs symbols, too,
1223 # and global variables created in xs 2073 # and global variables created in xs
1224 #Symbol::delete_package __PACKAGE__; 2074 #Symbol::delete_package __PACKAGE__;
1225 2075
1226 # reload cf.pm 2076 # reload cf.pm
1227 $msg->("reloading cf.pm"); 2077 warn "reloading cf.pm";
1228 require cf; 2078 require cf;
1229 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2079 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1230 2080
1231 # load config and database again 2081 # load config and database again
1232 cf::cfg_load; 2082 cf::cfg_load;
1233 cf::db_load; 2083 cf::db_load;
1234 2084
1235 # load extensions 2085 # load extensions
1236 $msg->("load extensions"); 2086 warn "load extensions";
1237 cf::load_extensions; 2087 cf::load_extensions;
1238 2088
1239 # reattach attachments to objects 2089 # reattach attachments to objects
1240 $msg->("reattach"); 2090 warn "reattach";
1241 _global_reattach; 2091 _global_reattach;
1242 }; 2092 };
1243 $msg->($@) if $@;
1244 2093
1245 $msg->("reloaded"); 2094 if ($@) {
2095 warn $@;
2096 warn "error while reloading, exiting.";
2097 exit 1;
2098 }
2099
2100 warn "reloaded successfully";
1246}; 2101};
1247 2102
1248sub perl_reload() { 2103#############################################################################
1249 _perl_reload { 2104
1250 warn $_[0]; 2105unless ($LINK_MAP) {
1251 print "$_[0]\n"; 2106 $LINK_MAP = cf::map::new;
1252 }; 2107
2108 $LINK_MAP->width (41);
2109 $LINK_MAP->height (41);
2110 $LINK_MAP->alloc;
2111 $LINK_MAP->path ("{link}");
2112 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2113 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2114
2115 # dirty hack because... archetypes are not yet loaded
2116 Event->timer (
2117 after => 2,
2118 cb => sub {
2119 $_[0]->w->cancel;
2120
2121 # provide some exits "home"
2122 my $exit = cf::object::new "exit";
2123
2124 $exit->slaying ($EMERGENCY_POSITION->[0]);
2125 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2126 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2127
2128 $LINK_MAP->insert ($exit->clone, 19, 19);
2129 $LINK_MAP->insert ($exit->clone, 19, 20);
2130 $LINK_MAP->insert ($exit->clone, 19, 21);
2131 $LINK_MAP->insert ($exit->clone, 20, 19);
2132 $LINK_MAP->insert ($exit->clone, 20, 21);
2133 $LINK_MAP->insert ($exit->clone, 21, 19);
2134 $LINK_MAP->insert ($exit->clone, 21, 20);
2135 $LINK_MAP->insert ($exit->clone, 21, 21);
2136
2137 $exit->destroy;
2138 });
2139
2140 $LINK_MAP->{deny_save} = 1;
2141 $LINK_MAP->{deny_reset} = 1;
2142
2143 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
1253} 2144}
1254 2145
1255register "<global>", __PACKAGE__; 2146register "<global>", __PACKAGE__;
1256 2147
1257register_command "perl-reload" => sub { 2148register_command "reload" => sub {
1258 my ($who, $arg) = @_; 2149 my ($who, $arg) = @_;
1259 2150
1260 if ($who->flag (FLAG_WIZ)) { 2151 if ($who->flag (FLAG_WIZ)) {
1261 _perl_reload { 2152 $who->message ("start of reload.");
1262 warn $_[0]; 2153 reload;
1263 $who->message ($_[0]); 2154 $who->message ("end of reload.");
1264 };
1265 } 2155 }
1266}; 2156};
1267 2157
1268unshift @INC, $LIBDIR; 2158unshift @INC, $LIBDIR;
1269 2159
1270$TICK_WATCHER = Event->timer ( 2160$TICK_WATCHER = Event->timer (
2161 reentrant => 0,
1271 prio => 0, 2162 prio => 0,
1272 at => $NEXT_TICK || 1, 2163 at => $NEXT_TICK || $TICK,
1273 data => WF_AUTOCANCEL, 2164 data => WF_AUTOCANCEL,
1274 cb => sub { 2165 cb => sub {
2166 unless ($FREEZE) {
1275 cf::server_tick; # one server iteration 2167 cf::server_tick; # one server iteration
2168 $RUNTIME += $TICK;
2169 }
1276 2170
1277 my $NOW = Event::time;
1278 $NEXT_TICK += $TICK; 2171 $NEXT_TICK += $TICK;
1279 2172
1280 # if we are delayed by four ticks or more, skip them all 2173 # if we are delayed by four ticks or more, skip them all
1281 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 2174 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1282 2175
1283 $TICK_WATCHER->at ($NEXT_TICK); 2176 $TICK_WATCHER->at ($NEXT_TICK);
1284 $TICK_WATCHER->start; 2177 $TICK_WATCHER->start;
1285 }, 2178 },
1286); 2179);
1287 2180
1288IO::AIO::max_poll_time $TICK * 0.2; 2181IO::AIO::max_poll_time $TICK * 0.2;
1289 2182
2183Event->io (
1290Event->io (fd => IO::AIO::poll_fileno, 2184 fd => IO::AIO::poll_fileno,
1291 poll => 'r', 2185 poll => 'r',
1292 prio => 5, 2186 prio => 5,
1293 data => WF_AUTOCANCEL, 2187 data => WF_AUTOCANCEL,
1294 cb => \&IO::AIO::poll_cb); 2188 cb => \&IO::AIO::poll_cb,
2189);
2190
2191Event->timer (
2192 data => WF_AUTOCANCEL,
2193 after => 0,
2194 interval => 10,
2195 cb => sub {
2196 (Coro::unblock_sub {
2197 write_runtime
2198 or warn "ERROR: unable to write runtime file: $!";
2199 })->();
2200 },
2201);
2202
2203END { cf::emergency_save }
1295 2204
12961 22051
1297 2206

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines