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.139 by root, Fri Jan 5 19:12:03 2007 UTC vs.
Revision 1.183 by root, Fri Jan 19 19:42:37 2007 UTC

… …
8use Storable; 8use Storable;
9use Opcode; 9use Opcode;
10use Safe; 10use Safe;
11use Safe::Hole; 11use Safe::Hole;
12 12
13use Coro 3.3 (); 13use Coro 3.4 ();
14use Coro::Event; 14use Coro::Event;
15use Coro::Timer; 15use Coro::Timer;
16use Coro::Signal; 16use Coro::Signal;
17use Coro::Semaphore; 17use Coro::Semaphore;
18use Coro::AIO; 18use Coro::AIO;
19 19
20use Data::Dumper;
20use Digest::MD5; 21use Digest::MD5;
21use Fcntl; 22use Fcntl;
22use IO::AIO 2.31 (); 23use IO::AIO 2.32 ();
23use YAML::Syck (); 24use YAML::Syck ();
24use Time::HiRes; 25use Time::HiRes;
25 26
26use Event; $Event::Eval = 1; # no idea why this is required, but it is 27use Event; $Event::Eval = 1; # no idea why this is required, but it is
27 28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30
28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1; 32$YAML::Syck::ImplicitUnicode = 1;
30 33
31$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32 35
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34
35our %COMMAND = (); 36our %COMMAND = ();
36our %COMMAND_TIME = (); 37our %COMMAND_TIME = ();
38
39our @EXTS = (); # list of extension package names
37our %EXTCMD = (); 40our %EXTCMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps
38 43
39our @EVENT; 44our @EVENT;
40our $LIBDIR = datadir . "/ext"; 45our $LIBDIR = datadir . "/ext";
41 46
42our $TICK = MAX_TIME * 1e-6; 47our $TICK = MAX_TIME * 1e-6;
43our $TICK_WATCHER; 48our $TICK_WATCHER;
49our $AIO_POLL_WATCHER;
50our $WRITE_RUNTIME_WATCHER;
44our $NEXT_TICK; 51our $NEXT_TICK;
45our $NOW; 52our $NOW;
46 53
47our %CFG; 54our %CFG;
48 55
49our $UPTIME; $UPTIME ||= time; 56our $UPTIME; $UPTIME ||= time;
50our $RUNTIME; 57our $RUNTIME;
51 58
59our %PLAYER; # all users
52our %MAP; # all maps 60our %MAP; # all maps
53our $LINK_MAP; # the special {link} map 61our $LINK_MAP; # the special {link} map, which is always available
54our $RANDOM_MAPS = cf::localdir . "/random"; 62our $RANDOM_MAPS = cf::localdir . "/random";
55our %EXT_CORO; 63
64our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
65our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
66
67# used to convert map paths into valid unix filenames by replacing / by ∕
68our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
56 69
57binmode STDOUT; 70binmode STDOUT;
58binmode STDERR; 71binmode STDERR;
59 72
60# read virtual server time, if available 73# read virtual server time, if available
… …
68mkdir cf::localdir . "/" . cf::playerdir; 81mkdir cf::localdir . "/" . cf::playerdir;
69mkdir cf::localdir . "/" . cf::tmpdir; 82mkdir cf::localdir . "/" . cf::tmpdir;
70mkdir cf::localdir . "/" . cf::uniquedir; 83mkdir cf::localdir . "/" . cf::uniquedir;
71mkdir $RANDOM_MAPS; 84mkdir $RANDOM_MAPS;
72 85
73# a special map that is always available
74our $LINK_MAP;
75our $EMERGENCY_POSITION; 86our $EMERGENCY_POSITION;
76 87
77############################################################################# 88#############################################################################
78 89
79=head2 GLOBAL VARIABLES 90=head2 GLOBAL VARIABLES
… …
104 115
105=item %cf::CFG 116=item %cf::CFG
106 117
107Configuration for the server, loaded from C</etc/crossfire/config>, or 118Configuration for the server, loaded from C</etc/crossfire/config>, or
108from wherever your confdir points to. 119from wherever your confdir points to.
120
121=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
122
123These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
124or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
125processing has been done. Call C<< ->wait >> on them to maximise the
126window of cpu time available, or simply to synchronise to the server tick.
109 127
110=back 128=back
111 129
112=cut 130=cut
113 131
… …
117 utf8::encode $msg; 135 utf8::encode $msg;
118 136
119 $msg .= "\n" 137 $msg .= "\n"
120 unless $msg =~ /\n$/; 138 unless $msg =~ /\n$/;
121 139
122 LOG llevError, "cfperl: $msg"; 140 LOG llevError, $msg;
123 }; 141 };
124} 142}
125 143
126@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 144@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
127@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 145@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
… …
145 163
146$Event::DIED = sub { 164$Event::DIED = sub {
147 warn "error in event callback: @_"; 165 warn "error in event callback: @_";
148}; 166};
149 167
150my %ext_pkg;
151my @exts;
152my @hook;
153
154=head2 UTILITY FUNCTIONS 168=head2 UTILITY FUNCTIONS
155 169
156=over 4 170=over 4
157 171
172=item dumpval $ref
173
158=cut 174=cut
175
176sub dumpval {
177 eval {
178 local $SIG{__DIE__};
179 my $d;
180 if (1) {
181 $d = new Data::Dumper([$_[0]], ["*var"]);
182 $d->Terse(1);
183 $d->Indent(2);
184 $d->Quotekeys(0);
185 $d->Useqq(1);
186 #$d->Bless(...);
187 $d->Seen($_[1]) if @_ > 1;
188 $d = $d->Dump();
189 }
190 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
191 $d
192 } || "[unable to dump $_[0]: '$@']";
193}
159 194
160use JSON::Syck (); # TODO# replace by JSON::PC once working 195use JSON::Syck (); # TODO# replace by JSON::PC once working
161 196
162=item $ref = cf::from_json $json 197=item $ref = cf::from_json $json
163 198
… …
224} 259}
225 260
226sub freeze_mainloop { 261sub freeze_mainloop {
227 return unless $TICK_WATCHER->is_active; 262 return unless $TICK_WATCHER->is_active;
228 263
229 my $guard = Coro::guard { $TICK_WATCHER->start }; 264 my $guard = Coro::guard {
265 $TICK_WATCHER->start;
266 $WRITE_RUNTIME_WATCHER->start;
267 };
268 $WRITE_RUNTIME_WATCHER->stop;
230 $TICK_WATCHER->stop; 269 $TICK_WATCHER->stop;
231 $guard 270 $guard
232} 271}
272
273=item cf::async { BLOCK }
274
275Currently the same as Coro::async_pool, meaning you cannot use
276C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
277thing you are allowed to do is call C<prio> on it.
278
279=cut
280
281BEGIN { *async = \&Coro::async_pool }
233 282
234=item cf::sync_job { BLOCK } 283=item cf::sync_job { BLOCK }
235 284
236The design of crossfire+ requires that the main coro ($Coro::main) is 285The design of crossfire+ requires that the main coro ($Coro::main) is
237always able to handle events or runnable, as crossfire+ is only partly 286always able to handle events or runnable, as crossfire+ is only partly
… …
256 my $freeze_guard = freeze_mainloop; 305 my $freeze_guard = freeze_mainloop;
257 306
258 my $busy = 1; 307 my $busy = 1;
259 my @res; 308 my @res;
260 309
261 (Coro::async_pool { 310 (async {
262 @res = eval { $job->() }; 311 @res = eval { $job->() };
263 warn $@ if $@; 312 warn $@ if $@;
264 undef $busy; 313 undef $busy;
265 })->prio (Coro::PRIO_MAX); 314 })->prio (Coro::PRIO_MAX);
266 315
267 while ($busy) { 316 while ($busy) {
268 unless (Coro::cede) { 317 Coro::cede or Event::one_event;
269 Coro::nready ? Event::one_event 0 : Event::one_event;
270 Coro::cede_notself unless Coro::cede;
271 }
272 } 318 }
273 319
274 wantarray ? @res : $res[0] 320 wantarray ? @res : $res[0]
275 } else { 321 } else {
276 # we are in another coroutine, how wonderful, everything just works 322 # we are in another coroutine, how wonderful, everything just works
277 323
278 $job->() 324 $job->()
279 } 325 }
280} 326}
281 327
282=item $coro = cf::coro { BLOCK } 328=item $coro = cf::async_ext { BLOCK }
283 329
284Creates (and readies) and returns a new coro. This coro is automcatially 330Like async, but this coro is automatically being canceled when the
285being canceled when the extension calling this is being unloaded. 331extension calling this is being unloaded.
286 332
287=cut 333=cut
288 334
289sub coro(&) { 335sub async_ext(&) {
290 my $cb = shift; 336 my $cb = shift;
291 337
292 my $coro = &Coro::async_pool ($cb); 338 my $coro = &Coro::async ($cb);
293 339
294 $coro->on_destroy (sub { 340 $coro->on_destroy (sub {
295 delete $EXT_CORO{$coro+0}; 341 delete $EXT_CORO{$coro+0};
296 }); 342 });
297 $EXT_CORO{$coro+0} = $coro; 343 $EXT_CORO{$coro+0} = $coro;
… …
322} 368}
323 369
324=back 370=back
325 371
326=cut 372=cut
327
328#############################################################################
329
330package cf::path;
331
332sub new {
333 my ($class, $path, $base) = @_;
334
335 $path = $path->as_string if ref $path;
336
337 my $self = bless { }, $class;
338
339 # {... are special paths that are not touched
340 # ?xxx/... are special absolute paths
341 # ?random/... random maps
342 # /! non-realised random map exit
343 # /... normal maps
344 # ~/... per-player maps without a specific player (DO NOT USE)
345 # ~user/... per-player map of a specific user
346
347 if ($path =~ /^{/) {
348 # fine as it is
349 } elsif ($path =~ s{^\?random/}{}) {
350 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
351 $self->{random} = cf::from_json $data;
352 } else {
353 if ($path =~ s{^~([^/]+)?}{}) {
354 $self->{user_rel} = 1;
355
356 if (defined $1) {
357 $self->{user} = $1;
358 } elsif ($base =~ m{^~([^/]+)/}) {
359 $self->{user} = $1;
360 } else {
361 warn "cannot resolve user-relative path without user <$path,$base>\n";
362 }
363 } elsif ($path =~ /^\//) {
364 # already absolute
365 } else {
366 $base =~ s{[^/]+/?$}{};
367 return $class->new ("$base/$path");
368 }
369
370 for ($path) {
371 redo if s{/\.?/}{/};
372 redo if s{/[^/]+/\.\./}{/};
373 }
374 }
375
376 $self->{path} = $path;
377
378 $self
379}
380
381# the name / primary key / in-game path
382sub as_string {
383 my ($self) = @_;
384
385 $self->{user_rel} ? "~$self->{user}$self->{path}"
386 : $self->{random} ? "?random/$self->{path}"
387 : $self->{path}
388}
389
390# the displayed name, this is a one way mapping
391sub visible_name {
392 my ($self) = @_;
393
394# if (my $rmp = $self->{random}) {
395# # todo: be more intelligent about this
396# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
397# } else {
398 $self->as_string
399# }
400}
401
402# escape the /'s in the path
403sub _escaped_path {
404 # ∕ is U+2215
405 (my $path = $_[0]{path}) =~ s/\//∕/g;
406 $path
407}
408
409# the original (read-only) location
410sub load_path {
411 my ($self) = @_;
412
413 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
414}
415
416# the temporary/swap location
417sub save_path {
418 my ($self) = @_;
419
420 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
421 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
422 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
423}
424
425# the unique path, might be eq to save_path
426sub uniq_path {
427 my ($self) = @_;
428
429 $self->{user_rel} || $self->{random}
430 ? undef
431 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
432}
433
434# return random map parameters, or undef
435sub random_map_params {
436 my ($self) = @_;
437
438 $self->{random}
439}
440
441# this is somewhat ugly, but style maps do need special treatment
442sub is_style_map {
443 $_[0]{path} =~ m{^/styles/}
444}
445
446package cf;
447 373
448############################################################################# 374#############################################################################
449 375
450=head2 ATTACHABLE OBJECTS 376=head2 ATTACHABLE OBJECTS
451 377
… …
577our @CB_TYPE = (); # registry for type (cf-object class) based events 503our @CB_TYPE = (); # registry for type (cf-object class) based events
578our @CB_MAP = (); 504our @CB_MAP = ();
579 505
580my %attachment; 506my %attachment;
581 507
508sub cf::attachable::thawer_merge {
509 # simply override everything except _meta
510 local $_[0]{_meta};
511 %{$_[0]} = %{$_[1]};
512}
513
582sub _attach_cb($$$$) { 514sub _attach_cb($$$$) {
583 my ($registry, $event, $prio, $cb) = @_; 515 my ($registry, $event, $prio, $cb) = @_;
584 516
585 use sort 'stable'; 517 use sort 'stable';
586 518
… …
757# object support 689# object support
758 690
759sub reattach { 691sub reattach {
760 # basically do the same as instantiate, without calling instantiate 692 # basically do the same as instantiate, without calling instantiate
761 my ($obj) = @_; 693 my ($obj) = @_;
694
695 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
762 696
763 my $registry = $obj->registry; 697 my $registry = $obj->registry;
764 698
765 @$registry = (); 699 @$registry = ();
766 700
… …
898=cut 832=cut
899 833
900sub register_extcmd { 834sub register_extcmd {
901 my ($name, $cb) = @_; 835 my ($name, $cb) = @_;
902 836
903 my $caller = caller;
904 #warn "registering extcmd '$name' to '$caller'";
905
906 $EXTCMD{$name} = [$cb, $caller]; 837 $EXTCMD{$name} = $cb;
907} 838}
908 839
909cf::player->attach ( 840cf::player->attach (
910 on_command => sub { 841 on_command => sub {
911 my ($pl, $name, $params) = @_; 842 my ($pl, $name, $params) = @_;
… …
924 855
925 my $msg = eval { from_json $buf }; 856 my $msg = eval { from_json $buf };
926 857
927 if (ref $msg) { 858 if (ref $msg) {
928 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 859 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
929 if (my %reply = $cb->[0]->($pl, $msg)) { 860 if (my %reply = $cb->($pl, $msg)) {
930 $pl->ext_reply ($msg->{msgid}, %reply); 861 $pl->ext_reply ($msg->{msgid}, %reply);
931 } 862 }
932 } 863 }
933 } else { 864 } else {
934 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 865 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
936 867
937 cf::override; 868 cf::override;
938 }, 869 },
939); 870);
940 871
941sub register {
942 my ($base, $pkg) = @_;
943
944 #TODO
945}
946
947sub load_extension { 872sub load_extension {
948 my ($path) = @_; 873 my ($path) = @_;
949 874
950 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 875 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
951 my $base = $1; 876 my $base = $1;
952 my $pkg = $1; 877 my $pkg = $1;
953 $pkg =~ s/[^[:word:]]/_/g; 878 $pkg =~ s/[^[:word:]]/_/g;
954 $pkg = "ext::$pkg"; 879 $pkg = "ext::$pkg";
955 880
956 warn "loading '$path' into '$pkg'\n"; 881 warn "... loading '$path' into '$pkg'\n";
957 882
958 open my $fh, "<:utf8", $path 883 open my $fh, "<:utf8", $path
959 or die "$path: $!"; 884 or die "$path: $!";
960 885
961 my $source = 886 my $source =
962 "package $pkg; use strict; use utf8;\n" 887 "package $pkg; use strict; use utf8;\n"
963 . "#line 1 \"$path\"\n{\n" 888 . "#line 1 \"$path\"\n{\n"
964 . (do { local $/; <$fh> }) 889 . (do { local $/; <$fh> })
965 . "\n};\n1"; 890 . "\n};\n1";
966 891
967 eval $source 892 unless (eval $source) {
968 or die $@ ? "$path: $@\n" 893 my $msg = $@ ? "$path: $@\n"
969 : "extension disabled.\n"; 894 : "extension disabled.\n";
970 895 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
971 push @exts, $pkg; 896 warn $@;
972 $ext_pkg{$base} = $pkg; 897 warn "mandatory extension failed to load, exiting.\n";
973 898 exit 1;
974# no strict 'refs'; 899 }
975# @{"$pkg\::ISA"} = ext::; 900 die $@;
976
977 register $base, $pkg;
978}
979
980sub unload_extension {
981 my ($pkg) = @_;
982
983 warn "removing extension $pkg\n";
984
985 # remove hooks
986 #TODO
987# for my $idx (0 .. $#PLUGIN_EVENT) {
988# delete $hook[$idx]{$pkg};
989# } 901 }
990 902
991 # remove commands 903 push @EXTS, $pkg;
992 for my $name (keys %COMMAND) {
993 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
994
995 if (@cb) {
996 $COMMAND{$name} = \@cb;
997 } else {
998 delete $COMMAND{$name};
999 }
1000 }
1001
1002 # remove extcmds
1003 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1004 delete $EXTCMD{$name};
1005 }
1006
1007 if (my $cb = $pkg->can ("unload")) {
1008 eval {
1009 $cb->($pkg);
1010 1
1011 } or warn "$pkg unloaded, but with errors: $@";
1012 }
1013
1014 Symbol::delete_package $pkg;
1015} 904}
1016 905
1017sub load_extensions { 906sub load_extensions {
1018 for my $ext (<$LIBDIR/*.ext>) { 907 for my $ext (<$LIBDIR/*.ext>) {
1019 next unless -r $ext; 908 next unless -r $ext;
… …
1023 } or warn "$ext not loaded: $@"; 912 } or warn "$ext not loaded: $@";
1024 } 913 }
1025} 914}
1026 915
1027############################################################################# 916#############################################################################
1028# load/save/clean perl data associated with a map
1029
1030*cf::mapsupport::on_clean = sub {
1031 my ($map) = @_;
1032
1033 my $path = $map->tmpname;
1034 defined $path or return;
1035
1036 unlink "$path.pst";
1037};
1038
1039cf::map->attach (prio => -10000, package => cf::mapsupport::);
1040
1041#############################################################################
1042# load/save perl data associated with player->ob objects
1043
1044sub all_objects(@) {
1045 @_, map all_objects ($_->inv), @_
1046}
1047
1048# TODO: compatibility cruft, remove when no longer needed
1049cf::player->attach (
1050 on_load => sub {
1051 my ($pl, $path) = @_;
1052
1053 for my $o (all_objects $pl->ob) {
1054 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1055 $o->set_ob_key_value ("_perl_data");
1056
1057 %$o = %{ Storable::thaw pack "H*", $value };
1058 }
1059 }
1060 },
1061);
1062
1063#############################################################################
1064 917
1065=head2 CORE EXTENSIONS 918=head2 CORE EXTENSIONS
1066 919
1067Functions and methods that extend core crossfire objects. 920Functions and methods that extend core crossfire objects.
1068 921
922=cut
923
924package cf::player;
925
926use Coro::AIO;
927
1069=head3 cf::player 928=head3 cf::player
1070 929
1071=over 4 930=over 4
1072 931
1073=item cf::player::exists $login 932=item cf::player::find $login
1074 933
1075Returns true when the given account exists. 934Returns the given player object, loading it if necessary (might block).
1076 935
1077=cut 936=cut
1078 937
1079sub cf::player::exists($) { 938sub playerdir($) {
1080 cf::player::find $_[0] 939 cf::localdir
1081 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 940 . "/"
941 . cf::playerdir
942 . "/"
943 . (ref $_[0] ? $_[0]->ob->name : $_[0])
944}
945
946sub path($) {
947 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
948
949 (playerdir $login) . "/$login.pl"
950}
951
952sub find_active($) {
953 $cf::PLAYER{$_[0]}
954 and $cf::PLAYER{$_[0]}->active
955 and $cf::PLAYER{$_[0]}
956}
957
958sub exists($) {
959 my ($login) = @_;
960
961 $cf::PLAYER{$login}
962 or cf::sync_job { !aio_stat path $login }
963}
964
965sub find($) {
966 return $cf::PLAYER{$_[0]} || do {
967 my $login = $_[0];
968
969 my $guard = cf::lock_acquire "user_find:$login";
970
971 $cf::PLAYER{$_[0]} || do {
972 my $pl = load_pl path $login
973 or return;
974 $cf::PLAYER{$login} = $pl
975 }
976 }
977}
978
979sub save($) {
980 my ($pl) = @_;
981
982 return if $pl->{deny_save};
983
984 my $path = path $pl;
985 my $guard = cf::lock_acquire "user_save:$path";
986
987 return if $pl->{deny_save};
988
989 aio_mkdir playerdir $pl, 0770;
990 $pl->{last_save} = $cf::RUNTIME;
991
992 $pl->save_pl ($path);
993 Coro::cede;
994}
995
996sub new($) {
997 my ($login) = @_;
998
999 my $self = create;
1000
1001 $self->ob->name ($login);
1002 $self->{deny_save} = 1;
1003
1004 $cf::PLAYER{$login} = $self;
1005
1006 $self
1007}
1008
1009=item $pl->quit_character
1010
1011Nukes the player without looking back. If logged in, the connection will
1012be destroyed. May block for a long time.
1013
1014=cut
1015
1016sub quit_character {
1017 my ($pl) = @_;
1018
1019 $pl->{deny_save} = 1;
1020 $pl->password ("*"); # this should lock out the player until we nuked the dir
1021
1022 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1023 $pl->deactivate;
1024 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1025 $pl->ns->destroy if $pl->ns;
1026
1027 my $path = playerdir $pl;
1028 my $temp = "$path~$cf::RUNTIME~deleting~";
1029 aio_rename $path, $temp;
1030 delete $cf::PLAYER{$pl->ob->name};
1031 $pl->destroy;
1032 IO::AIO::aio_rmtree $temp;
1033}
1034
1035=item cf::player::list_logins
1036
1037Returns am arrayref of all valid playernames in the system, can take a
1038while and may block, so not sync_job-capable, ever.
1039
1040=cut
1041
1042sub list_logins {
1043 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1044 or return [];
1045
1046 my @logins;
1047
1048 for my $login (@$dirs) {
1049 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1050 aio_read $fh, 0, 512, my $buf, 0 or next;
1051 $buf !~ /^password -------------$/m or next; # official not-valid tag
1052
1053 utf8::decode $login;
1054 push @logins, $login;
1055 }
1056
1057 \@logins
1058}
1059
1060=item $player->maps
1061
1062Returns an arrayref of map paths that are private for this
1063player. May block.
1064
1065=cut
1066
1067sub maps($) {
1068 my ($pl) = @_;
1069
1070 my $files = aio_readdir playerdir $pl
1071 or return;
1072
1073 my @paths;
1074
1075 for (@$files) {
1076 utf8::decode $_;
1077 next if /\.(?:pl|pst)$/;
1078 next unless /^$PATH_SEP/o;
1079
1080 s/\.map$//;
1081 push @paths, "~" . $pl->ob->name . "/" . $_;
1082 }
1083
1084 \@paths
1082} 1085}
1083 1086
1084=item $player->ext_reply ($msgid, $msgtype, %msg) 1087=item $player->ext_reply ($msgid, $msgtype, %msg)
1085 1088
1086Sends an ext reply to the player. 1089Sends an ext reply to the player.
1087 1090
1088=cut 1091=cut
1089 1092
1090sub cf::player::ext_reply($$$%) { 1093sub ext_reply($$$%) {
1091 my ($self, $id, %msg) = @_; 1094 my ($self, $id, %msg) = @_;
1092 1095
1093 $msg{msgid} = $id; 1096 $msg{msgid} = $id;
1094 1097
1095 $self->send ("ext " . to_json \%msg); 1098 $self->send ("ext " . cf::to_json \%msg);
1096} 1099}
1100
1101package cf;
1097 1102
1098=back 1103=back
1099 1104
1100 1105
1101=head3 cf::map 1106=head3 cf::map
… …
1107package cf::map; 1112package cf::map;
1108 1113
1109use Fcntl; 1114use Fcntl;
1110use Coro::AIO; 1115use Coro::AIO;
1111 1116
1117use overload
1118 '""' => \&as_string,
1119 fallback => 1;
1120
1112our $MAX_RESET = 3600; 1121our $MAX_RESET = 3600;
1113our $DEFAULT_RESET = 3000; 1122our $DEFAULT_RESET = 3000;
1114 1123
1115sub generate_random_map { 1124sub generate_random_map {
1116 my ($path, $rmp) = @_; 1125 my ($self, $rmp) = @_;
1117
1118 # mit "rum" bekleckern, nicht 1126 # mit "rum" bekleckern, nicht
1119 cf::map::_create_random_map 1127 $self->_create_random_map (
1120 $path,
1121 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1128 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1122 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1129 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1123 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1130 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1124 $rmp->{exit_on_final_map}, 1131 $rmp->{exit_on_final_map},
1125 $rmp->{xsize}, $rmp->{ysize}, 1132 $rmp->{xsize}, $rmp->{ysize},
1126 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1133 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1127 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1134 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1128 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1135 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1129 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1136 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1130 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1137 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1131 (cf::region::find $rmp->{region}) 1138 (cf::region::find $rmp->{region}), $rmp->{custom}
1139 )
1140}
1141
1142sub register {
1143 my (undef, $regex) = @_;
1144 my $pkg = caller;
1145
1146 no strict;
1147 push @{"$pkg\::ISA"}, __PACKAGE__;
1148
1149 $EXT_MAP{$pkg} = qr<$regex>;
1150}
1151
1152# also paths starting with '/'
1153$EXT_MAP{"cf::map"} = qr{^(?=/)};
1154
1155sub thawer_merge {
1156 my ($self, $merge) = @_;
1157
1158 # we have to keep some variables in memory intact
1159 local $self->{path};
1160 local $self->{load_path};
1161 local $self->{deny_save};
1162 local $self->{deny_reset};
1163
1164 $self->SUPER::thawer_merge ($merge);
1165}
1166
1167sub normalise {
1168 my ($path, $base) = @_;
1169
1170 # map plan:
1171 #
1172 # /! non-realised random map exit (special hack!)
1173 # {... are special paths that are not being touched
1174 # ?xxx/... are special absolute paths
1175 # ?random/... random maps
1176 # /... normal maps
1177 # ~user/... per-player map of a specific user
1178
1179 $path =~ s/$PATH_SEP/\//go;
1180
1181 # treat it as relative path if it starts with
1182 # something that looks reasonable
1183 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1184 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1185
1186 $base =~ s{[^/]+/?$}{};
1187 $path = "$base/$path";
1188 }
1189
1190 for ($path) {
1191 redo if s{//}{/};
1192 redo if s{/\.?/}{/};
1193 redo if s{/[^/]+/\.\./}{/};
1194 }
1195
1196 $path
1197}
1198
1199sub new_from_path {
1200 my (undef, $path, $base) = @_;
1201
1202 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1203
1204 $path = normalise $path, $base;
1205
1206 for my $pkg (keys %EXT_MAP) {
1207 if ($path =~ $EXT_MAP{$pkg}) {
1208 my $self = bless cf::map::new, $pkg;
1209 $self->{path} = $path; $self->path ($path);
1210 $self->init; # pass $1 etc.
1211 return $self;
1212 }
1213 }
1214
1215 Carp::carp "unable to resolve path '$path'.";
1216 ()
1217}
1218
1219sub init {
1220 my ($self) = @_;
1221
1222 $self
1223}
1224
1225sub as_string {
1226 my ($self) = @_;
1227
1228 "$self->{path}"
1229}
1230
1231# the displayed name, this is a one way mapping
1232sub visible_name {
1233 &as_string
1234}
1235
1236# the original (read-only) location
1237sub load_path {
1238 my ($self) = @_;
1239
1240 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
1241}
1242
1243# the temporary/swap location
1244sub save_path {
1245 my ($self) = @_;
1246
1247 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1248 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path
1249}
1250
1251# the unique path, undef == no special unique path
1252sub uniq_path {
1253 my ($self) = @_;
1254
1255 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1256 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path
1132} 1257}
1133 1258
1134# and all this just because we cannot iterate over 1259# and all this just because we cannot iterate over
1135# all maps in C++... 1260# all maps in C++...
1136sub change_all_map_light { 1261sub change_all_map_light {
… …
1138 1263
1139 $_->change_map_light ($change) 1264 $_->change_map_light ($change)
1140 for grep $_->outdoor, values %cf::MAP; 1265 for grep $_->outdoor, values %cf::MAP;
1141} 1266}
1142 1267
1268sub unlink_save {
1269 my ($self) = @_;
1270
1271 utf8::encode (my $save = $self->save_path);
1272 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1273 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1274}
1275
1143sub try_load_header($) { 1276sub load_header_from($) {
1144 my ($path) = @_; 1277 my ($self, $path) = @_;
1145 1278
1146 utf8::encode $path; 1279 utf8::encode $path;
1147 aio_open $path, O_RDONLY, 0 1280 aio_open $path, O_RDONLY, 0
1148 or return; 1281 or return;
1149 1282
1150 my $map = cf::map::new 1283 $self->_load_header ($path)
1151 or return; 1284 or return;
1152 1285
1153 # for better error messages only, will be overwritten 1286 $self->{load_path} = $path;
1154 $map->path ($path);
1155 1287
1156 $map->load_header ($path) 1288 1
1289}
1290
1291sub load_orig {
1292 my ($self) = @_;
1293
1294 $self->load_header_from ($self->load_path)
1295}
1296
1297sub load_temp {
1298 my ($self) = @_;
1299
1300 $self->load_header_from ($self->save_path)
1301}
1302
1303sub load_header {
1304 my ($self) = @_;
1305
1306 if ($self->load_temp) {
1307 $self->last_access ((delete $self->{last_access})
1308 || $cf::RUNTIME); #d#
1309 # safety
1310 $self->{instantiate_time} = $cf::RUNTIME
1311 if $self->{instantiate_time} > $cf::RUNTIME;
1312 } else {
1313 $self->load_orig
1157 or return; 1314 or return;
1158 1315
1159 $map->{load_path} = $path; 1316 $self->{load_original} = 1;
1317 $self->{instantiate_time} = $cf::RUNTIME;
1318 $self->last_access ($cf::RUNTIME);
1319 $self->instantiate;
1320 }
1160 1321
1161 $map 1322 1
1162} 1323}
1163 1324
1164sub find; 1325sub find;
1165sub find { 1326sub find {
1166 my ($path, $origin) = @_; 1327 my ($path, $origin) = @_;
1167 1328
1168 #warn "find<$path,$origin>\n";#d#
1169
1170 $path = new cf::path $path, $origin && $origin->path; 1329 $path = normalise $path, $origin && $origin->path;
1171 my $key = $path->as_string;
1172 1330
1173 cf::lock_wait "map_find:$key"; 1331 cf::lock_wait "map_find:$path";
1174 1332
1175 $cf::MAP{$key} || do { 1333 $cf::MAP{$path} || do {
1176 my $guard = cf::lock_acquire "map_find:$key"; 1334 my $guard = cf::lock_acquire "map_find:$path";
1177 1335 my $map = new_from_path cf::map $path
1178 # do it the slow way
1179 my $map = try_load_header $path->save_path;
1180
1181 Coro::cede;
1182
1183 if ($map) {
1184 $map->last_access ((delete $map->{last_access})
1185 || $cf::RUNTIME); #d#
1186 # safety
1187 $map->{instantiate_time} = $cf::RUNTIME
1188 if $map->{instantiate_time} > $cf::RUNTIME;
1189 } else {
1190 if (my $rmp = $path->random_map_params) {
1191 $map = generate_random_map $key, $rmp;
1192 } else {
1193 $map = try_load_header $path->load_path;
1194 }
1195
1196 $map or return; 1336 or return;
1197 1337
1198 $map->{load_original} = 1;
1199 $map->{instantiate_time} = $cf::RUNTIME;
1200 $map->last_access ($cf::RUNTIME);
1201 $map->instantiate;
1202
1203 # per-player maps become, after loading, normal maps
1204 $map->per_player (0) if $path->{user_rel};
1205 }
1206
1207 $map->path ($key);
1208 $map->{path} = $path;
1209 $map->{last_save} = $cf::RUNTIME; 1338 $map->{last_save} = $cf::RUNTIME;
1210 1339
1211 Coro::cede; 1340 $map->load_header
1341 or return;
1212 1342
1213 if ($map->should_reset) { 1343 if ($map->should_reset) {
1344 $cf::WAIT_FOR_TICK->wait;
1214 $map->reset; 1345 $map->reset;
1215 undef $guard; 1346 undef $guard;
1216 $map = find $path 1347 $map = find $path
1217 or return; 1348 or return;
1218 } 1349 }
1219 1350
1220 $cf::MAP{$key} = $map 1351 $cf::MAP{$path} = $map
1221 } 1352 }
1222} 1353}
1223 1354
1224sub load { 1355sub load {
1225 my ($self) = @_; 1356 my ($self) = @_;
1226 1357
1227 my $path = $self->{path}; 1358 my $path = $self->{path};
1228 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1359 my $guard = cf::lock_acquire "map_load:$path";
1229 1360
1230 return if $self->in_memory != cf::MAP_SWAPPED; 1361 return if $self->in_memory != cf::MAP_SWAPPED;
1231 1362
1232 $self->in_memory (cf::MAP_LOADING); 1363 $self->in_memory (cf::MAP_LOADING);
1233 1364
1234 $self->alloc; 1365 $self->alloc;
1235 $self->load_objects ($self->{load_path}, 1) 1366 $self->_load_objects ($self->{load_path}, 1)
1236 or return; 1367 or return;
1237 1368
1238 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1369 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1239 if delete $self->{load_original}; 1370 if delete $self->{load_original};
1240 1371
1241 if (my $uniq = $path->uniq_path) { 1372 if (my $uniq = $self->uniq_path) {
1242 utf8::encode $uniq; 1373 utf8::encode $uniq;
1243 if (aio_open $uniq, O_RDONLY, 0) { 1374 if (aio_open $uniq, O_RDONLY, 0) {
1244 $self->clear_unique_items; 1375 $self->clear_unique_items;
1245 $self->load_objects ($uniq, 0); 1376 $self->_load_objects ($uniq, 0);
1246 } 1377 }
1247 } 1378 }
1248 1379
1249 Coro::cede; 1380 Coro::cede;
1250 1381
1251 # now do the right thing for maps 1382 # now do the right thing for maps
1252 $self->link_multipart_objects; 1383 $self->link_multipart_objects;
1253 1384
1254 if ($self->{path}->is_style_map) { 1385 unless ($self->{deny_activate}) {
1255 $self->{deny_save} = 1; 1386 $self->decay_objects;
1256 $self->{deny_reset} = 1;
1257 } else {
1258 $self->fix_auto_apply; 1387 $self->fix_auto_apply;
1259 $self->decay_objects;
1260 $self->update_buttons; 1388 $self->update_buttons;
1389 Coro::cede;
1261 $self->set_darkness_map; 1390 $self->set_darkness_map;
1262 $self->difficulty ($self->estimate_difficulty) 1391 $self->difficulty ($self->estimate_difficulty)
1263 unless $self->difficulty; 1392 unless $self->difficulty;
1393 Coro::cede;
1264 $self->activate; 1394 $self->activate;
1265 } 1395 }
1266 1396
1267 Coro::cede;
1268
1269 $self->in_memory (cf::MAP_IN_MEMORY); 1397 $self->in_memory (cf::MAP_IN_MEMORY);
1398}
1399
1400sub customise_for {
1401 my ($self, $ob) = @_;
1402
1403 return find "~" . $ob->name . "/" . $self->{path}
1404 if $self->per_player;
1405
1406 $self
1407}
1408
1409# find and load all maps in the 3x3 area around a map
1410sub load_diag {
1411 my ($map) = @_;
1412
1413 my @diag; # diagonal neighbours
1414
1415 for (0 .. 3) {
1416 my $neigh = $map->tile_path ($_)
1417 or next;
1418 $neigh = find $neigh, $map
1419 or next;
1420 $neigh->load;
1421
1422 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1423 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1424 }
1425
1426 for (@diag) {
1427 my $neigh = find @$_
1428 or next;
1429 $neigh->load;
1430 }
1270} 1431}
1271 1432
1272sub find_sync { 1433sub find_sync {
1273 my ($path, $origin) = @_; 1434 my ($path, $origin) = @_;
1274 1435
1275 cf::sync_job { 1436 cf::sync_job { find $path, $origin }
1276 my $map = cf::map::find $path, $origin;
1277 $map
1278 }
1279} 1437}
1280 1438
1281sub do_load_sync { 1439sub do_load_sync {
1282 my ($map) = @_; 1440 my ($map) = @_;
1283 1441
1284 cf::sync_job { $map->load }; 1442 cf::sync_job { $map->load };
1285} 1443}
1286 1444
1445our %MAP_PREFETCH;
1446our $MAP_PREFETCHER = undef;
1447
1448sub find_async {
1449 my ($path, $origin) = @_;
1450
1451 $path = normalise $path, $origin && $origin->{path};
1452
1453 if (my $map = $cf::MAP{$path}) {
1454 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1455 }
1456
1457 undef $MAP_PREFETCH{$path};
1458 $MAP_PREFETCHER ||= cf::async {
1459 while (%MAP_PREFETCH) {
1460 for my $path (keys %MAP_PREFETCH) {
1461 warn "prefetching $path...\n";#d#
1462 my $map = find $path
1463 or next;
1464 $map->load;
1465
1466 delete $MAP_PREFETCH{$path};
1467 }
1468 }
1469 undef $MAP_PREFETCHER;
1470 };
1471
1472 ()
1473}
1474
1287sub save { 1475sub save {
1288 my ($self) = @_; 1476 my ($self) = @_;
1289 1477
1290 my $lock = cf::lock_acquire "map_data:" . $self->path; 1478 my $lock = cf::lock_acquire "map_data:" . $self->path;
1291 1479
1292 $self->{last_save} = $cf::RUNTIME; 1480 $self->{last_save} = $cf::RUNTIME;
1293 1481
1294 return unless $self->dirty; 1482 return unless $self->dirty;
1295 1483
1296 my $save = $self->{path}->save_path; utf8::encode $save; 1484 my $save = $self->save_path; utf8::encode $save;
1297 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1485 my $uniq = $self->uniq_path; utf8::encode $uniq;
1298 1486
1299 $self->{load_path} = $save; 1487 $self->{load_path} = $save;
1300 1488
1301 return if $self->{deny_save}; 1489 return if $self->{deny_save};
1302 1490
1303 local $self->{last_access} = $self->last_access;#d# 1491 local $self->{last_access} = $self->last_access;#d#
1304 1492
1493 cf::async {
1494 $_->contr->save for $self->players;
1495 };
1496
1305 if ($uniq) { 1497 if ($uniq) {
1306 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1498 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1307 $self->save_objects ($uniq, cf::IO_UNIQUES); 1499 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1308 } else { 1500 } else {
1309 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 1501 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1310 } 1502 }
1311} 1503}
1312 1504
1313sub swap_out { 1505sub swap_out {
1314 my ($self) = @_; 1506 my ($self) = @_;
… …
1328 1520
1329sub reset_at { 1521sub reset_at {
1330 my ($self) = @_; 1522 my ($self) = @_;
1331 1523
1332 # TODO: safety, remove and allow resettable per-player maps 1524 # TODO: safety, remove and allow resettable per-player maps
1333 return 1e99 if $self->{path}{user_rel}; 1525 return 1e99 if $self->isa ("ext::map_per_player");#d#
1334 return 1e99 if $self->{deny_reset}; 1526 return 1e99 if $self->{deny_reset};
1335 1527
1336 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1528 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1337 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1529 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1338 1530
… …
1343 my ($self) = @_; 1535 my ($self) = @_;
1344 1536
1345 $self->reset_at <= $cf::RUNTIME 1537 $self->reset_at <= $cf::RUNTIME
1346} 1538}
1347 1539
1348sub unlink_save {
1349 my ($self) = @_;
1350
1351 utf8::encode (my $save = $self->{path}->save_path);
1352 aioreq_pri 3; IO::AIO::aio_unlink $save;
1353 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1354}
1355
1356sub rename {
1357 my ($self, $new_path) = @_;
1358
1359 $self->unlink_save;
1360
1361 delete $cf::MAP{$self->path};
1362 $self->{path} = new cf::path $new_path;
1363 $self->path ($self->{path}->as_string);
1364 $cf::MAP{$self->path} = $self;
1365
1366 $self->save;
1367}
1368
1369sub reset { 1540sub reset {
1370 my ($self) = @_; 1541 my ($self) = @_;
1371 1542
1372 my $lock = cf::lock_acquire "map_data:" . $self->path; 1543 my $lock = cf::lock_acquire "map_data:$self->{path}";
1373 1544
1374 return if $self->players; 1545 return if $self->players;
1375 return if $self->{path}{user_rel};#d# 1546 return if $self->isa ("ext::map_per_player");#d#
1376 1547
1377 warn "resetting map ", $self->path;#d# 1548 warn "resetting map ", $self->path;#d#
1378 1549
1379 delete $cf::MAP{$self->path}; 1550 delete $cf::MAP{$self->path};
1551
1552 $self->in_memory (cf::MAP_SWAPPED);
1553 $self->clear;
1380 1554
1381 $_->clear_links_to ($self) for values %cf::MAP; 1555 $_->clear_links_to ($self) for values %cf::MAP;
1382 1556
1383 $self->unlink_save; 1557 $self->unlink_save;
1384 $self->destroy; 1558 $self->destroy;
… …
1387my $nuke_counter = "aaaa"; 1561my $nuke_counter = "aaaa";
1388 1562
1389sub nuke { 1563sub nuke {
1390 my ($self) = @_; 1564 my ($self) = @_;
1391 1565
1566 delete $cf::MAP{$self->path};
1567
1568 $self->unlink_save;
1569
1570 bless $self, "cf::map";
1571 delete $self->{deny_reset};
1392 $self->{deny_save} = 1; 1572 $self->{deny_save} = 1;
1393 $self->reset_timeout (1); 1573 $self->reset_timeout (1);
1394 $self->rename ("{nuke}/" . ($nuke_counter++)); 1574 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1575
1576 $cf::MAP{$self->path} = $self;
1577
1395 $self->reset; # polite request, might not happen 1578 $self->reset; # polite request, might not happen
1396} 1579}
1397 1580
1398sub customise_for { 1581=item cf::map::unique_maps
1399 my ($map, $ob) = @_;
1400 1582
1401 if ($map->per_player) { 1583Returns an arrayref of paths of all shared maps that have
1402 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1584instantiated unique items. May block.
1403 }
1404 1585
1405 $map 1586=cut
1406}
1407 1587
1408sub emergency_save { 1588sub unique_maps() {
1409 my $freeze_guard = cf::freeze_mainloop; 1589 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1590 or return;
1410 1591
1411 warn "enter emergency map save\n"; 1592 my @paths;
1412 1593
1413 cf::sync_job { 1594 for (@$files) {
1414 warn "begin emergency map save\n"; 1595 utf8::decode $_;
1415 $_->save for values %cf::MAP; 1596 next if /\.pst$/;
1597 next unless /^$PATH_SEP/o;
1598
1599 s/\.map$//;
1600 push @paths, $_;
1416 }; 1601 }
1417 1602
1418 warn "end emergency map save\n"; 1603 \@paths
1419} 1604}
1420 1605
1421package cf; 1606package cf;
1422 1607
1423=back 1608=back
1424 1609
1610=head3 cf::object
1611
1612=cut
1613
1614package cf::object;
1615
1616=over 4
1617
1618=item $ob->inv_recursive
1619
1620Returns the inventory of the object _and_ their inventories, recursively.
1621
1622=cut
1623
1624sub inv_recursive_;
1625sub inv_recursive_ {
1626 map { $_, inv_recursive_ $_->inv } @_
1627}
1628
1629sub inv_recursive {
1630 inv_recursive_ inv $_[0]
1631}
1632
1633package cf;
1634
1635=back
1425 1636
1426=head3 cf::object::player 1637=head3 cf::object::player
1427 1638
1428=over 4 1639=over 4
1429 1640
… …
1469 1680
1470=item $player_object->enter_link 1681=item $player_object->enter_link
1471 1682
1472Freezes the player and moves him/her to a special map (C<{link}>). 1683Freezes the player and moves him/her to a special map (C<{link}>).
1473 1684
1474The player should be reaosnably safe there for short amounts of time. You 1685The player should be reasonably safe there for short amounts of time. You
1475I<MUST> call C<leave_link> as soon as possible, though. 1686I<MUST> call C<leave_link> as soon as possible, though.
1476 1687
1688Will never block.
1689
1477=item $player_object->leave_link ($map, $x, $y) 1690=item $player_object->leave_link ($map, $x, $y)
1478 1691
1479Moves the player out of the specila link map onto the given map. If the 1692Moves the player out of the special C<{link}> map onto the specified
1480map is not valid (or omitted), the player will be moved back to the 1693map. If the map is not valid (or omitted), the player will be moved back
1481location he/she was before the call to C<enter_link>, or, if that fails, 1694to the location he/she was before the call to C<enter_link>, or, if that
1482to the emergency map position. 1695fails, to the emergency map position.
1483 1696
1484Might block. 1697Might block.
1485 1698
1486=cut 1699=cut
1700
1701sub link_map {
1702 unless ($LINK_MAP) {
1703 $LINK_MAP = cf::map::find "{link}"
1704 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 };
1705 $LINK_MAP->load;
1706 }
1707
1708 $LINK_MAP
1709}
1487 1710
1488sub cf::object::player::enter_link { 1711sub cf::object::player::enter_link {
1489 my ($self) = @_; 1712 my ($self) = @_;
1490 1713
1491 $self->deactivate_recursive; 1714 $self->deactivate_recursive;
1492 1715
1493 return if $self->map == $LINK_MAP; 1716 return if UNIVERSAL::isa $self->map, "ext::map_link";
1494 1717
1495 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 1718 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1496 if $self->map; 1719 if $self->map;
1497 1720
1498 $self->enter_map ($LINK_MAP, 20, 20); 1721 $self->enter_map ($LINK_MAP || link_map, 20, 20);
1499} 1722}
1500 1723
1501sub cf::object::player::leave_link { 1724sub cf::object::player::leave_link {
1502 my ($self, $map, $x, $y) = @_; 1725 my ($self, $map, $x, $y) = @_;
1503 1726
… …
1521 # use -1 or undef as default coordinates, not 0, 0 1744 # use -1 or undef as default coordinates, not 0, 0
1522 ($x, $y) = ($map->enter_x, $map->enter_y) 1745 ($x, $y) = ($map->enter_x, $map->enter_y)
1523 if $x <=0 && $y <= 0; 1746 if $x <=0 && $y <= 0;
1524 1747
1525 $map->load; 1748 $map->load;
1749 $map->load_diag;
1526 1750
1751 return unless $self->contr->active;
1527 $self->activate_recursive; 1752 $self->activate_recursive;
1528 $self->enter_map ($map, $x, $y); 1753 $self->enter_map ($map, $x, $y);
1529} 1754}
1530 1755
1531cf::player->attach ( 1756cf::player->attach (
… …
1543 my ($pl) = @_; 1768 my ($pl) = @_;
1544 1769
1545 # try to abort aborted map switching on player login :) 1770 # try to abort aborted map switching on player login :)
1546 # should happen only on crashes 1771 # should happen only on crashes
1547 if ($pl->ob->{_link_pos}) { 1772 if ($pl->ob->{_link_pos}) {
1548
1549 $pl->ob->enter_link; 1773 $pl->ob->enter_link;
1550 (Coro::async_pool { 1774 (async {
1551 # we need this sleep as the login has a concurrent enter_exit running 1775 # we need this sleep as the login has a concurrent enter_exit running
1552 # and this sleep increases chances of the player not ending up in scorn 1776 # and this sleep increases chances of the player not ending up in scorn
1777 $pl->ob->reply (undef,
1778 "There was an internal problem at your last logout, "
1779 . "the server will try to bring you to your intended destination in a second.",
1780 cf::NDI_RED);
1553 Coro::Timer::sleep 1; 1781 Coro::Timer::sleep 1;
1554 $pl->ob->leave_link; 1782 $pl->ob->leave_link;
1555 })->prio (2); 1783 })->prio (2);
1556 } 1784 }
1557 }, 1785 },
… …
1564sub cf::object::player::goto { 1792sub cf::object::player::goto {
1565 my ($self, $path, $x, $y) = @_; 1793 my ($self, $path, $x, $y) = @_;
1566 1794
1567 $self->enter_link; 1795 $self->enter_link;
1568 1796
1569 (Coro::async_pool { 1797 (async {
1570 $path = new cf::path $path;
1571
1572 my $map = cf::map::find $path->as_string; 1798 my $map = cf::map::find $path;
1573 $map = $map->customise_for ($self) if $map; 1799 $map = $map->customise_for ($self) if $map;
1574 1800
1575# warn "entering ", $map->path, " at ($x, $y)\n" 1801# warn "entering ", $map->path, " at ($x, $y)\n"
1576# if $map; 1802# if $map;
1577 1803
1578 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1804 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1579 1805
1580 $self->leave_link ($map, $x, $y); 1806 $self->leave_link ($map, $x, $y);
1581 })->prio (1); 1807 })->prio (1);
1582} 1808}
1583 1809
… …
1587 1813
1588sub parse_random_map_params { 1814sub parse_random_map_params {
1589 my ($spec) = @_; 1815 my ($spec) = @_;
1590 1816
1591 my $rmp = { # defaults 1817 my $rmp = { # defaults
1592 xsize => 10, 1818 xsize => (cf::rndm 15, 40),
1593 ysize => 10, 1819 ysize => (cf::rndm 15, 40),
1820 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
1821 #layout => string,
1594 }; 1822 };
1595 1823
1596 for (split /\n/, $spec) { 1824 for (split /\n/, $spec) {
1597 my ($k, $v) = split /\s+/, $_, 2; 1825 my ($k, $v) = split /\s+/, $_, 2;
1598 1826
… …
1602 $rmp 1830 $rmp
1603} 1831}
1604 1832
1605sub prepare_random_map { 1833sub prepare_random_map {
1606 my ($exit) = @_; 1834 my ($exit) = @_;
1835
1836 my $guard = cf::lock_acquire "exit_prepare:$exit";
1607 1837
1608 # all this does is basically replace the /! path by 1838 # all this does is basically replace the /! path by
1609 # a new random map path (?random/...) with a seed 1839 # a new random map path (?random/...) with a seed
1610 # that depends on the exit object 1840 # that depends on the exit object
1611 1841
… …
1620 1850
1621 $rmp->{random_seed} ||= $exit->random_seed; 1851 $rmp->{random_seed} ||= $exit->random_seed;
1622 1852
1623 my $data = cf::to_json $rmp; 1853 my $data = cf::to_json $rmp;
1624 my $md5 = Digest::MD5::md5_hex $data; 1854 my $md5 = Digest::MD5::md5_hex $data;
1855 my $meta = "$cf::RANDOM_MAPS/$md5.meta";
1625 1856
1626 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 1857 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1627 aio_write $fh, 0, (length $data), $data, 0; 1858 aio_write $fh, 0, (length $data), $data, 0;
1859 undef $fh;
1860 aio_rename "$meta~", $meta;
1628 1861
1629 $exit->slaying ("?random/$md5"); 1862 $exit->slaying ("?random/$md5");
1630 $exit->msg (undef); 1863 $exit->msg (undef);
1631 } 1864 }
1632} 1865}
… …
1636 1869
1637 return unless $self->type == cf::PLAYER; 1870 return unless $self->type == cf::PLAYER;
1638 1871
1639 $self->enter_link; 1872 $self->enter_link;
1640 1873
1641 (Coro::async_pool { 1874 (async {
1642 $self->deactivate_recursive; # just to be sure 1875 $self->deactivate_recursive; # just to be sure
1643 unless (eval { 1876 unless (eval {
1644 prepare_random_map $exit 1877 prepare_random_map $exit
1645 if $exit->slaying eq "/!"; 1878 if $exit->slaying eq "/!";
1646 1879
1647 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path; 1880 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1648 $self->goto ($path, $exit->stats->hp, $exit->stats->sp); 1881 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1649 1882
1650 1; 1883 1;
1651 }) { 1884 }) {
1652 $self->message ("Something went wrong deep within the crossfire server. " 1885 $self->message ("Something went wrong deep within the crossfire server. "
1653 . "I'll try to bring you back to the map you were before. " 1886 . "I'll try to bring you back to the map you were before. "
1654 . "Please report this to the dungeon master", 1887 . "Please report this to the dungeon master!",
1655 cf::NDI_UNIQUE | cf::NDI_RED); 1888 cf::NDI_UNIQUE | cf::NDI_RED);
1656 1889
1657 warn "ERROR in enter_exit: $@"; 1890 warn "ERROR in enter_exit: $@";
1658 $self->leave_link; 1891 $self->leave_link;
1659 } 1892 }
… …
1727 } 1960 }
1728 } 1961 }
1729 }, 1962 },
1730); 1963);
1731 1964
1732=item $client->coro (\&cb) 1965=item $client->async (\&cb)
1733 1966
1734Create a new coroutine, running the specified callback. The coroutine will 1967Create a new coroutine, running the specified callback. The coroutine will
1735be automatically cancelled when the client gets destroyed (e.g. on logout, 1968be automatically cancelled when the client gets destroyed (e.g. on logout,
1736or loss of connection). 1969or loss of connection).
1737 1970
1738=cut 1971=cut
1739 1972
1740sub cf::client::coro { 1973sub cf::client::async {
1741 my ($self, $cb) = @_; 1974 my ($self, $cb) = @_;
1742 1975
1743 my $coro = &Coro::async_pool ($cb); 1976 my $coro = &Coro::async ($cb);
1744 1977
1745 $coro->on_destroy (sub { 1978 $coro->on_destroy (sub {
1746 delete $self->{_coro}{$coro+0}; 1979 delete $self->{_coro}{$coro+0};
1747 }); 1980 });
1748 1981
… …
1942 sub db_sync() { 2175 sub db_sync() {
1943 db_save if $dirty; 2176 db_save if $dirty;
1944 undef $dirty; 2177 undef $dirty;
1945 } 2178 }
1946 2179
1947 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub { 2180 my $idle = Event->idle (min => 10, max => 20, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1948 db_sync; 2181 db_sync;
1949 }); 2182 });
1950 2183
1951 sub db_dirty() { 2184 sub db_dirty() {
1952 $dirty = 1; 2185 $dirty = 1;
… …
1991 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 2224 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
1992 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 2225 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
1993 2226
1994 if (exists $CFG{mlockall}) { 2227 if (exists $CFG{mlockall}) {
1995 eval { 2228 eval {
1996 $CFG{mlockall} ? &mlockall : &munlockall 2229 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
1997 and die "WARNING: m(un)lockall failed: $!\n"; 2230 and die "WARNING: m(un)lockall failed: $!\n";
1998 }; 2231 };
1999 warn $@ if $@; 2232 warn $@ if $@;
2000 } 2233 }
2001} 2234}
2002 2235
2003sub main { 2236sub main {
2004 # we must not ever block the main coroutine 2237 # we must not ever block the main coroutine
2005 local $Coro::idle = sub { 2238 local $Coro::idle = sub {
2006 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2239 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2007 Coro::async_pool { Event::one_event }; 2240 (async {
2241 Event::one_event;
2242 })->prio (Coro::PRIO_MAX);
2008 }; 2243 };
2009 2244
2010 cfg_load; 2245 cfg_load;
2011 db_load; 2246 db_load;
2012 load_extensions; 2247 load_extensions;
2248
2249 $TICK_WATCHER->start;
2013 Event::loop; 2250 Event::loop;
2014} 2251}
2015 2252
2016############################################################################# 2253#############################################################################
2017# initialisation 2254# initialisation and cleanup
2255
2256# install some emergency cleanup handlers
2257BEGIN {
2258 for my $signal (qw(INT HUP TERM)) {
2259 Event->signal (
2260 data => WF_AUTOCANCEL,
2261 signal => $signal,
2262 cb => sub {
2263 cf::cleanup "SIG$signal";
2264 },
2265 );
2266 }
2267}
2268
2269sub emergency_save() {
2270 my $freeze_guard = cf::freeze_mainloop;
2271
2272 warn "enter emergency perl save\n";
2273
2274 cf::sync_job {
2275 # use a peculiar iteration method to avoid tripping on perl
2276 # refcount bugs in for. also avoids problems with players
2277 # and maps saved/destroyed asynchronously.
2278 warn "begin emergency player save\n";
2279 for my $login (keys %cf::PLAYER) {
2280 my $pl = $cf::PLAYER{$login} or next;
2281 $pl->valid or next;
2282 $pl->save;
2283 }
2284 warn "end emergency player save\n";
2285
2286 warn "begin emergency map save\n";
2287 for my $path (keys %cf::MAP) {
2288 my $map = $cf::MAP{$path} or next;
2289 $map->valid or next;
2290 $map->save;
2291 }
2292 warn "end emergency map save\n";
2293 };
2294
2295 warn "leave emergency perl save\n";
2296}
2018 2297
2019sub reload() { 2298sub reload() {
2020 # can/must only be called in main 2299 # can/must only be called in main
2021 if ($Coro::current != $Coro::main) { 2300 if ($Coro::current != $Coro::main) {
2022 warn "can only reload from main coroutine\n"; 2301 warn "can only reload from main coroutine";
2023 return; 2302 return;
2024 } 2303 }
2025 2304
2026 warn "reloading..."; 2305 warn "reloading...";
2027 2306
2028 my $guard = freeze_mainloop; 2307 warn "cancelling server ticker";
2308 $TICK_WATCHER->cancel;
2309
2029 cf::emergency_save; 2310 cf::emergency_save;
2030 2311
2031 eval { 2312 eval {
2032 # if anything goes wrong in here, we should simply crash as we already saved 2313 # if anything goes wrong in here, we should simply crash as we already saved
2033 2314
2034 # cancel all watchers 2315 warn "syncing database to disk";
2316 cf::db_sync;
2317
2318 warn "cancelling all WF_AUTOCANCEL watchers";
2035 for (Event::all_watchers) { 2319 for (Event::all_watchers) {
2036 $_->cancel if $_->data & WF_AUTOCANCEL; 2320 $_->cancel if $_->data & WF_AUTOCANCEL;
2037 } 2321 }
2038 2322
2323 warn "flushing outstanding aio requests";
2324 for (;;) {
2325 IO::AIO::flush;
2326 Coro::cede;
2327 last unless IO::AIO::nreqs;
2328 warn "iterate...";
2329 }
2330
2039 # cancel all extension coros 2331 warn "cancelling all extension coros";
2040 $_->cancel for values %EXT_CORO; 2332 $_->cancel for values %EXT_CORO;
2041 %EXT_CORO = (); 2333 %EXT_CORO = ();
2042 2334
2043 # unload all extensions 2335 warn "removing commands";
2044 for (@exts) { 2336 %COMMAND = ();
2337
2338 warn "removing ext commands";
2339 %EXTCMD = ();
2340
2341 warn "unloading/nuking all extensions";
2342 for my $pkg (@EXTS) {
2045 warn "unloading <$_>"; 2343 warn "... unloading $pkg";
2046 unload_extension $_; 2344
2345 if (my $cb = $pkg->can ("unload")) {
2346 eval {
2347 $cb->($pkg);
2348 1
2349 } or warn "$pkg unloaded, but with errors: $@";
2047 } 2350 }
2048 2351
2352 warn "... nuking $pkg";
2353 Symbol::delete_package $pkg;
2354 }
2355
2049 # unload all modules loaded from $LIBDIR 2356 warn "unloading all perl modules loaded from $LIBDIR";
2050 while (my ($k, $v) = each %INC) { 2357 while (my ($k, $v) = each %INC) {
2051 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2358 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2052 2359
2053 warn "removing <$k>"; 2360 warn "... unloading $k";
2054 delete $INC{$k}; 2361 delete $INC{$k};
2055 2362
2056 $k =~ s/\.pm$//; 2363 $k =~ s/\.pm$//;
2057 $k =~ s/\//::/g; 2364 $k =~ s/\//::/g;
2058 2365
… …
2061 } 2368 }
2062 2369
2063 Symbol::delete_package $k; 2370 Symbol::delete_package $k;
2064 } 2371 }
2065 2372
2066 # sync database to disk
2067 cf::db_sync;
2068 IO::AIO::flush;
2069
2070 # get rid of safe::, as good as possible 2373 warn "getting rid of safe::, as good as possible";
2071 Symbol::delete_package "safe::$_" 2374 Symbol::delete_package "safe::$_"
2072 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2375 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2073 2376
2074 # remove register_script_function callbacks
2075 # TODO
2076
2077 # unload cf.pm "a bit" 2377 warn "unloading cf.pm \"a bit\"";
2078 delete $INC{"cf.pm"}; 2378 delete $INC{"cf.pm"};
2079 2379
2080 # don't, removes xs symbols, too, 2380 # don't, removes xs symbols, too,
2081 # and global variables created in xs 2381 # and global variables created in xs
2082 #Symbol::delete_package __PACKAGE__; 2382 #Symbol::delete_package __PACKAGE__;
2083 2383
2084 # reload cf.pm 2384 warn "unload completed, starting to reload now";
2385
2085 warn "reloading cf.pm"; 2386 warn "reloading cf.pm";
2086 require cf; 2387 require cf;
2087 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2388 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2088 2389
2089 # load config and database again 2390 warn "loading config and database again";
2090 cf::cfg_load; 2391 cf::cfg_load;
2091 cf::db_load; 2392 cf::db_load;
2092 2393
2093 # load extensions
2094 warn "load extensions"; 2394 warn "loading extensions";
2095 cf::load_extensions; 2395 cf::load_extensions;
2096 2396
2097 # reattach attachments to objects 2397 warn "reattaching attachments to objects/players";
2098 warn "reattach";
2099 _global_reattach; 2398 _global_reattach;
2399 warn "reattaching attachments to maps";
2400 reattach $_ for values %MAP;
2401
2402 warn "restarting server ticker";
2403
2404 $TICK_WATCHER->start;
2100 }; 2405 };
2101 2406
2102 if ($@) { 2407 if ($@) {
2103 warn $@; 2408 warn $@;
2104 warn "error while reloading, exiting."; 2409 warn "error while reloading, exiting.";
2105 exit 1; 2410 exit 1;
2106 } 2411 }
2107 2412
2108 warn "reloaded successfully"; 2413 warn "reloaded";
2109}; 2414};
2110 2415
2111############################################################################# 2416our $RELOAD_WATCHER; # used only during reload
2112
2113unless ($LINK_MAP) {
2114 $LINK_MAP = cf::map::new;
2115
2116 $LINK_MAP->width (41);
2117 $LINK_MAP->height (41);
2118 $LINK_MAP->alloc;
2119 $LINK_MAP->path ("{link}");
2120 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2121 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2122
2123 # dirty hack because... archetypes are not yet loaded
2124 Event->timer (
2125 after => 2,
2126 cb => sub {
2127 $_[0]->w->cancel;
2128
2129 # provide some exits "home"
2130 my $exit = cf::object::new "exit";
2131
2132 $exit->slaying ($EMERGENCY_POSITION->[0]);
2133 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2134 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2135
2136 $LINK_MAP->insert ($exit->clone, 19, 19);
2137 $LINK_MAP->insert ($exit->clone, 19, 20);
2138 $LINK_MAP->insert ($exit->clone, 19, 21);
2139 $LINK_MAP->insert ($exit->clone, 20, 19);
2140 $LINK_MAP->insert ($exit->clone, 20, 21);
2141 $LINK_MAP->insert ($exit->clone, 21, 19);
2142 $LINK_MAP->insert ($exit->clone, 21, 20);
2143 $LINK_MAP->insert ($exit->clone, 21, 21);
2144
2145 $exit->destroy;
2146 });
2147
2148 $LINK_MAP->{deny_save} = 1;
2149 $LINK_MAP->{deny_reset} = 1;
2150
2151 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2152}
2153
2154register "<global>", __PACKAGE__;
2155 2417
2156register_command "reload" => sub { 2418register_command "reload" => sub {
2157 my ($who, $arg) = @_; 2419 my ($who, $arg) = @_;
2158 2420
2159 if ($who->flag (FLAG_WIZ)) { 2421 if ($who->flag (FLAG_WIZ)) {
2160 $who->message ("start of reload."); 2422 $who->message ("reloading server.");
2423
2424 # doing reload synchronously and two reloads happen back-to-back,
2425 # coro crashes during coro_state_free->destroy here.
2426
2427 $RELOAD_WATCHER ||= Event->timer (after => 0, data => WF_AUTOCANCEL, cb => sub {
2161 reload; 2428 reload;
2162 $who->message ("end of reload."); 2429 undef $RELOAD_WATCHER;
2430 });
2163 } 2431 }
2164}; 2432};
2165 2433
2166unshift @INC, $LIBDIR; 2434unshift @INC, $LIBDIR;
2435
2436my $bug_warning = 0;
2167 2437
2168$TICK_WATCHER = Event->timer ( 2438$TICK_WATCHER = Event->timer (
2169 reentrant => 0, 2439 reentrant => 0,
2440 parked => 1,
2170 prio => 0, 2441 prio => 0,
2171 at => $NEXT_TICK || $TICK, 2442 at => $NEXT_TICK || $TICK,
2172 data => WF_AUTOCANCEL, 2443 data => WF_AUTOCANCEL,
2173 cb => sub { 2444 cb => sub {
2445 if ($Coro::current != $Coro::main) {
2446 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2447 unless ++$bug_warning > 10;
2448 return;
2449 }
2450
2451 $NOW = Event::time;
2452
2174 cf::server_tick; # one server iteration 2453 cf::server_tick; # one server iteration
2175 $RUNTIME += $TICK; 2454 $RUNTIME += $TICK;
2176 $NEXT_TICK += $TICK; 2455 $NEXT_TICK += $TICK;
2456
2457 $WAIT_FOR_TICK->broadcast;
2458 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2177 2459
2178 # if we are delayed by four ticks or more, skip them all 2460 # if we are delayed by four ticks or more, skip them all
2179 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2461 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2180 2462
2181 $TICK_WATCHER->at ($NEXT_TICK); 2463 $TICK_WATCHER->at ($NEXT_TICK);
… …
2183 }, 2465 },
2184); 2466);
2185 2467
2186IO::AIO::max_poll_time $TICK * 0.2; 2468IO::AIO::max_poll_time $TICK * 0.2;
2187 2469
2188Event->io ( 2470$AIO_POLL_WATCHER = Event->io (
2189 fd => IO::AIO::poll_fileno, 2471 fd => IO::AIO::poll_fileno,
2190 poll => 'r', 2472 poll => 'r',
2191 prio => 5, 2473 prio => 5,
2192 data => WF_AUTOCANCEL, 2474 data => WF_AUTOCANCEL,
2193 cb => \&IO::AIO::poll_cb, 2475 cb => \&IO::AIO::poll_cb,
2194); 2476);
2195 2477
2196Event->timer ( 2478$WRITE_RUNTIME_WATCHER = Event->timer (
2197 data => WF_AUTOCANCEL, 2479 data => WF_AUTOCANCEL,
2198 after => 0, 2480 after => 1,
2199 interval => 10, 2481 interval => 10,
2200 cb => sub { 2482 cb => Coro::unblock_sub {
2201 (Coro::unblock_sub {
2202 write_runtime 2483 write_runtime
2203 or warn "ERROR: unable to write runtime file: $!"; 2484 or warn "ERROR: unable to write runtime file: $!";
2204 })->();
2205 }, 2485 },
2206); 2486);
2207 2487
2208END { cf::emergency_save } 2488END { cf::emergency_save }
2209 2489

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines