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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines