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.135 by root, Thu Jan 4 20:29:46 2007 UTC vs.
Revision 1.179 by root, Thu Jan 18 20:39:00 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 (2); # 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
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34 35
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
… …
221 # wake up all waiters, to be on the safe side 256 # wake up all waiters, to be on the safe side
222 $_->ready for @{ delete $LOCK{$key} }; 257 $_->ready for @{ delete $LOCK{$key} };
223 } 258 }
224} 259}
225 260
226=item cf::async { BLOCK }
227
228Like C<Coro::async>, but runs the given BLOCK in an eval and only logs the
229error instead of exiting the server in case of a problem.
230
231=cut
232
233sub async(&) {
234 my ($cb) = @_;
235
236 Coro::async {
237 eval { $cb->() };
238 warn $@ if $@;
239 }
240}
241
242sub freeze_mainloop { 261sub freeze_mainloop {
243 return unless $TICK_WATCHER->is_active; 262 return unless $TICK_WATCHER->is_active;
244 263
245 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;
246 $TICK_WATCHER->stop; 269 $TICK_WATCHER->stop;
247 $guard 270 $guard
248} 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 }
249 282
250=item cf::sync_job { BLOCK } 283=item cf::sync_job { BLOCK }
251 284
252The design of crossfire+ requires that the main coro ($Coro::main) is 285The design of crossfire+ requires that the main coro ($Coro::main) is
253always able to handle events or runnable, as crossfire+ is only partly 286always able to handle events or runnable, as crossfire+ is only partly
… …
272 my $freeze_guard = freeze_mainloop; 305 my $freeze_guard = freeze_mainloop;
273 306
274 my $busy = 1; 307 my $busy = 1;
275 my @res; 308 my @res;
276 309
277 (Coro::async { 310 (async {
278 @res = eval { $job->() }; 311 @res = eval { $job->() };
279 warn $@ if $@; 312 warn $@ if $@;
280 undef $busy; 313 undef $busy;
281 })->prio (Coro::PRIO_MAX); 314 })->prio (Coro::PRIO_MAX);
282 315
283 while ($busy) { 316 while ($busy) {
284 Coro::cede_notself; 317 Coro::cede or Event::one_event;
285 Event::one_event unless Coro::nready;
286 } 318 }
287 319
288 wantarray ? @res : $res[0] 320 wantarray ? @res : $res[0]
289 } else { 321 } else {
290 # we are in another coroutine, how wonderful, everything just works 322 # we are in another coroutine, how wonderful, everything just works
291 323
292 $job->() 324 $job->()
293 } 325 }
294} 326}
295 327
296=item $coro = cf::coro { BLOCK } 328=item $coro = cf::async_ext { BLOCK }
297 329
298Creates and returns a new coro. This coro is automcatially being canceled 330Like async, but this coro is automatically being canceled when the
299when the extension calling this is being unloaded. 331extension calling this is being unloaded.
300 332
301=cut 333=cut
302 334
303sub coro(&) { 335sub async_ext(&) {
304 my $cb = shift; 336 my $cb = shift;
305 337
306 my $coro = &cf::async ($cb); 338 my $coro = &Coro::async ($cb);
307 339
308 $coro->on_destroy (sub { 340 $coro->on_destroy (sub {
309 delete $EXT_CORO{$coro+0}; 341 delete $EXT_CORO{$coro+0};
310 }); 342 });
311 $EXT_CORO{$coro+0} = $coro; 343 $EXT_CORO{$coro+0} = $coro;
… …
336} 368}
337 369
338=back 370=back
339 371
340=cut 372=cut
341
342#############################################################################
343
344package cf::path;
345
346sub new {
347 my ($class, $path, $base) = @_;
348
349 $path = $path->as_string if ref $path;
350
351 my $self = bless { }, $class;
352
353 # {... are special paths that are not touched
354 # ?xxx/... are special absolute paths
355 # ?random/... random maps
356 # /! non-realised random map exit
357 # /... normal maps
358 # ~/... per-player maps without a specific player (DO NOT USE)
359 # ~user/... per-player map of a specific user
360
361 if ($path =~ /^{/) {
362 # fine as it is
363 } elsif ($path =~ s{^\?random/}{}) {
364 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
365 $self->{random} = cf::from_json $data;
366 } else {
367 if ($path =~ s{^~([^/]+)?}{}) {
368 $self->{user_rel} = 1;
369
370 if (defined $1) {
371 $self->{user} = $1;
372 } elsif ($base =~ m{^~([^/]+)/}) {
373 $self->{user} = $1;
374 } else {
375 warn "cannot resolve user-relative path without user <$path,$base>\n";
376 }
377 } elsif ($path =~ /^\//) {
378 # already absolute
379 } else {
380 $base =~ s{[^/]+/?$}{};
381 return $class->new ("$base/$path");
382 }
383
384 for ($path) {
385 redo if s{/\.?/}{/};
386 redo if s{/[^/]+/\.\./}{/};
387 }
388 }
389
390 $self->{path} = $path;
391
392 $self
393}
394
395# the name / primary key / in-game path
396sub as_string {
397 my ($self) = @_;
398
399 $self->{user_rel} ? "~$self->{user}$self->{path}"
400 : $self->{random} ? "?random/$self->{path}"
401 : $self->{path}
402}
403
404# the displayed name, this is a one way mapping
405sub visible_name {
406 my ($self) = @_;
407
408# if (my $rmp = $self->{random}) {
409# # todo: be more intelligent about this
410# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
411# } else {
412 $self->as_string
413# }
414}
415
416# escape the /'s in the path
417sub _escaped_path {
418 # ∕ is U+2215
419 (my $path = $_[0]{path}) =~ s/\//∕/g;
420 $path
421}
422
423# the original (read-only) location
424sub load_path {
425 my ($self) = @_;
426
427 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
428}
429
430# the temporary/swap location
431sub save_path {
432 my ($self) = @_;
433
434 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
435 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
436 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
437}
438
439# the unique path, might be eq to save_path
440sub uniq_path {
441 my ($self) = @_;
442
443 $self->{user_rel} || $self->{random}
444 ? undef
445 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
446}
447
448# return random map parameters, or undef
449sub random_map_params {
450 my ($self) = @_;
451
452 $self->{random}
453}
454
455# this is somewhat ugly, but style maps do need special treatment
456sub is_style_map {
457 $_[0]{path} =~ m{^/styles/}
458}
459
460package cf;
461 373
462############################################################################# 374#############################################################################
463 375
464=head2 ATTACHABLE OBJECTS 376=head2 ATTACHABLE OBJECTS
465 377
… …
591our @CB_TYPE = (); # registry for type (cf-object class) based events 503our @CB_TYPE = (); # registry for type (cf-object class) based events
592our @CB_MAP = (); 504our @CB_MAP = ();
593 505
594my %attachment; 506my %attachment;
595 507
508sub cf::attachable::thawer_merge {
509 # simply override everything except _meta
510 local $_[0]{_meta};
511 %{$_[0]} = %{$_[1]};
512}
513
596sub _attach_cb($$$$) { 514sub _attach_cb($$$$) {
597 my ($registry, $event, $prio, $cb) = @_; 515 my ($registry, $event, $prio, $cb) = @_;
598 516
599 use sort 'stable'; 517 use sort 'stable';
600 518
… …
771# object support 689# object support
772 690
773sub reattach { 691sub reattach {
774 # basically do the same as instantiate, without calling instantiate 692 # basically do the same as instantiate, without calling instantiate
775 my ($obj) = @_; 693 my ($obj) = @_;
694
695 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
776 696
777 my $registry = $obj->registry; 697 my $registry = $obj->registry;
778 698
779 @$registry = (); 699 @$registry = ();
780 700
… …
912=cut 832=cut
913 833
914sub register_extcmd { 834sub register_extcmd {
915 my ($name, $cb) = @_; 835 my ($name, $cb) = @_;
916 836
917 my $caller = caller;
918 #warn "registering extcmd '$name' to '$caller'";
919
920 $EXTCMD{$name} = [$cb, $caller]; 837 $EXTCMD{$name} = $cb;
921} 838}
922 839
923cf::player->attach ( 840cf::player->attach (
924 on_command => sub { 841 on_command => sub {
925 my ($pl, $name, $params) = @_; 842 my ($pl, $name, $params) = @_;
… …
938 855
939 my $msg = eval { from_json $buf }; 856 my $msg = eval { from_json $buf };
940 857
941 if (ref $msg) { 858 if (ref $msg) {
942 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 859 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
943 if (my %reply = $cb->[0]->($pl, $msg)) { 860 if (my %reply = $cb->($pl, $msg)) {
944 $pl->ext_reply ($msg->{msgid}, %reply); 861 $pl->ext_reply ($msg->{msgid}, %reply);
945 } 862 }
946 } 863 }
947 } else { 864 } else {
948 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 865 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
950 867
951 cf::override; 868 cf::override;
952 }, 869 },
953); 870);
954 871
955sub register {
956 my ($base, $pkg) = @_;
957
958 #TODO
959}
960
961sub load_extension { 872sub load_extension {
962 my ($path) = @_; 873 my ($path) = @_;
963 874
964 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 875 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
965 my $base = $1; 876 my $base = $1;
966 my $pkg = $1; 877 my $pkg = $1;
967 $pkg =~ s/[^[:word:]]/_/g; 878 $pkg =~ s/[^[:word:]]/_/g;
968 $pkg = "ext::$pkg"; 879 $pkg = "ext::$pkg";
969 880
970 warn "loading '$path' into '$pkg'\n"; 881 warn "... loading '$path' into '$pkg'\n";
971 882
972 open my $fh, "<:utf8", $path 883 open my $fh, "<:utf8", $path
973 or die "$path: $!"; 884 or die "$path: $!";
974 885
975 my $source = 886 my $source =
976 "package $pkg; use strict; use utf8;\n" 887 "package $pkg; use strict; use utf8;\n"
977 . "#line 1 \"$path\"\n{\n" 888 . "#line 1 \"$path\"\n{\n"
978 . (do { local $/; <$fh> }) 889 . (do { local $/; <$fh> })
979 . "\n};\n1"; 890 . "\n};\n1";
980 891
981 eval $source 892 unless (eval $source) {
982 or die $@ ? "$path: $@\n" 893 my $msg = $@ ? "$path: $@\n"
983 : "extension disabled.\n"; 894 : "extension disabled.\n";
984 895 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
985 push @exts, $pkg; 896 warn $@;
986 $ext_pkg{$base} = $pkg; 897 warn "mandatory extension failed to load, exiting.\n";
987 898 exit 1;
988# no strict 'refs'; 899 }
989# @{"$pkg\::ISA"} = ext::; 900 die $@;
990
991 register $base, $pkg;
992}
993
994sub unload_extension {
995 my ($pkg) = @_;
996
997 warn "removing extension $pkg\n";
998
999 # remove hooks
1000 #TODO
1001# for my $idx (0 .. $#PLUGIN_EVENT) {
1002# delete $hook[$idx]{$pkg};
1003# } 901 }
1004 902
1005 # remove commands 903 push @EXTS, $pkg;
1006 for my $name (keys %COMMAND) {
1007 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1008
1009 if (@cb) {
1010 $COMMAND{$name} = \@cb;
1011 } else {
1012 delete $COMMAND{$name};
1013 }
1014 }
1015
1016 # remove extcmds
1017 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1018 delete $EXTCMD{$name};
1019 }
1020
1021 if (my $cb = $pkg->can ("unload")) {
1022 eval {
1023 $cb->($pkg);
1024 1
1025 } or warn "$pkg unloaded, but with errors: $@";
1026 }
1027
1028 Symbol::delete_package $pkg;
1029} 904}
1030 905
1031sub load_extensions { 906sub load_extensions {
1032 for my $ext (<$LIBDIR/*.ext>) { 907 for my $ext (<$LIBDIR/*.ext>) {
1033 next unless -r $ext; 908 next unless -r $ext;
… …
1037 } or warn "$ext not loaded: $@"; 912 } or warn "$ext not loaded: $@";
1038 } 913 }
1039} 914}
1040 915
1041############################################################################# 916#############################################################################
1042# load/save/clean perl data associated with a map
1043
1044*cf::mapsupport::on_clean = sub {
1045 my ($map) = @_;
1046
1047 my $path = $map->tmpname;
1048 defined $path or return;
1049
1050 unlink "$path.pst";
1051};
1052
1053cf::map->attach (prio => -10000, package => cf::mapsupport::);
1054
1055#############################################################################
1056# load/save perl data associated with player->ob objects
1057
1058sub all_objects(@) {
1059 @_, map all_objects ($_->inv), @_
1060}
1061
1062# TODO: compatibility cruft, remove when no longer needed
1063cf::player->attach (
1064 on_load => sub {
1065 my ($pl, $path) = @_;
1066
1067 for my $o (all_objects $pl->ob) {
1068 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1069 $o->set_ob_key_value ("_perl_data");
1070
1071 %$o = %{ Storable::thaw pack "H*", $value };
1072 }
1073 }
1074 },
1075);
1076
1077#############################################################################
1078 917
1079=head2 CORE EXTENSIONS 918=head2 CORE EXTENSIONS
1080 919
1081Functions and methods that extend core crossfire objects. 920Functions and methods that extend core crossfire objects.
1082 921
922=cut
923
924package cf::player;
925
926use Coro::AIO;
927
1083=head3 cf::player 928=head3 cf::player
1084 929
1085=over 4 930=over 4
1086 931
1087=item cf::player::exists $login 932=item cf::player::find $login
1088 933
1089Returns true when the given account exists. 934Returns the given player object, loading it if necessary (might block).
1090 935
1091=cut 936=cut
1092 937
1093sub cf::player::exists($) { 938sub playerdir($) {
1094 cf::player::find $_[0] 939 cf::localdir
1095 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 $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
1096} 1085}
1097 1086
1098=item $player->ext_reply ($msgid, $msgtype, %msg) 1087=item $player->ext_reply ($msgid, $msgtype, %msg)
1099 1088
1100Sends an ext reply to the player. 1089Sends an ext reply to the player.
1101 1090
1102=cut 1091=cut
1103 1092
1104sub cf::player::ext_reply($$$%) { 1093sub ext_reply($$$%) {
1105 my ($self, $id, %msg) = @_; 1094 my ($self, $id, %msg) = @_;
1106 1095
1107 $msg{msgid} = $id; 1096 $msg{msgid} = $id;
1108 1097
1109 $self->send ("ext " . to_json \%msg); 1098 $self->send ("ext " . cf::to_json \%msg);
1110} 1099}
1100
1101package cf;
1111 1102
1112=back 1103=back
1113 1104
1114 1105
1115=head3 cf::map 1106=head3 cf::map
… …
1121package cf::map; 1112package cf::map;
1122 1113
1123use Fcntl; 1114use Fcntl;
1124use Coro::AIO; 1115use Coro::AIO;
1125 1116
1117use overload
1118 '""' => \&as_string,
1119 fallback => 1;
1120
1126our $MAX_RESET = 3600; 1121our $MAX_RESET = 3600;
1127our $DEFAULT_RESET = 3000; 1122our $DEFAULT_RESET = 3000;
1128 1123
1129sub generate_random_map { 1124sub generate_random_map {
1130 my ($path, $rmp) = @_; 1125 my ($self, $rmp) = @_;
1131
1132 # mit "rum" bekleckern, nicht 1126 # mit "rum" bekleckern, nicht
1133 cf::map::_create_random_map 1127 $self->_create_random_map (
1134 $path,
1135 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1128 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1136 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1129 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1137 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1130 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1138 $rmp->{exit_on_final_map}, 1131 $rmp->{exit_on_final_map},
1139 $rmp->{xsize}, $rmp->{ysize}, 1132 $rmp->{xsize}, $rmp->{ysize},
1140 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1133 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1141 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1134 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1142 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1135 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1143 $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},
1144 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1137 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1145 (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
1146} 1257}
1147 1258
1148# and all this just because we cannot iterate over 1259# and all this just because we cannot iterate over
1149# all maps in C++... 1260# all maps in C++...
1150sub change_all_map_light { 1261sub change_all_map_light {
… …
1152 1263
1153 $_->change_map_light ($change) 1264 $_->change_map_light ($change)
1154 for grep $_->outdoor, values %cf::MAP; 1265 for grep $_->outdoor, values %cf::MAP;
1155} 1266}
1156 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
1157sub try_load_header($) { 1276sub load_header_from($) {
1158 my ($path) = @_; 1277 my ($self, $path) = @_;
1159 1278
1160 utf8::encode $path; 1279 utf8::encode $path;
1161 aio_open $path, O_RDONLY, 0 1280 aio_open $path, O_RDONLY, 0
1162 or return; 1281 or return;
1163 1282
1164 my $map = cf::map::new 1283 $self->_load_header ($path)
1165 or return; 1284 or return;
1166 1285
1167 # for better error messages only, will be overwritten 1286 $self->{load_path} = $path;
1168 $map->path ($path);
1169 1287
1170 $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
1171 or return; 1314 or return;
1172 1315
1173 $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 }
1174 1321
1175 $map 1322 1
1176} 1323}
1177 1324
1178sub find; 1325sub find;
1179sub find { 1326sub find {
1180 my ($path, $origin) = @_; 1327 my ($path, $origin) = @_;
1181 1328
1182 #warn "find<$path,$origin>\n";#d#
1183
1184 $path = new cf::path $path, $origin && $origin->path; 1329 $path = normalise $path, $origin && $origin->path;
1185 my $key = $path->as_string;
1186 1330
1187 cf::lock_wait "map_find:$key"; 1331 cf::lock_wait "map_find:$path";
1188 1332
1189 $cf::MAP{$key} || do { 1333 $cf::MAP{$path} || do {
1190 my $guard = cf::lock_acquire "map_find:$key"; 1334 my $guard = cf::lock_acquire "map_find:$path";
1191 1335 my $map = new_from_path cf::map $path
1192 # do it the slow way
1193 my $map = try_load_header $path->save_path;
1194
1195 Coro::cede;
1196
1197 if ($map) {
1198 $map->last_access ((delete $map->{last_access})
1199 || $cf::RUNTIME); #d#
1200 # safety
1201 $map->{instantiate_time} = $cf::RUNTIME
1202 if $map->{instantiate_time} > $cf::RUNTIME;
1203 } else {
1204 if (my $rmp = $path->random_map_params) {
1205 $map = generate_random_map $key, $rmp;
1206 } else {
1207 $map = try_load_header $path->load_path;
1208 }
1209
1210 $map or return; 1336 or return;
1211 1337
1212 $map->{load_original} = 1;
1213 $map->{instantiate_time} = $cf::RUNTIME;
1214 $map->last_access ($cf::RUNTIME);
1215 $map->instantiate;
1216
1217 # per-player maps become, after loading, normal maps
1218 $map->per_player (0) if $path->{user_rel};
1219 }
1220
1221 $map->path ($key);
1222 $map->{path} = $path;
1223 $map->{last_save} = $cf::RUNTIME; 1338 $map->{last_save} = $cf::RUNTIME;
1224 1339
1225 Coro::cede; 1340 $map->load_header
1341 or return;
1226 1342
1227 if ($map->should_reset) { 1343 if ($map->should_reset) {
1344 $cf::WAIT_FOR_TICK->wait;
1228 $map->reset; 1345 $map->reset;
1229 undef $guard; 1346 undef $guard;
1230 $map = find $path 1347 $map = find $path
1231 or return; 1348 or return;
1232 } 1349 }
1233 1350
1234 $cf::MAP{$key} = $map 1351 $cf::MAP{$path} = $map
1235 } 1352 }
1236} 1353}
1237 1354
1238sub load { 1355sub load {
1239 my ($self) = @_; 1356 my ($self) = @_;
1240 1357
1241 my $path = $self->{path}; 1358 my $path = $self->{path};
1242 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1359 my $guard = cf::lock_acquire "map_load:$path";
1243 1360
1244 return if $self->in_memory != cf::MAP_SWAPPED; 1361 return if $self->in_memory != cf::MAP_SWAPPED;
1245 1362
1246 $self->in_memory (cf::MAP_LOADING); 1363 $self->in_memory (cf::MAP_LOADING);
1247 1364
1248 $self->alloc; 1365 $self->alloc;
1249 $self->load_objects ($self->{load_path}, 1) 1366 $self->_load_objects ($self->{load_path}, 1)
1250 or return; 1367 or return;
1251 1368
1252 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1369 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1253 if delete $self->{load_original}; 1370 if delete $self->{load_original};
1254 1371
1255 if (my $uniq = $path->uniq_path) { 1372 if (my $uniq = $self->uniq_path) {
1256 utf8::encode $uniq; 1373 utf8::encode $uniq;
1257 if (aio_open $uniq, O_RDONLY, 0) { 1374 if (aio_open $uniq, O_RDONLY, 0) {
1258 $self->clear_unique_items; 1375 $self->clear_unique_items;
1259 $self->load_objects ($uniq, 0); 1376 $self->_load_objects ($uniq, 0);
1260 } 1377 }
1261 } 1378 }
1262 1379
1263 Coro::cede; 1380 Coro::cede;
1264 1381
1265 # now do the right thing for maps 1382 # now do the right thing for maps
1266 $self->link_multipart_objects; 1383 $self->link_multipart_objects;
1267 1384
1268 if ($self->{path}->is_style_map) { 1385 unless ($self->{deny_activate}) {
1269 $self->{deny_save} = 1; 1386 $self->decay_objects;
1270 $self->{deny_reset} = 1;
1271 } else {
1272 $self->fix_auto_apply; 1387 $self->fix_auto_apply;
1273 $self->decay_objects;
1274 $self->update_buttons; 1388 $self->update_buttons;
1389 Coro::cede;
1275 $self->set_darkness_map; 1390 $self->set_darkness_map;
1276 $self->difficulty ($self->estimate_difficulty) 1391 $self->difficulty ($self->estimate_difficulty)
1277 unless $self->difficulty; 1392 unless $self->difficulty;
1393 Coro::cede;
1278 $self->activate; 1394 $self->activate;
1279 } 1395 }
1280 1396
1281 Coro::cede;
1282
1283 $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 }
1284} 1431}
1285 1432
1286sub find_sync { 1433sub find_sync {
1287 my ($path, $origin) = @_; 1434 my ($path, $origin) = @_;
1288 1435
1289 cf::sync_job { cf::map::find $path, $origin } 1436 cf::sync_job { find $path, $origin }
1290} 1437}
1291 1438
1292sub do_load_sync { 1439sub do_load_sync {
1293 my ($map) = @_; 1440 my ($map) = @_;
1294 1441
1295 cf::sync_job { $map->load }; 1442 cf::sync_job { $map->load };
1296} 1443}
1297 1444
1445our %MAP_PREFETCH;
1446our $MAP_PREFETCHER = Coro::async {
1447 while () {
1448 for my $path (keys %MAP_PREFETCH) {
1449 my $map = find $path
1450 or next;
1451 $map->load;
1452
1453 delete $MAP_PREFETCH{$path};
1454 }
1455 Coro::schedule;
1456 }
1457};
1458
1459sub find_async {
1460 my ($path, $origin) = @_;
1461
1462 $path = normalise $path, $origin && $origin->{path};
1463
1464 if (my $map = $cf::MAP{$path}) {
1465 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1466 }
1467
1468 $MAP_PREFETCH{$path} = 0;
1469 $MAP_PREFETCHER->ready;
1470
1471 ()
1472}
1473
1298sub save { 1474sub save {
1299 my ($self) = @_; 1475 my ($self) = @_;
1300 1476
1477 my $lock = cf::lock_acquire "map_data:" . $self->path;
1478
1301 $self->{last_save} = $cf::RUNTIME; 1479 $self->{last_save} = $cf::RUNTIME;
1302 1480
1303 return unless $self->dirty; 1481 return unless $self->dirty;
1304 1482
1305 my $save = $self->{path}->save_path; utf8::encode $save; 1483 my $save = $self->save_path; utf8::encode $save;
1306 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1484 my $uniq = $self->uniq_path; utf8::encode $uniq;
1307 1485
1308 $self->{load_path} = $save; 1486 $self->{load_path} = $save;
1309 1487
1310 return if $self->{deny_save}; 1488 return if $self->{deny_save};
1311 1489
1312 local $self->{last_access} = $self->last_access;#d# 1490 local $self->{last_access} = $self->last_access;#d#
1313 1491
1492 cf::async {
1493 $_->contr->save for $self->players;
1494 };
1495
1314 if ($uniq) { 1496 if ($uniq) {
1315 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1497 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1316 $self->save_objects ($uniq, cf::IO_UNIQUES); 1498 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1317 } else { 1499 } else {
1318 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 1500 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1319 } 1501 }
1320} 1502}
1321 1503
1322sub swap_out { 1504sub swap_out {
1323 my ($self) = @_; 1505 my ($self) = @_;
1324 1506
1325 # save first because save cedes 1507 # save first because save cedes
1326 $self->save; 1508 $self->save;
1509
1510 my $lock = cf::lock_acquire "map_data:" . $self->path;
1327 1511
1328 return if $self->players; 1512 return if $self->players;
1329 return if $self->in_memory != cf::MAP_IN_MEMORY; 1513 return if $self->in_memory != cf::MAP_IN_MEMORY;
1330 return if $self->{deny_save}; 1514 return if $self->{deny_save};
1331 1515
… …
1335 1519
1336sub reset_at { 1520sub reset_at {
1337 my ($self) = @_; 1521 my ($self) = @_;
1338 1522
1339 # TODO: safety, remove and allow resettable per-player maps 1523 # TODO: safety, remove and allow resettable per-player maps
1340 return 1e99 if $self->{path}{user_rel}; 1524 return 1e99 if $self->isa ("ext::map_per_player");#d#
1341 return 1e99 if $self->{deny_reset}; 1525 return 1e99 if $self->{deny_reset};
1342 1526
1343 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1527 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1344 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1528 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1345 1529
… …
1350 my ($self) = @_; 1534 my ($self) = @_;
1351 1535
1352 $self->reset_at <= $cf::RUNTIME 1536 $self->reset_at <= $cf::RUNTIME
1353} 1537}
1354 1538
1355sub unlink_save {
1356 my ($self) = @_;
1357
1358 utf8::encode (my $save = $self->{path}->save_path);
1359 aioreq_pri 3; IO::AIO::aio_unlink $save;
1360 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1361}
1362
1363sub rename {
1364 my ($self, $new_path) = @_;
1365
1366 $self->unlink_save;
1367
1368 delete $cf::MAP{$self->path};
1369 $self->{path} = new cf::path $new_path;
1370 $self->path ($self->{path}->as_string);
1371 $cf::MAP{$self->path} = $self;
1372
1373 $self->save;
1374}
1375
1376sub reset { 1539sub reset {
1377 my ($self) = @_; 1540 my ($self) = @_;
1378 1541
1542 my $lock = cf::lock_acquire "map_data:$self->{path}";
1543
1379 return if $self->players; 1544 return if $self->players;
1380 return if $self->{path}{user_rel};#d# 1545 return if $self->isa ("ext::map_per_player");#d#
1381 1546
1382 warn "resetting map ", $self->path;#d# 1547 warn "resetting map ", $self->path;#d#
1383 1548
1384 delete $cf::MAP{$self->path}; 1549 delete $cf::MAP{$self->path};
1550
1551 $self->in_memory (cf::MAP_SWAPPED);
1552 $self->clear;
1385 1553
1386 $_->clear_links_to ($self) for values %cf::MAP; 1554 $_->clear_links_to ($self) for values %cf::MAP;
1387 1555
1388 $self->unlink_save; 1556 $self->unlink_save;
1389 $self->destroy; 1557 $self->destroy;
… …
1392my $nuke_counter = "aaaa"; 1560my $nuke_counter = "aaaa";
1393 1561
1394sub nuke { 1562sub nuke {
1395 my ($self) = @_; 1563 my ($self) = @_;
1396 1564
1565 delete $cf::MAP{$self->path};
1566
1567 $self->unlink_save;
1568
1569 bless $self, "cf::map";
1570 delete $self->{deny_reset};
1397 $self->{deny_save} = 1; 1571 $self->{deny_save} = 1;
1398 $self->reset_timeout (1); 1572 $self->reset_timeout (1);
1399 $self->rename ("{nuke}/" . ($nuke_counter++)); 1573 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1574
1575 $cf::MAP{$self->path} = $self;
1576
1400 $self->reset; # polite request, might not happen 1577 $self->reset; # polite request, might not happen
1401} 1578}
1402 1579
1403sub customise_for { 1580=item cf::map::unique_maps
1404 my ($map, $ob) = @_;
1405 1581
1406 if ($map->per_player) { 1582Returns an arrayref of paths of all shared maps that have
1407 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1583instantiated unique items. May block.
1408 }
1409 1584
1410 $map 1585=cut
1411}
1412 1586
1413sub emergency_save { 1587sub unique_maps() {
1414 my $freeze_guard = cf::freeze_mainloop; 1588 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1589 or return;
1415 1590
1416 warn "enter emergency map save\n"; 1591 my @paths;
1417 1592
1418 cf::sync_job { 1593 for (@$files) {
1419 warn "begin emergency map save\n"; 1594 utf8::decode $_;
1420 $_->save for values %cf::MAP; 1595 next if /\.pst$/;
1596 next unless /^$PATH_SEP/o;
1597
1598 s/\.map$//;
1599 push @paths, $_;
1421 }; 1600 }
1422 1601
1423 warn "end emergency map save\n"; 1602 \@paths
1424} 1603}
1425 1604
1426package cf; 1605package cf;
1427 1606
1428=back 1607=back
1429 1608
1609=head3 cf::object
1610
1611=cut
1612
1613package cf::object;
1614
1615=over 4
1616
1617=item $ob->inv_recursive
1618
1619Returns the inventory of the object _and_ their inventories, recursively.
1620
1621=cut
1622
1623sub inv_recursive_;
1624sub inv_recursive_ {
1625 map { $_, inv_recursive_ $_->inv } @_
1626}
1627
1628sub inv_recursive {
1629 inv_recursive_ inv $_[0]
1630}
1631
1632package cf;
1633
1634=back
1430 1635
1431=head3 cf::object::player 1636=head3 cf::object::player
1432 1637
1433=over 4 1638=over 4
1434 1639
… …
1474 1679
1475=item $player_object->enter_link 1680=item $player_object->enter_link
1476 1681
1477Freezes the player and moves him/her to a special map (C<{link}>). 1682Freezes the player and moves him/her to a special map (C<{link}>).
1478 1683
1479The player should be reaosnably safe there for short amounts of time. You 1684The player should be reasonably safe there for short amounts of time. You
1480I<MUST> call C<leave_link> as soon as possible, though. 1685I<MUST> call C<leave_link> as soon as possible, though.
1481 1686
1687Will never block.
1688
1482=item $player_object->leave_link ($map, $x, $y) 1689=item $player_object->leave_link ($map, $x, $y)
1483 1690
1484Moves the player out of the specila link map onto the given map. If the 1691Moves the player out of the special C<{link}> map onto the specified
1485map is not valid (or omitted), the player will be moved back to the 1692map. If the map is not valid (or omitted), the player will be moved back
1486location he/she was before the call to C<enter_link>, or, if that fails, 1693to the location he/she was before the call to C<enter_link>, or, if that
1487to the emergency map position. 1694fails, to the emergency map position.
1488 1695
1489Might block. 1696Might block.
1490 1697
1491=cut 1698=cut
1699
1700sub link_map {
1701 unless ($LINK_MAP) {
1702 $LINK_MAP = cf::map::find "{link}"
1703 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 };
1704 $LINK_MAP->load;
1705 }
1706
1707 $LINK_MAP
1708}
1492 1709
1493sub cf::object::player::enter_link { 1710sub cf::object::player::enter_link {
1494 my ($self) = @_; 1711 my ($self) = @_;
1495 1712
1496 $self->deactivate_recursive; 1713 $self->deactivate_recursive;
1497 1714
1498 return if $self->map == $LINK_MAP; 1715 return if UNIVERSAL::isa $self->map, "ext::map_link";
1499 1716
1500 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 1717 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1501 if $self->map; 1718 if $self->map;
1502 1719
1503 $self->enter_map ($LINK_MAP, 20, 20); 1720 $self->enter_map ($LINK_MAP || link_map, 20, 20);
1504} 1721}
1505 1722
1506sub cf::object::player::leave_link { 1723sub cf::object::player::leave_link {
1507 my ($self, $map, $x, $y) = @_; 1724 my ($self, $map, $x, $y) = @_;
1508 1725
… …
1526 # use -1 or undef as default coordinates, not 0, 0 1743 # use -1 or undef as default coordinates, not 0, 0
1527 ($x, $y) = ($map->enter_x, $map->enter_y) 1744 ($x, $y) = ($map->enter_x, $map->enter_y)
1528 if $x <=0 && $y <= 0; 1745 if $x <=0 && $y <= 0;
1529 1746
1530 $map->load; 1747 $map->load;
1748 $map->load_diag;
1531 1749
1750 return unless $self->contr->active;
1532 $self->activate_recursive; 1751 $self->activate_recursive;
1533 $self->enter_map ($map, $x, $y); 1752 $self->enter_map ($map, $x, $y);
1534} 1753}
1535 1754
1536cf::player->attach ( 1755cf::player->attach (
… …
1549 1768
1550 # try to abort aborted map switching on player login :) 1769 # try to abort aborted map switching on player login :)
1551 # should happen only on crashes 1770 # should happen only on crashes
1552 if ($pl->ob->{_link_pos}) { 1771 if ($pl->ob->{_link_pos}) {
1553 $pl->ob->enter_link; 1772 $pl->ob->enter_link;
1554 cf::async { 1773 (async {
1555 # we need this sleep as the login has a concurrent enter_exit running 1774 # we need this sleep as the login has a concurrent enter_exit running
1556 # and this sleep increases chances of the player not ending up in scorn 1775 # and this sleep increases chances of the player not ending up in scorn
1776 $pl->ob->reply (undef,
1777 "There was an internal problem at your last logout, "
1778 . "the server will try to bring you to your intended destination in a second.",
1779 cf::NDI_RED);
1557 Coro::Timer::sleep 1; 1780 Coro::Timer::sleep 1;
1558 $pl->ob->leave_link; 1781 $pl->ob->leave_link;
1559 }; 1782 })->prio (2);
1560 } 1783 }
1561 }, 1784 },
1562); 1785);
1563 1786
1564=item $player_object->goto_map ($path, $x, $y) 1787=item $player_object->goto ($path, $x, $y)
1565 1788
1566=cut 1789=cut
1567 1790
1568sub cf::object::player::goto_map { 1791sub cf::object::player::goto {
1569 my ($self, $path, $x, $y) = @_; 1792 my ($self, $path, $x, $y) = @_;
1570 1793
1571 $self->enter_link; 1794 $self->enter_link;
1572 1795
1573 (cf::async { 1796 (async {
1574 $path = new cf::path $path;
1575
1576 my $map = cf::map::find $path->as_string; 1797 my $map = cf::map::find $path;
1577 $map = $map->customise_for ($self) if $map; 1798 $map = $map->customise_for ($self) if $map;
1578 1799
1579# warn "entering ", $map->path, " at ($x, $y)\n" 1800# warn "entering ", $map->path, " at ($x, $y)\n"
1580# if $map; 1801# if $map;
1581 1802
1582 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1803 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1583 1804
1584 $self->leave_link ($map, $x, $y); 1805 $self->leave_link ($map, $x, $y);
1585 })->prio (1); 1806 })->prio (1);
1586} 1807}
1587 1808
… …
1591 1812
1592sub parse_random_map_params { 1813sub parse_random_map_params {
1593 my ($spec) = @_; 1814 my ($spec) = @_;
1594 1815
1595 my $rmp = { # defaults 1816 my $rmp = { # defaults
1596 xsize => 10, 1817 xsize => -1,
1597 ysize => 10, 1818 ysize => -1,
1598 }; 1819 };
1599 1820
1600 for (split /\n/, $spec) { 1821 for (split /\n/, $spec) {
1601 my ($k, $v) = split /\s+/, $_, 2; 1822 my ($k, $v) = split /\s+/, $_, 2;
1602 1823
… …
1606 $rmp 1827 $rmp
1607} 1828}
1608 1829
1609sub prepare_random_map { 1830sub prepare_random_map {
1610 my ($exit) = @_; 1831 my ($exit) = @_;
1832
1833 my $guard = cf::lock_acquire "exit_prepare:$exit";
1611 1834
1612 # all this does is basically replace the /! path by 1835 # all this does is basically replace the /! path by
1613 # a new random map path (?random/...) with a seed 1836 # a new random map path (?random/...) with a seed
1614 # that depends on the exit object 1837 # that depends on the exit object
1615 1838
… …
1624 1847
1625 $rmp->{random_seed} ||= $exit->random_seed; 1848 $rmp->{random_seed} ||= $exit->random_seed;
1626 1849
1627 my $data = cf::to_json $rmp; 1850 my $data = cf::to_json $rmp;
1628 my $md5 = Digest::MD5::md5_hex $data; 1851 my $md5 = Digest::MD5::md5_hex $data;
1852 my $meta = "$cf::RANDOM_MAPS/$md5.meta";
1629 1853
1630 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 1854 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1631 aio_write $fh, 0, (length $data), $data, 0; 1855 aio_write $fh, 0, (length $data), $data, 0;
1856 undef $fh;
1857 aio_rename "$meta~", $meta;
1632 1858
1633 $exit->slaying ("?random/$md5"); 1859 $exit->slaying ("?random/$md5");
1634 $exit->msg (undef); 1860 $exit->msg (undef);
1635 } 1861 }
1636} 1862}
… …
1640 1866
1641 return unless $self->type == cf::PLAYER; 1867 return unless $self->type == cf::PLAYER;
1642 1868
1643 $self->enter_link; 1869 $self->enter_link;
1644 1870
1645 (cf::async { 1871 (async {
1646 $self->deactivate_recursive; # just to be sure 1872 $self->deactivate_recursive; # just to be sure
1647 unless (eval { 1873 unless (eval {
1648 prepare_random_map $exit 1874 prepare_random_map $exit
1649 if $exit->slaying eq "/!"; 1875 if $exit->slaying eq "/!";
1650 1876
1651 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path; 1877 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1652 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp); 1878 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1653 1879
1654 1; 1880 1;
1655 }) { 1881 }) {
1656 $self->message ("Something went wrong deep within the crossfire server. " 1882 $self->message ("Something went wrong deep within the crossfire server. "
1657 . "I'll try to bring you back to the map you were before. " 1883 . "I'll try to bring you back to the map you were before. "
1658 . "Please report this to the dungeon master", 1884 . "Please report this to the dungeon master!",
1659 cf::NDI_UNIQUE | cf::NDI_RED); 1885 cf::NDI_UNIQUE | cf::NDI_RED);
1660 1886
1661 warn "ERROR in enter_exit: $@"; 1887 warn "ERROR in enter_exit: $@";
1662 $self->leave_link; 1888 $self->leave_link;
1663 } 1889 }
… …
1731 } 1957 }
1732 } 1958 }
1733 }, 1959 },
1734); 1960);
1735 1961
1736=item $client->coro (\&cb) 1962=item $client->async (\&cb)
1737 1963
1738Create a new coroutine, running the specified callback. The coroutine will 1964Create a new coroutine, running the specified callback. The coroutine will
1739be automatically cancelled when the client gets destroyed (e.g. on logout, 1965be automatically cancelled when the client gets destroyed (e.g. on logout,
1740or loss of connection). 1966or loss of connection).
1741 1967
1742=cut 1968=cut
1743 1969
1744sub cf::client::coro { 1970sub cf::client::async {
1745 my ($self, $cb) = @_; 1971 my ($self, $cb) = @_;
1746 1972
1747 my $coro = &cf::async ($cb); 1973 my $coro = &Coro::async ($cb);
1748 1974
1749 $coro->on_destroy (sub { 1975 $coro->on_destroy (sub {
1750 delete $self->{_coro}{$coro+0}; 1976 delete $self->{_coro}{$coro+0};
1751 }); 1977 });
1752 1978
… …
1990 local $/; 2216 local $/;
1991 *CFG = YAML::Syck::Load <$fh>; 2217 *CFG = YAML::Syck::Load <$fh>;
1992 2218
1993 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 2219 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
1994 2220
2221 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2222 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2223
1995 if (exists $CFG{mlockall}) { 2224 if (exists $CFG{mlockall}) {
1996 eval { 2225 eval {
1997 $CFG{mlockall} ? &mlockall : &munlockall 2226 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
1998 and die "WARNING: m(un)lockall failed: $!\n"; 2227 and die "WARNING: m(un)lockall failed: $!\n";
1999 }; 2228 };
2000 warn $@ if $@; 2229 warn $@ if $@;
2001 } 2230 }
2002} 2231}
2003 2232
2004sub main { 2233sub main {
2005 # we must not ever block the main coroutine 2234 # we must not ever block the main coroutine
2006 local $Coro::idle = sub { 2235 local $Coro::idle = sub {
2007 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2236 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2008 (Coro::unblock_sub { 2237 (async {
2009 Event::one_event; 2238 Event::one_event;
2010 })->(); 2239 })->prio (Coro::PRIO_MAX);
2011 }; 2240 };
2012 2241
2013 cfg_load; 2242 cfg_load;
2014 db_load; 2243 db_load;
2015 load_extensions; 2244 load_extensions;
2016 Event::loop; 2245 Event::loop;
2017} 2246}
2018 2247
2019############################################################################# 2248#############################################################################
2020# initialisation 2249# initialisation and cleanup
2250
2251# install some emergency cleanup handlers
2252BEGIN {
2253 for my $signal (qw(INT HUP TERM)) {
2254 Event->signal (
2255 data => WF_AUTOCANCEL,
2256 signal => $signal,
2257 cb => sub {
2258 cf::cleanup "SIG$signal";
2259 },
2260 );
2261 }
2262}
2263
2264sub emergency_save() {
2265 my $freeze_guard = cf::freeze_mainloop;
2266
2267 warn "enter emergency perl save\n";
2268
2269 cf::sync_job {
2270 # use a peculiar iteration method to avoid tripping on perl
2271 # refcount bugs in for. also avoids problems with players
2272 # and maps saved/destroyed asynchronously.
2273 warn "begin emergency player save\n";
2274 for my $login (keys %cf::PLAYER) {
2275 my $pl = $cf::PLAYER{$login} or next;
2276 $pl->valid or next;
2277 $pl->save;
2278 }
2279 warn "end emergency player save\n";
2280
2281 warn "begin emergency map save\n";
2282 for my $path (keys %cf::MAP) {
2283 my $map = $cf::MAP{$path} or next;
2284 $map->valid or next;
2285 $map->save;
2286 }
2287 warn "end emergency map save\n";
2288 };
2289
2290 warn "leave emergency perl save\n";
2291}
2021 2292
2022sub reload() { 2293sub reload() {
2023 # can/must only be called in main 2294 # can/must only be called in main
2024 if ($Coro::current != $Coro::main) { 2295 if ($Coro::current != $Coro::main) {
2025 warn "can only reload from main coroutine\n"; 2296 warn "can only reload from main coroutine\n";
2026 return; 2297 return;
2027 } 2298 }
2028 2299
2029 warn "reloading..."; 2300 warn "reloading...";
2030 2301
2302 warn "freezing server";
2031 my $guard = freeze_mainloop; 2303 my $guard = freeze_mainloop;
2032 cf::emergency_save; 2304 cf::emergency_save;
2033 2305
2306 warn "sync database to disk";
2307 cf::db_sync;
2308 IO::AIO::flush;
2309
2034 eval { 2310 eval {
2035 # if anything goes wrong in here, we should simply crash as we already saved 2311 # if anything goes wrong in here, we should simply crash as we already saved
2036 2312
2037 # cancel all watchers 2313 warn "cancel all watchers";
2038 for (Event::all_watchers) { 2314 for (Event::all_watchers) {
2039 $_->cancel if $_->data & WF_AUTOCANCEL; 2315 $_->cancel if $_->data & WF_AUTOCANCEL;
2040 } 2316 }
2041 2317
2042 # cancel all extension coros 2318 warn "cancel all extension coros";
2043 $_->cancel for values %EXT_CORO; 2319 $_->cancel for values %EXT_CORO;
2044 %EXT_CORO = (); 2320 %EXT_CORO = ();
2045 2321
2322 warn "remove commands";
2323 %COMMAND = ();
2324
2325 warn "remove ext commands";
2326 %EXTCMD = ();
2327
2046 # unload all extensions 2328 warn "unload/nuke all extensions";
2047 for (@exts) { 2329 for my $pkg (@EXTS) {
2048 warn "unloading <$_>"; 2330 warn "... unloading $pkg";
2049 unload_extension $_; 2331
2332 if (my $cb = $pkg->can ("unload")) {
2333 eval {
2334 $cb->($pkg);
2335 1
2336 } or warn "$pkg unloaded, but with errors: $@";
2050 } 2337 }
2051 2338
2339 warn "... nuking $pkg";
2340 Symbol::delete_package $pkg;
2341 }
2342
2052 # unload all modules loaded from $LIBDIR 2343 warn "unload all perl modules loaded from $LIBDIR";
2053 while (my ($k, $v) = each %INC) { 2344 while (my ($k, $v) = each %INC) {
2054 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2345 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2055 2346
2056 warn "removing <$k>"; 2347 warn "removing <$k>";
2057 delete $INC{$k}; 2348 delete $INC{$k};
… …
2064 } 2355 }
2065 2356
2066 Symbol::delete_package $k; 2357 Symbol::delete_package $k;
2067 } 2358 }
2068 2359
2069 # sync database to disk
2070 cf::db_sync;
2071 IO::AIO::flush;
2072
2073 # get rid of safe::, as good as possible 2360 warn "get rid of safe::, as good as possible";
2074 Symbol::delete_package "safe::$_" 2361 Symbol::delete_package "safe::$_"
2075 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2362 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2076 2363
2077 # remove register_script_function callbacks
2078 # TODO
2079
2080 # unload cf.pm "a bit" 2364 warn "unload cf.pm \"a bit\"";
2081 delete $INC{"cf.pm"}; 2365 delete $INC{"cf.pm"};
2082 2366
2083 # don't, removes xs symbols, too, 2367 # don't, removes xs symbols, too,
2084 # and global variables created in xs 2368 # and global variables created in xs
2085 #Symbol::delete_package __PACKAGE__; 2369 #Symbol::delete_package __PACKAGE__;
2086 2370
2087 # reload cf.pm
2088 warn "reloading cf.pm"; 2371 warn "reloading cf.pm";
2089 require cf; 2372 require cf;
2090 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2373 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2091 2374
2092 # load config and database again 2375 warn "load config and database again";
2093 cf::cfg_load; 2376 cf::cfg_load;
2094 cf::db_load; 2377 cf::db_load;
2095 2378
2096 # load extensions
2097 warn "load extensions"; 2379 warn "load extensions";
2098 cf::load_extensions; 2380 cf::load_extensions;
2099 2381
2100 # reattach attachments to objects 2382 warn "reattach attachments to objects/players";
2101 warn "reattach";
2102 _global_reattach; 2383 _global_reattach;
2384 warn "reattach attachments to maps";
2385 reattach $_ for values %MAP;
2103 }; 2386 };
2104 2387
2105 if ($@) { 2388 if ($@) {
2106 warn $@; 2389 warn $@;
2107 warn "error while reloading, exiting."; 2390 warn "error while reloading, exiting.";
2108 exit 1; 2391 exit 1;
2109 } 2392 }
2110 2393
2111 warn "reloaded successfully"; 2394 warn "reloaded";
2112}; 2395};
2113 2396
2114############################################################################# 2397our $RELOAD_WATCHER; # used only during reload
2115
2116unless ($LINK_MAP) {
2117 $LINK_MAP = cf::map::new;
2118
2119 $LINK_MAP->width (41);
2120 $LINK_MAP->height (41);
2121 $LINK_MAP->alloc;
2122 $LINK_MAP->path ("{link}");
2123 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2124 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2125
2126 # dirty hack because... archetypes are not yet loaded
2127 Event->timer (
2128 after => 2,
2129 cb => sub {
2130 $_[0]->w->cancel;
2131
2132 # provide some exits "home"
2133 my $exit = cf::object::new "exit";
2134
2135 $exit->slaying ($EMERGENCY_POSITION->[0]);
2136 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2137 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2138
2139 $LINK_MAP->insert ($exit->clone, 19, 19);
2140 $LINK_MAP->insert ($exit->clone, 19, 20);
2141 $LINK_MAP->insert ($exit->clone, 19, 21);
2142 $LINK_MAP->insert ($exit->clone, 20, 19);
2143 $LINK_MAP->insert ($exit->clone, 20, 21);
2144 $LINK_MAP->insert ($exit->clone, 21, 19);
2145 $LINK_MAP->insert ($exit->clone, 21, 20);
2146 $LINK_MAP->insert ($exit->clone, 21, 21);
2147
2148 $exit->destroy;
2149 });
2150
2151 $LINK_MAP->{deny_save} = 1;
2152 $LINK_MAP->{deny_reset} = 1;
2153
2154 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2155}
2156
2157register "<global>", __PACKAGE__;
2158 2398
2159register_command "reload" => sub { 2399register_command "reload" => sub {
2160 my ($who, $arg) = @_; 2400 my ($who, $arg) = @_;
2161 2401
2162 if ($who->flag (FLAG_WIZ)) { 2402 if ($who->flag (FLAG_WIZ)) {
2163 $who->message ("start of reload."); 2403 $who->message ("reloading server.");
2404
2405 # doing reload synchronously and two reloads happen back-to-back,
2406 # coro crashes during coro_state_free->destroy here.
2407
2408 $RELOAD_WATCHER ||= Event->timer (after => 0, data => WF_AUTOCANCEL, cb => sub {
2164 reload; 2409 reload;
2165 $who->message ("end of reload."); 2410 undef $RELOAD_WATCHER;
2411 });
2166 } 2412 }
2167}; 2413};
2168 2414
2169unshift @INC, $LIBDIR; 2415unshift @INC, $LIBDIR;
2170 2416
… …
2172 reentrant => 0, 2418 reentrant => 0,
2173 prio => 0, 2419 prio => 0,
2174 at => $NEXT_TICK || $TICK, 2420 at => $NEXT_TICK || $TICK,
2175 data => WF_AUTOCANCEL, 2421 data => WF_AUTOCANCEL,
2176 cb => sub { 2422 cb => sub {
2423 $NOW = Event::time;
2424
2177 cf::server_tick; # one server iteration 2425 cf::server_tick; # one server iteration
2178 $RUNTIME += $TICK; 2426 $RUNTIME += $TICK;
2179 $NEXT_TICK += $TICK; 2427 $NEXT_TICK += $TICK;
2428
2429 $WAIT_FOR_TICK->broadcast;
2430 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2180 2431
2181 # if we are delayed by four ticks or more, skip them all 2432 # if we are delayed by four ticks or more, skip them all
2182 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2433 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2183 2434
2184 $TICK_WATCHER->at ($NEXT_TICK); 2435 $TICK_WATCHER->at ($NEXT_TICK);
… …
2186 }, 2437 },
2187); 2438);
2188 2439
2189IO::AIO::max_poll_time $TICK * 0.2; 2440IO::AIO::max_poll_time $TICK * 0.2;
2190 2441
2191Event->io ( 2442$AIO_POLL_WATCHER = Event->io (
2192 fd => IO::AIO::poll_fileno, 2443 fd => IO::AIO::poll_fileno,
2193 poll => 'r', 2444 poll => 'r',
2194 prio => 5, 2445 prio => 5,
2195 data => WF_AUTOCANCEL, 2446 data => WF_AUTOCANCEL,
2196 cb => \&IO::AIO::poll_cb, 2447 cb => \&IO::AIO::poll_cb,
2197); 2448);
2198 2449
2199Event->timer ( 2450$WRITE_RUNTIME_WATCHER = Event->timer (
2200 data => WF_AUTOCANCEL, 2451 data => WF_AUTOCANCEL,
2201 after => 0, 2452 after => 0,
2202 interval => 10, 2453 interval => 10,
2203 cb => sub { 2454 cb => sub {
2204 (Coro::unblock_sub { 2455 (Coro::unblock_sub {

Diff Legend

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