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.101 by root, Mon Dec 25 14:43:23 2006 UTC vs.
Revision 1.120 by root, Tue Jan 2 11:08:36 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::sync_job { BLOCK }
251
252The design of crossfire+ requires that the main coro ($Coro::main) is
253always able to handle events or runnable, as crossfire+ is only partly
254reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
255
256If it must be done, put the blocking parts into C<sync_job>. This will run
257the given BLOCK in another coroutine while waiting for the result. The
258server will be frozen during this time, so the block should either finish
259fast or be very important.
260
261=cut
262
263sub sync_job(&) {
264 my ($job) = @_;
265
266 if ($Coro::current == $Coro::main) {
267 # this is the main coro, too bad, we have to block
268 # till the operation succeeds, freezing the server :/
269
270 # TODO: use suspend/resume instead
271 # (but this is cancel-safe)
272 local $FREEZE = 1;
273
274 my $busy = 1;
275 my @res;
276
277 (Coro::async {
278 @res = eval { $job->() };
279 warn $@ if $@;
280 undef $busy;
281 })->prio (Coro::PRIO_MAX);
282
283 while ($busy) {
284 Coro::cede_notself;
285 Event::one_event unless Coro::nready;
286 }
287
288 wantarray ? @res : $res[0]
289 } else {
290 # we are in another coroutine, how wonderful, everything just works
291
292 $job->()
293 }
294}
295
296=item $coro = cf::coro { BLOCK }
297
298Creates and returns a new coro. This coro is automcatially being canceled
299when the extension calling this is being unloaded.
300
301=cut
302
303sub coro(&) {
304 my $cb = shift;
305
306 my $coro; $coro = async {
307 eval {
308 $cb->();
309 };
310 warn $@ if $@;
311 };
312
313 $coro->on_destroy (sub {
314 delete $EXT_CORO{$coro+0};
315 });
316 $EXT_CORO{$coro+0} = $coro;
317
318 $coro
319}
320
321sub write_runtime {
322 my $runtime = cf::localdir . "/runtime";
323
324 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
325 or return;
326
327 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock
328 (aio_write $fh, 0, (length $value), $value, 0) <= 0
329 and return;
330
331 aio_fsync $fh
332 and return;
333
334 close $fh
335 or return;
336
337 aio_rename "$runtime~", $runtime
338 and return;
339
340 1
341}
342
144=back 343=back
145 344
146=cut 345=cut
346
347#############################################################################
348
349package cf::path;
350
351sub new {
352 my ($class, $path, $base) = @_;
353
354 $path = $path->as_string if ref $path;
355
356 my $self = bless { }, $class;
357
358 # {... are special paths that are not touched
359 # ?xxx/... are special absolute paths
360 # ?random/... random maps
361 # /! non-realised random map exit
362 # /... normal maps
363 # ~/... per-player maps without a specific player (DO NOT USE)
364 # ~user/... per-player map of a specific user
365
366 if ($path =~ /^{/) {
367 # fine as it is
368 } elsif ($path =~ s{^\?random/}{}) {
369 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
370 $self->{random} = cf::from_json $data;
371 } else {
372 if ($path =~ s{^~([^/]+)?}{}) {
373 $self->{user_rel} = 1;
374
375 if (defined $1) {
376 $self->{user} = $1;
377 } elsif ($base =~ m{^~([^/]+)/}) {
378 $self->{user} = $1;
379 } else {
380 warn "cannot resolve user-relative path without user <$path,$base>\n";
381 }
382 } elsif ($path =~ /^\//) {
383 # already absolute
384 } else {
385 $base =~ s{[^/]+/?$}{};
386 return $class->new ("$base/$path");
387 }
388
389 for ($path) {
390 redo if s{/\.?/}{/};
391 redo if s{/[^/]+/\.\./}{/};
392 }
393 }
394
395 $self->{path} = $path;
396
397 $self
398}
399
400# the name / primary key / in-game path
401sub as_string {
402 my ($self) = @_;
403
404 $self->{user_rel} ? "~$self->{user}$self->{path}"
405 : $self->{random} ? "?random/$self->{path}"
406 : $self->{path}
407}
408
409# the displayed name, this is a one way mapping
410sub visible_name {
411 my ($self) = @_;
412
413# if (my $rmp = $self->{random}) {
414# # todo: be more intelligent about this
415# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
416# } else {
417 $self->as_string
418# }
419}
420
421# escape the /'s in the path
422sub _escaped_path {
423 # ∕ is U+2215
424 (my $path = $_[0]{path}) =~ s/\//∕/g;
425 $path
426}
427
428# the original (read-only) location
429sub load_path {
430 my ($self) = @_;
431
432 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
433}
434
435# the temporary/swap location
436sub save_path {
437 my ($self) = @_;
438
439 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
440 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
441 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
442}
443
444# the unique path, might be eq to save_path
445sub uniq_path {
446 my ($self) = @_;
447
448 $self->{user_rel} || $self->{random}
449 ? undef
450 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
451}
452
453# return random map parameters, or undef
454sub random_map_params {
455 my ($self) = @_;
456
457 $self->{random}
458}
459
460# this is somewhat ugly, but style maps do need special treatment
461sub is_style_map {
462 $_[0]{path} =~ m{^/styles/}
463}
464
465package cf;
147 466
148############################################################################# 467#############################################################################
149 468
150=head2 ATTACHABLE OBJECTS 469=head2 ATTACHABLE OBJECTS
151 470
454=cut 773=cut
455 774
456############################################################################# 775#############################################################################
457# object support 776# object support
458 777
778sub reattach {
779 # basically do the same as instantiate, without calling instantiate
780 my ($obj) = @_;
781
782 my $registry = $obj->registry;
783
784 @$registry = ();
785
786 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
787
788 for my $name (keys %{ $obj->{_attachment} || {} }) {
789 if (my $attach = $attachment{$name}) {
790 for (@$attach) {
791 my ($klass, @attach) = @$_;
792 _attach $registry, $klass, @attach;
793 }
794 } else {
795 warn "object uses attachment '$name' that is not available, postponing.\n";
796 }
797 }
798}
799
459cf::attachable->attach ( 800cf::attachable->attach (
460 prio => -1000000, 801 prio => -1000000,
461 on_instantiate => sub { 802 on_instantiate => sub {
462 my ($obj, $data) = @_; 803 my ($obj, $data) = @_;
463 804
467 my ($name, $args) = @$_; 808 my ($name, $args) = @$_;
468 809
469 $obj->attach ($name, %{$args || {} }); 810 $obj->attach ($name, %{$args || {} });
470 } 811 }
471 }, 812 },
472 on_reattach => sub { 813 on_reattach => \&reattach,
473 # basically do the same as instantiate, without calling instantiate
474 my ($obj) = @_;
475 my $registry = $obj->registry;
476
477 @$registry = ();
478
479 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
480
481 for my $name (keys %{ $obj->{_attachment} || {} }) {
482 if (my $attach = $attachment{$name}) {
483 for (@$attach) {
484 my ($klass, @attach) = @$_;
485 _attach $registry, $klass, @attach;
486 }
487 } else {
488 warn "object uses attachment '$name' that is not available, postponing.\n";
489 }
490 }
491 },
492 on_clone => sub { 814 on_clone => sub {
493 my ($src, $dst) = @_; 815 my ($src, $dst) = @_;
494 816
495 @{$dst->registry} = @{$src->registry}; 817 @{$dst->registry} = @{$src->registry};
496 818
502); 824);
503 825
504sub object_freezer_save { 826sub object_freezer_save {
505 my ($filename, $rdata, $objs) = @_; 827 my ($filename, $rdata, $objs) = @_;
506 828
829 sync_job {
507 if (length $$rdata) { 830 if (length $$rdata) {
508 warn sprintf "saving %s (%d,%d)\n", 831 warn sprintf "saving %s (%d,%d)\n",
509 $filename, length $$rdata, scalar @$objs; 832 $filename, length $$rdata, scalar @$objs;
510 833
511 if (open my $fh, ">:raw", "$filename~") { 834 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
512 chmod SAVE_MODE, $fh;
513 syswrite $fh, $$rdata;
514 close $fh;
515
516 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
517 chmod SAVE_MODE, $fh; 835 chmod SAVE_MODE, $fh;
518 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 836 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
837 aio_fsync $fh;
519 close $fh; 838 close $fh;
839
840 if (@$objs) {
841 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
842 chmod SAVE_MODE, $fh;
843 my $data = Storable::nfreeze { version => 1, objs => $objs };
844 aio_write $fh, 0, (length $data), $data, 0;
845 aio_fsync $fh;
846 close $fh;
520 rename "$filename.pst~", "$filename.pst"; 847 aio_rename "$filename.pst~", "$filename.pst";
848 }
849 } else {
850 aio_unlink "$filename.pst";
851 }
852
853 aio_rename "$filename~", $filename;
521 } else { 854 } else {
522 unlink "$filename.pst"; 855 warn "FATAL: $filename~: $!\n";
523 } 856 }
524
525 rename "$filename~", $filename;
526 } else { 857 } else {
527 warn "FATAL: $filename~: $!\n";
528 }
529 } else {
530 unlink $filename; 858 aio_unlink $filename;
531 unlink "$filename.pst"; 859 aio_unlink "$filename.pst";
860 }
532 } 861 }
533} 862}
534 863
535sub object_freezer_as_string { 864sub object_freezer_as_string {
536 my ($rdata, $objs) = @_; 865 my ($rdata, $objs) = @_;
541} 870}
542 871
543sub object_thawer_load { 872sub object_thawer_load {
544 my ($filename) = @_; 873 my ($filename) = @_;
545 874
546 local $/; 875 my ($data, $av);
547 876
548 my $av; 877 (aio_load $filename, $data) >= 0
878 or return;
549 879
550 #TODO: use sysread etc. 880 unless (aio_stat "$filename.pst") {
551 if (open my $data, "<:raw:perlio", $filename) { 881 (aio_load "$filename.pst", $av) >= 0
552 $data = <$data>; 882 or return;
553 if (open my $pst, "<:raw:perlio", "$filename.pst") {
554 $av = eval { (Storable::thaw <$pst>)->{objs} }; 883 $av = eval { (Storable::thaw $av)->{objs} };
555 } 884 }
885
886 warn sprintf "loading %s (%d)\n",
887 $filename, length $data, scalar @{$av || []};#d#
556 return ($data, $av); 888 return ($data, $av);
557 }
558
559 ()
560} 889}
561 890
562############################################################################# 891#############################################################################
563# command handling &c 892# command handling &c
564 893
785 $self->send ("ext " . to_json \%msg); 1114 $self->send ("ext " . to_json \%msg);
786} 1115}
787 1116
788=back 1117=back
789 1118
1119
1120=head3 cf::map
1121
1122=over 4
1123
1124=cut
1125
1126package cf::map;
1127
1128use Fcntl;
1129use Coro::AIO;
1130
1131our $MAX_RESET = 7200;
1132our $DEFAULT_RESET = 3600;
1133
1134sub generate_random_map {
1135 my ($path, $rmp) = @_;
1136
1137 # mit "rum" bekleckern, nicht
1138 cf::map::_create_random_map
1139 $path,
1140 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1141 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1142 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1143 $rmp->{exit_on_final_map},
1144 $rmp->{xsize}, $rmp->{ysize},
1145 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1146 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1147 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1148 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1149 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1150 (cf::region::find $rmp->{region})
1151}
1152
1153# and all this just because we cannot iterate over
1154# all maps in C++...
1155sub change_all_map_light {
1156 my ($change) = @_;
1157
1158 $_->change_map_light ($change) for values %cf::MAP;
1159}
1160
1161sub try_load_header($) {
1162 my ($path) = @_;
1163
1164 utf8::encode $path;
1165 aio_open $path, O_RDONLY, 0
1166 or return;
1167
1168 my $map = cf::map::new
1169 or return;
1170
1171 $map->load_header ($path)
1172 or return;
1173
1174 $map->{load_path} = $path;
1175
1176 $map
1177}
1178
1179sub find_map {
1180 my ($path, $origin) = @_;
1181
1182 #warn "find_map<$path,$origin>\n";#d#
1183
1184 $path = new cf::path $path, $origin && $origin->path;
1185 my $key = $path->as_string;
1186
1187 cf::lock_wait "map_find:$key";
1188
1189 $cf::MAP{$key} || do {
1190 my $guard = cf::lock_acquire "map_find:$key";
1191
1192 # do it the slow way
1193 my $map = try_load_header $path->save_path;
1194
1195 if ($map) {
1196 # safety
1197 $map->{instantiate_time} = $cf::RUNTIME
1198 if $map->{instantiate_time} > $cf::RUNTIME;
1199 } else {
1200 if (my $rmp = $path->random_map_params) {
1201 $map = generate_random_map $key, $rmp;
1202 } else {
1203 $map = try_load_header $path->load_path;
1204 }
1205
1206 $map or return;
1207
1208 $map->{load_original} = 1;
1209 $map->{instantiate_time} = $cf::RUNTIME;
1210 $map->instantiate;
1211
1212 # per-player maps become, after loading, normal maps
1213 $map->per_player (0) if $path->{user_rel};
1214 }
1215 #Coro::Timer::sleep 1;#d#
1216
1217 $map->path ($key);
1218 $map->{path} = $path;
1219 $map->{last_save} = $cf::RUNTIME;
1220 $map->last_access ($cf::RUNTIME);
1221
1222 if ($map->should_reset) {
1223 $map->reset;
1224 $map = find_map $path;
1225 }
1226
1227 $cf::MAP{$key} = $map
1228 }
1229}
1230
1231sub load {
1232 my ($self) = @_;
1233
1234 my $path = $self->{path};
1235 my $guard = cf::lock_acquire "map_load:" . $path->as_string;
1236
1237 return if $self->in_memory != cf::MAP_SWAPPED;
1238
1239 $self->in_memory (cf::MAP_LOADING);
1240
1241 $self->alloc;
1242 $self->load_objects ($self->{load_path}, 1)
1243 or return;
1244
1245 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1246 if delete $self->{load_original};
1247
1248 if (my $uniq = $path->uniq_path) {
1249 utf8::encode $uniq;
1250 if (aio_open $uniq, O_RDONLY, 0) {
1251 $self->clear_unique_items;
1252 $self->load_objects ($uniq, 0);
1253 }
1254 }
1255
1256 # now do the right thing for maps
1257 $self->link_multipart_objects;
1258
1259 if ($self->{path}->is_style_map) {
1260 $self->{deny_save} = 1;
1261 $self->{deny_reset} = 1;
1262 } else {
1263 $self->fix_auto_apply;
1264 $self->decay_objects;
1265 $self->update_buttons;
1266 $self->set_darkness_map;
1267 $self->difficulty ($self->estimate_difficulty)
1268 unless $self->difficulty;
1269 $self->activate;
1270 }
1271
1272 $self->in_memory (cf::MAP_IN_MEMORY);
1273}
1274
1275sub load_map_sync {
1276 my ($path, $origin) = @_;
1277
1278 #warn "load_map_sync<$path, $origin>\n";#d#
1279
1280 cf::sync_job {
1281 my $map = cf::map::find_map $path, $origin
1282 or return;
1283 $map->load;
1284 $map
1285 }
1286}
1287
1288sub save {
1289 my ($self) = @_;
1290
1291 $self->{last_save} = $cf::RUNTIME;
1292
1293 return unless $self->dirty;
1294
1295 my $save = $self->{path}->save_path; utf8::encode $save;
1296 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
1297
1298 $self->{load_path} = $save;
1299
1300 return if $self->{deny_save};
1301
1302 if ($uniq) {
1303 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1304 $self->save_objects ($uniq, cf::IO_UNIQUES);
1305 } else {
1306 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1307 }
1308}
1309
1310sub swap_out {
1311 my ($self) = @_;
1312
1313 return if $self->players;
1314 return if $self->in_memory != cf::MAP_IN_MEMORY;
1315 return if $self->{deny_save};
1316
1317 $self->save;
1318 $self->clear;
1319 $self->in_memory (cf::MAP_SWAPPED);
1320}
1321
1322sub reset_at {
1323 my ($self) = @_;
1324
1325 # TODO: safety, remove and allow resettable per-player maps
1326 return 1e99 if $self->{path}{user_rel};
1327 return 1e99 if $self->{deny_reset};
1328
1329 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1330 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1331
1332 $time + $to
1333}
1334
1335sub should_reset {
1336 my ($self) = @_;
1337
1338 $self->reset_at <= $cf::RUNTIME
1339}
1340
1341sub unlink_save {
1342 my ($self) = @_;
1343
1344 utf8::encode (my $save = $self->{path}->save_path);
1345 aioreq_pri 3; IO::AIO::aio_unlink $save;
1346 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1347}
1348
1349sub rename {
1350 my ($self, $new_path) = @_;
1351
1352 $self->unlink_save;
1353
1354 delete $cf::MAP{$self->path};
1355 $self->{path} = new cf::path $new_path;
1356 $self->path ($self->{path}->as_string);
1357 $cf::MAP{$self->path} = $self;
1358
1359 $self->save;
1360}
1361
1362sub reset {
1363 my ($self) = @_;
1364
1365 return if $self->players;
1366 return if $self->{path}{user_rel};#d#
1367
1368 warn "resetting map ", $self->path;#d#
1369
1370 delete $cf::MAP{$self->path};
1371
1372 $_->clear_links_to ($self) for values %cf::MAP;
1373
1374 $self->unlink_save;
1375 $self->destroy;
1376}
1377
1378my $nuke_counter = "aaaa";
1379
1380sub nuke {
1381 my ($self) = @_;
1382
1383 $self->{deny_save} = 1;
1384 $self->reset_timeout (1);
1385 $self->rename ("{nuke}/" . ($nuke_counter++));
1386 $self->reset; # polite request, might not happen
1387}
1388
1389sub customise_for {
1390 my ($map, $ob) = @_;
1391
1392 if ($map->per_player) {
1393 return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path};
1394 }
1395
1396 $map
1397}
1398
1399sub emergency_save {
1400 local $cf::FREEZE = 1;
1401
1402 warn "enter emergency map save\n";
1403
1404 cf::sync_job {
1405 warn "begin emergency map save\n";
1406 $_->save for values %cf::MAP;
1407 };
1408
1409 warn "end emergency map save\n";
1410}
1411
1412package cf;
1413
1414=back
1415
1416
790=head3 cf::object::player 1417=head3 cf::object::player
791 1418
792=over 4 1419=over 4
793 1420
794=item $player_object->reply ($npc, $msg[, $flags]) 1421=item $player_object->reply ($npc, $msg[, $flags])
827 1454
828 $self->flag (cf::FLAG_WIZ) || 1455 $self->flag (cf::FLAG_WIZ) ||
829 (ref $cf::CFG{"may_$access"} 1456 (ref $cf::CFG{"may_$access"}
830 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 1457 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
831 : $cf::CFG{"may_$access"}) 1458 : $cf::CFG{"may_$access"})
1459}
1460
1461=item $player_object->enter_link
1462
1463Freezes the player and moves him/her to a special map (C<{link}>).
1464
1465The player should be reaosnably safe there for short amounts of time. You
1466I<MUST> call C<leave_link> as soon as possible, though.
1467
1468=item $player_object->leave_link ($map, $x, $y)
1469
1470Moves the player out of the specila link map onto the given map. If the
1471map is not valid (or omitted), the player will be moved back to the
1472location he/she was before the call to C<enter_link>, or, if that fails,
1473to the emergency map position.
1474
1475Might block.
1476
1477=cut
1478
1479sub cf::object::player::enter_link {
1480 my ($self) = @_;
1481
1482 $self->deactivate_recursive;
1483
1484 return if $self->map == $LINK_MAP;
1485
1486 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1487 if $self->map;
1488
1489 $self->enter_map ($LINK_MAP, 20, 20);
1490}
1491
1492sub cf::object::player::leave_link {
1493 my ($self, $map, $x, $y) = @_;
1494
1495 my $link_pos = delete $self->{_link_pos};
1496
1497 unless ($map) {
1498 # restore original map position
1499 ($map, $x, $y) = @{ $link_pos || [] };
1500 $map = cf::map::find_map $map;
1501
1502 unless ($map) {
1503 ($map, $x, $y) = @$EMERGENCY_POSITION;
1504 $map = cf::map::find_map $map
1505 or die "FATAL: cannot load emergency map\n";
1506 }
1507 }
1508
1509 ($x, $y) = (-1, -1)
1510 unless (defined $x) && (defined $y);
1511
1512 # use -1 or undef as default coordinates, not 0, 0
1513 ($x, $y) = ($map->enter_x, $map->enter_y)
1514 if $x <=0 && $y <= 0;
1515
1516 $map->load;
1517
1518 $self->activate_recursive;
1519 $self->enter_map ($map, $x, $y);
1520}
1521
1522cf::player->attach (
1523 on_logout => sub {
1524 my ($pl) = @_;
1525
1526 # abort map switching before logout
1527 if ($pl->ob->{_link_pos}) {
1528 cf::sync_job {
1529 $pl->ob->leave_link
1530 };
1531 }
1532 },
1533 on_login => sub {
1534 my ($pl) = @_;
1535
1536 # try to abort aborted map switching on player login :)
1537 # should happen only on crashes
1538 if ($pl->ob->{_link_pos}) {
1539 $pl->ob->enter_link;
1540 Coro::async {
1541 # we need this sleep as the login has a concurrent enter_exit running
1542 # and this sleep increases chances of the player not ending up in scorn
1543 Coro::Timer::sleep 1;
1544 $pl->ob->leave_link;
1545 };
1546 }
1547 },
1548);
1549
1550=item $player_object->goto_map ($path, $x, $y)
1551
1552=cut
1553
1554sub cf::object::player::goto_map {
1555 my ($self, $path, $x, $y) = @_;
1556
1557 $self->enter_link;
1558
1559 (Coro::async {
1560 $path = new cf::path $path;
1561
1562 my $map = cf::map::find_map $path->as_string;
1563 $map = $map->customise_for ($self) if $map;
1564
1565# warn "entering ", $map->path, " at ($x, $y)\n"
1566# if $map;
1567
1568 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1569
1570 $self->leave_link ($map, $x, $y);
1571 })->prio (1);
1572}
1573
1574=item $player_object->enter_exit ($exit_object)
1575
1576=cut
1577
1578sub parse_random_map_params {
1579 my ($spec) = @_;
1580
1581 my $rmp = { # defaults
1582 xsize => 10,
1583 ysize => 10,
1584 };
1585
1586 for (split /\n/, $spec) {
1587 my ($k, $v) = split /\s+/, $_, 2;
1588
1589 $rmp->{lc $k} = $v if (length $k) && (length $v);
1590 }
1591
1592 $rmp
1593}
1594
1595sub prepare_random_map {
1596 my ($exit) = @_;
1597
1598 # all this does is basically replace the /! path by
1599 # a new random map path (?random/...) with a seed
1600 # that depends on the exit object
1601
1602 my $rmp = parse_random_map_params $exit->msg;
1603
1604 if ($exit->map) {
1605 $rmp->{region} = $exit->map->region_name;
1606 $rmp->{origin_map} = $exit->map->path;
1607 $rmp->{origin_x} = $exit->x;
1608 $rmp->{origin_y} = $exit->y;
1609 }
1610
1611 $rmp->{random_seed} ||= $exit->random_seed;
1612
1613 my $data = cf::to_json $rmp;
1614 my $md5 = Digest::MD5::md5_hex $data;
1615
1616 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) {
1617 aio_write $fh, 0, (length $data), $data, 0;
1618
1619 $exit->slaying ("?random/$md5");
1620 $exit->msg (undef);
1621 }
1622}
1623
1624sub cf::object::player::enter_exit {
1625 my ($self, $exit) = @_;
1626
1627 return unless $self->type == cf::PLAYER;
1628
1629 $self->enter_link;
1630
1631 (Coro::async {
1632 unless (eval {
1633
1634 prepare_random_map $exit
1635 if $exit->slaying eq "/!";
1636
1637 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1638 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
1639
1640 1;
1641 }) {
1642 $self->message ("Something went wrong deep within the crossfire server. "
1643 . "I'll try to bring you back to the map you were before. "
1644 . "Please report this to the dungeon master",
1645 cf::NDI_UNIQUE | cf::NDI_RED);
1646
1647 warn "ERROR in enter_exit: $@";
1648 $self->leave_link;
1649 }
1650 })->prio (1);
832} 1651}
833 1652
834=head3 cf::client 1653=head3 cf::client
835 1654
836=over 4 1655=over 4
913 my $coro; $coro = async { 1732 my $coro; $coro = async {
914 eval { 1733 eval {
915 $cb->(); 1734 $cb->();
916 }; 1735 };
917 warn $@ if $@; 1736 warn $@ if $@;
1737 };
1738
1739 $coro->on_destroy (sub {
918 delete $self->{_coro}{$coro+0}; 1740 delete $self->{_coro}{$coro+0};
919 }; 1741 });
920 1742
921 $self->{_coro}{$coro+0} = $coro; 1743 $self->{_coro}{$coro+0} = $coro;
1744
1745 $coro
922} 1746}
923 1747
924cf::client->attach ( 1748cf::client->attach (
925 on_destroy => sub { 1749 on_destroy => sub {
926 my ($ns) = @_; 1750 my ($ns) = @_;
1158 local $/; 1982 local $/;
1159 *CFG = YAML::Syck::Load <$fh>; 1983 *CFG = YAML::Syck::Load <$fh>;
1160} 1984}
1161 1985
1162sub main { 1986sub main {
1987 # we must not ever block the main coroutine
1988 local $Coro::idle = sub {
1989 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1990 (Coro::unblock_sub {
1991 Event::one_event;
1992 })->();
1993 };
1994
1163 cfg_load; 1995 cfg_load;
1164 db_load; 1996 db_load;
1165 load_extensions; 1997 load_extensions;
1166 Event::loop; 1998 Event::loop;
1167} 1999}
1168 2000
1169############################################################################# 2001#############################################################################
1170# initialisation 2002# initialisation
1171 2003
1172sub _perl_reload(&) { 2004sub reload() {
1173 my ($msg) = @_; 2005 # can/must only be called in main
2006 if ($Coro::current != $Coro::main) {
2007 warn "can only reload from main coroutine\n";
2008 return;
2009 }
1174 2010
1175 $msg->("reloading..."); 2011 warn "reloading...";
2012
2013 local $FREEZE = 1;
2014 cf::emergency_save;
1176 2015
1177 eval { 2016 eval {
2017 # if anything goes wrong in here, we should simply crash as we already saved
2018
1178 # cancel all watchers 2019 # cancel all watchers
1179 for (Event::all_watchers) { 2020 for (Event::all_watchers) {
1180 $_->cancel if $_->data & WF_AUTOCANCEL; 2021 $_->cancel if $_->data & WF_AUTOCANCEL;
1181 } 2022 }
1182 2023
2024 # cancel all extension coros
2025 $_->cancel for values %EXT_CORO;
2026 %EXT_CORO = ();
2027
1183 # unload all extensions 2028 # unload all extensions
1184 for (@exts) { 2029 for (@exts) {
1185 $msg->("unloading <$_>"); 2030 warn "unloading <$_>";
1186 unload_extension $_; 2031 unload_extension $_;
1187 } 2032 }
1188 2033
1189 # unload all modules loaded from $LIBDIR 2034 # unload all modules loaded from $LIBDIR
1190 while (my ($k, $v) = each %INC) { 2035 while (my ($k, $v) = each %INC) {
1191 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2036 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1192 2037
1193 $msg->("removing <$k>"); 2038 warn "removing <$k>";
1194 delete $INC{$k}; 2039 delete $INC{$k};
1195 2040
1196 $k =~ s/\.pm$//; 2041 $k =~ s/\.pm$//;
1197 $k =~ s/\//::/g; 2042 $k =~ s/\//::/g;
1198 2043
1203 Symbol::delete_package $k; 2048 Symbol::delete_package $k;
1204 } 2049 }
1205 2050
1206 # sync database to disk 2051 # sync database to disk
1207 cf::db_sync; 2052 cf::db_sync;
2053 IO::AIO::flush;
1208 2054
1209 # get rid of safe::, as good as possible 2055 # get rid of safe::, as good as possible
1210 Symbol::delete_package "safe::$_" 2056 Symbol::delete_package "safe::$_"
1211 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region); 2057 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1212 2058
1213 # remove register_script_function callbacks 2059 # remove register_script_function callbacks
1214 # TODO 2060 # TODO
1215 2061
1216 # unload cf.pm "a bit" 2062 # unload cf.pm "a bit"
1219 # don't, removes xs symbols, too, 2065 # don't, removes xs symbols, too,
1220 # and global variables created in xs 2066 # and global variables created in xs
1221 #Symbol::delete_package __PACKAGE__; 2067 #Symbol::delete_package __PACKAGE__;
1222 2068
1223 # reload cf.pm 2069 # reload cf.pm
1224 $msg->("reloading cf.pm"); 2070 warn "reloading cf.pm";
1225 require cf; 2071 require cf;
1226 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2072 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1227 2073
1228 # load config and database again 2074 # load config and database again
1229 cf::cfg_load; 2075 cf::cfg_load;
1230 cf::db_load; 2076 cf::db_load;
1231 2077
1232 # load extensions 2078 # load extensions
1233 $msg->("load extensions"); 2079 warn "load extensions";
1234 cf::load_extensions; 2080 cf::load_extensions;
1235 2081
1236 # reattach attachments to objects 2082 # reattach attachments to objects
1237 $msg->("reattach"); 2083 warn "reattach";
1238 _global_reattach; 2084 _global_reattach;
1239 }; 2085 };
1240 $msg->($@) if $@;
1241 2086
1242 $msg->("reloaded"); 2087 if ($@) {
2088 warn $@;
2089 warn "error while reloading, exiting.";
2090 exit 1;
2091 }
2092
2093 warn "reloaded successfully";
1243}; 2094};
1244 2095
1245sub perl_reload() { 2096#############################################################################
1246 _perl_reload { 2097
1247 warn $_[0]; 2098unless ($LINK_MAP) {
1248 print "$_[0]\n"; 2099 $LINK_MAP = cf::map::new;
1249 }; 2100
2101 $LINK_MAP->width (41);
2102 $LINK_MAP->height (41);
2103 $LINK_MAP->alloc;
2104 $LINK_MAP->path ("{link}");
2105 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2106 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2107
2108 # dirty hack because... archetypes are not yet loaded
2109 Event->timer (
2110 after => 2,
2111 cb => sub {
2112 $_[0]->w->cancel;
2113
2114 # provide some exits "home"
2115 my $exit = cf::object::new "exit";
2116
2117 $exit->slaying ($EMERGENCY_POSITION->[0]);
2118 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2119 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2120
2121 $LINK_MAP->insert ($exit->clone, 19, 19);
2122 $LINK_MAP->insert ($exit->clone, 19, 20);
2123 $LINK_MAP->insert ($exit->clone, 19, 21);
2124 $LINK_MAP->insert ($exit->clone, 20, 19);
2125 $LINK_MAP->insert ($exit->clone, 20, 21);
2126 $LINK_MAP->insert ($exit->clone, 21, 19);
2127 $LINK_MAP->insert ($exit->clone, 21, 20);
2128 $LINK_MAP->insert ($exit->clone, 21, 21);
2129
2130 $exit->destroy;
2131 });
2132
2133 $LINK_MAP->{deny_save} = 1;
2134 $LINK_MAP->{deny_reset} = 1;
2135
2136 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
1250} 2137}
1251 2138
1252register "<global>", __PACKAGE__; 2139register "<global>", __PACKAGE__;
1253 2140
1254register_command "perl-reload" => sub { 2141register_command "reload" => sub {
1255 my ($who, $arg) = @_; 2142 my ($who, $arg) = @_;
1256 2143
1257 if ($who->flag (FLAG_WIZ)) { 2144 if ($who->flag (FLAG_WIZ)) {
1258 _perl_reload { 2145 $who->message ("start of reload.");
1259 warn $_[0]; 2146 reload;
1260 $who->message ($_[0]); 2147 $who->message ("end of reload.");
1261 };
1262 } 2148 }
1263}; 2149};
1264 2150
1265unshift @INC, $LIBDIR; 2151unshift @INC, $LIBDIR;
1266 2152
1267$TICK_WATCHER = Event->timer ( 2153$TICK_WATCHER = Event->timer (
2154 reentrant => 0,
1268 prio => 0, 2155 prio => 0,
1269 at => $NEXT_TICK || 1, 2156 at => $NEXT_TICK || $TICK,
1270 data => WF_AUTOCANCEL, 2157 data => WF_AUTOCANCEL,
1271 cb => sub { 2158 cb => sub {
2159 unless ($FREEZE) {
1272 cf::server_tick; # one server iteration 2160 cf::server_tick; # one server iteration
2161 $RUNTIME += $TICK;
2162 }
1273 2163
1274 my $NOW = Event::time;
1275 $NEXT_TICK += $TICK; 2164 $NEXT_TICK += $TICK;
1276 2165
1277 # if we are delayed by four ticks or more, skip them all 2166 # if we are delayed by four ticks or more, skip them all
1278 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 2167 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1279 2168
1280 $TICK_WATCHER->at ($NEXT_TICK); 2169 $TICK_WATCHER->at ($NEXT_TICK);
1281 $TICK_WATCHER->start; 2170 $TICK_WATCHER->start;
1282 }, 2171 },
1283); 2172);
1284 2173
1285IO::AIO::max_poll_time $TICK * 0.2; 2174IO::AIO::max_poll_time $TICK * 0.2;
1286 2175
2176Event->io (
1287Event->io (fd => IO::AIO::poll_fileno, 2177 fd => IO::AIO::poll_fileno,
1288 poll => 'r', 2178 poll => 'r',
1289 prio => 5, 2179 prio => 5,
1290 data => WF_AUTOCANCEL, 2180 data => WF_AUTOCANCEL,
1291 cb => \&IO::AIO::poll_cb); 2181 cb => \&IO::AIO::poll_cb,
2182);
2183
2184Event->timer (
2185 data => WF_AUTOCANCEL,
2186 after => 0,
2187 interval => 10,
2188 cb => sub {
2189 (Coro::unblock_sub {
2190 write_runtime
2191 or warn "ERROR: unable to write runtime file: $!";
2192 })->();
2193 },
2194);
1292 2195
12931 21961
1294 2197

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines