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.137 by root, Fri Jan 5 10:23:05 2007 UTC vs.
Revision 1.237 by root, Fri Apr 13 05:08:51 2007 UTC

… …
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Storable; 8use Storable;
9use Event;
9use Opcode; 10use Opcode;
10use Safe; 11use Safe;
11use Safe::Hole; 12use Safe::Hole;
12 13
13use Coro 3.3 (); 14use Coro 3.52 ();
15use Coro::State;
14use Coro::Event; 16use Coro::Event;
15use Coro::Timer; 17use Coro::Timer;
16use Coro::Signal; 18use Coro::Signal;
17use Coro::Semaphore; 19use Coro::Semaphore;
18use Coro::AIO; 20use Coro::AIO;
21use Coro::Storable;
19 22
23use BDB ();
24use Data::Dumper;
20use Digest::MD5; 25use Digest::MD5;
21use Fcntl; 26use Fcntl;
22use IO::AIO 2.31 ();
23use YAML::Syck (); 27use YAML::Syck ();
28use IO::AIO 2.32 ();
24use Time::HiRes; 29use Time::HiRes;
30use Compress::LZF;
25 31
32# configure various modules to our taste
33#
34$Storable::canonical = 1; # reduce rsync transfers
35Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
36Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
37
26use Event; $Event::Eval = 1; # no idea why this is required, but it is 38$Event::Eval = 1; # no idea why this is required, but it is
27 39
28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 40# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1; 41$YAML::Syck::ImplicitUnicode = 1;
30 42
31$Coro::main->prio (2); # run main coroutine ("the server") with very high priority 43$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32 44
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 45sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34 46
35our %COMMAND = (); 47our %COMMAND = ();
36our %COMMAND_TIME = (); 48our %COMMAND_TIME = ();
49
50our @EXTS = (); # list of extension package names
37our %EXTCMD = (); 51our %EXTCMD = ();
52our %EXT_CORO = (); # coroutines bound to extensions
53our %EXT_MAP = (); # pluggable maps
38 54
55our $RELOAD; # number of reloads so far
39our @EVENT; 56our @EVENT;
40our $LIBDIR = datadir . "/ext"; 57our $LIBDIR = datadir . "/ext";
41 58
42our $TICK = MAX_TIME * 1e-6; 59our $TICK = MAX_TIME * 1e-6;
43our $TICK_WATCHER; 60our $TICK_WATCHER;
61our $AIO_POLL_WATCHER;
62our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
44our $NEXT_TICK; 63our $NEXT_TICK;
45our $NOW; 64our $NOW;
65our $USE_FSYNC = 1; # use fsync to write maps - default off
66
67our $BDB_POLL_WATCHER;
68our $DB_ENV;
46 69
47our %CFG; 70our %CFG;
48 71
49our $UPTIME; $UPTIME ||= time; 72our $UPTIME; $UPTIME ||= time;
50our $RUNTIME; 73our $RUNTIME;
51 74
75our %PLAYER; # all users
52our %MAP; # all maps 76our %MAP; # all maps
53our $LINK_MAP; # the special {link} map 77our $LINK_MAP; # the special {link} map, which is always available
54our $RANDOM_MAPS = cf::localdir . "/random"; 78our $RANDOM_MAPS = cf::localdir . "/random";
55our %EXT_CORO; 79our $BDB_ENV_DIR = cf::localdir . "/db";
80
81our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
82our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
83
84# used to convert map paths into valid unix filenames by replacing / by ∕
85our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
56 86
57binmode STDOUT; 87binmode STDOUT;
58binmode STDERR; 88binmode STDERR;
59 89
60# read virtual server time, if available 90# read virtual server time, if available
… …
67mkdir cf::localdir; 97mkdir cf::localdir;
68mkdir cf::localdir . "/" . cf::playerdir; 98mkdir cf::localdir . "/" . cf::playerdir;
69mkdir cf::localdir . "/" . cf::tmpdir; 99mkdir cf::localdir . "/" . cf::tmpdir;
70mkdir cf::localdir . "/" . cf::uniquedir; 100mkdir cf::localdir . "/" . cf::uniquedir;
71mkdir $RANDOM_MAPS; 101mkdir $RANDOM_MAPS;
102mkdir $BDB_ENV_DIR;
72 103
73# a special map that is always available
74our $LINK_MAP;
75our $EMERGENCY_POSITION; 104our $EMERGENCY_POSITION;
105
106sub cf::map::normalise;
76 107
77############################################################################# 108#############################################################################
78 109
79=head2 GLOBAL VARIABLES 110=head2 GLOBAL VARIABLES
80 111
… …
104 135
105=item %cf::CFG 136=item %cf::CFG
106 137
107Configuration for the server, loaded from C</etc/crossfire/config>, or 138Configuration for the server, loaded from C</etc/crossfire/config>, or
108from wherever your confdir points to. 139from wherever your confdir points to.
140
141=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
142
143These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
144or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
145processing has been done. Call C<< ->wait >> on them to maximise the
146window of cpu time available, or simply to synchronise to the server tick.
109 147
110=back 148=back
111 149
112=cut 150=cut
113 151
… …
117 utf8::encode $msg; 155 utf8::encode $msg;
118 156
119 $msg .= "\n" 157 $msg .= "\n"
120 unless $msg =~ /\n$/; 158 unless $msg =~ /\n$/;
121 159
122 LOG llevError, "cfperl: $msg"; 160 LOG llevError, $msg;
123 }; 161 };
124} 162}
125 163
126@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 164@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
127@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 165@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
… …
145 183
146$Event::DIED = sub { 184$Event::DIED = sub {
147 warn "error in event callback: @_"; 185 warn "error in event callback: @_";
148}; 186};
149 187
150my %ext_pkg;
151my @exts;
152my @hook;
153
154=head2 UTILITY FUNCTIONS 188=head2 UTILITY FUNCTIONS
155 189
156=over 4 190=over 4
157 191
158=cut 192=item dumpval $ref
159 193
194=cut
195
196sub dumpval {
197 eval {
198 local $SIG{__DIE__};
199 my $d;
200 if (1) {
201 $d = new Data::Dumper([$_[0]], ["*var"]);
202 $d->Terse(1);
203 $d->Indent(2);
204 $d->Quotekeys(0);
205 $d->Useqq(1);
206 #$d->Bless(...);
207 $d->Seen($_[1]) if @_ > 1;
208 $d = $d->Dump();
209 }
210 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
211 $d
212 } || "[unable to dump $_[0]: '$@']";
213}
214
160use JSON::Syck (); # TODO# replace by JSON::PC once working 215use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
161 216
162=item $ref = cf::from_json $json 217=item $ref = cf::from_json $json
163 218
164Converts a JSON string into the corresponding perl data structure. 219Converts a JSON string into the corresponding perl data structure.
165 220
166=cut
167
168sub from_json($) {
169 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
170 JSON::Syck::Load $_[0]
171}
172
173=item $json = cf::to_json $ref 221=item $json = cf::to_json $ref
174 222
175Converts a perl data structure into its JSON representation. 223Converts a perl data structure into its JSON representation.
176
177=cut
178
179sub to_json($) {
180 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
181 JSON::Syck::Dump $_[0]
182}
183 224
184=item cf::lock_wait $string 225=item cf::lock_wait $string
185 226
186Wait until the given lock is available. See cf::lock_acquire. 227Wait until the given lock is available. See cf::lock_acquire.
187 228
… …
221 # wake up all waiters, to be on the safe side 262 # wake up all waiters, to be on the safe side
222 $_->ready for @{ delete $LOCK{$key} }; 263 $_->ready for @{ delete $LOCK{$key} };
223 } 264 }
224} 265}
225 266
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 { 267sub freeze_mainloop {
243 return unless $TICK_WATCHER->is_active; 268 return unless $TICK_WATCHER->is_active;
244 269
245 my $guard = Coro::guard { $TICK_WATCHER->start }; 270 my $guard = Coro::guard {
271 $TICK_WATCHER->start;
272 };
246 $TICK_WATCHER->stop; 273 $TICK_WATCHER->stop;
247 $guard 274 $guard
248} 275}
276
277=item cf::async { BLOCK }
278
279Currently the same as Coro::async_pool, meaning you cannot use
280C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
281thing you are allowed to do is call C<prio> on it.
282
283=cut
284
285BEGIN { *async = \&Coro::async_pool }
249 286
250=item cf::sync_job { BLOCK } 287=item cf::sync_job { BLOCK }
251 288
252The design of crossfire+ requires that the main coro ($Coro::main) is 289The design of crossfire+ requires that the main coro ($Coro::main) is
253always able to handle events or runnable, as crossfire+ is only partly 290always able to handle events or runnable, as crossfire+ is only partly
… …
272 my $freeze_guard = freeze_mainloop; 309 my $freeze_guard = freeze_mainloop;
273 310
274 my $busy = 1; 311 my $busy = 1;
275 my @res; 312 my @res;
276 313
277 (Coro::async { 314 (async {
278 @res = eval { $job->() }; 315 @res = eval { $job->() };
279 warn $@ if $@; 316 warn $@ if $@;
280 undef $busy; 317 undef $busy;
281 })->prio (Coro::PRIO_MAX); 318 })->prio (Coro::PRIO_MAX);
282 319
283 while ($busy) { 320 while ($busy) {
284 Coro::cede_notself; 321 Coro::cede or Event::one_event;
285 Event::one_event unless Coro::nready;
286 } 322 }
287 323
288 wantarray ? @res : $res[0] 324 wantarray ? @res : $res[0]
289 } else { 325 } else {
290 # we are in another coroutine, how wonderful, everything just works 326 # we are in another coroutine, how wonderful, everything just works
291 327
292 $job->() 328 $job->()
293 } 329 }
294} 330}
295 331
296=item $coro = cf::coro { BLOCK } 332=item $coro = cf::async_ext { BLOCK }
297 333
298Creates and returns a new coro. This coro is automcatially being canceled 334Like async, but this coro is automatically being canceled when the
299when the extension calling this is being unloaded. 335extension calling this is being unloaded.
300 336
301=cut 337=cut
302 338
303sub coro(&) { 339sub async_ext(&) {
304 my $cb = shift; 340 my $cb = shift;
305 341
306 my $coro = &cf::async ($cb); 342 my $coro = &Coro::async ($cb);
307 343
308 $coro->on_destroy (sub { 344 $coro->on_destroy (sub {
309 delete $EXT_CORO{$coro+0}; 345 delete $EXT_CORO{$coro+0};
310 }); 346 });
311 $EXT_CORO{$coro+0} = $coro; 347 $EXT_CORO{$coro+0} = $coro;
312 348
313 $coro 349 $coro
314} 350}
315 351
316sub write_runtime { 352sub write_runtime {
353 my $guard = cf::lock_acquire "write_runtime";
354
317 my $runtime = cf::localdir . "/runtime"; 355 my $runtime = cf::localdir . "/runtime";
318 356
319 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 357 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
320 or return; 358 or return;
321 359
360 my $value = $cf::RUNTIME + 90 + 10;
322 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 361 # 10 is the runtime save interval, for a monotonic clock
362 # 60 allows for the watchdog to kill the server.
363
323 (aio_write $fh, 0, (length $value), $value, 0) <= 0 364 (aio_write $fh, 0, (length $value), $value, 0) <= 0
324 and return; 365 and return;
325 366
367 # always fsync - this file is important
326 aio_fsync $fh 368 aio_fsync $fh
327 and return; 369 and return;
328 370
329 close $fh 371 close $fh
330 or return; 372 or return;
… …
333 and return; 375 and return;
334 376
335 1 377 1
336} 378}
337 379
380=item cf::datalog type => key => value, ...
381
382Log a datalog packet of the given type with the given key-value pairs.
383
384=cut
385
386sub datalog($@) {
387 my ($type, %kv) = @_;
388 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
389}
390
338=back 391=back
339 392
340=cut 393=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 394
462############################################################################# 395#############################################################################
463 396
464=head2 ATTACHABLE OBJECTS 397=head2 ATTACHABLE OBJECTS
465 398
… …
591our @CB_TYPE = (); # registry for type (cf-object class) based events 524our @CB_TYPE = (); # registry for type (cf-object class) based events
592our @CB_MAP = (); 525our @CB_MAP = ();
593 526
594my %attachment; 527my %attachment;
595 528
529sub cf::attachable::thawer_merge {
530 # simply override everything except _meta
531 local $_[0]{_meta};
532 %{$_[0]} = %{$_[1]};
533}
534
596sub _attach_cb($$$$) { 535sub _attach_cb($$$$) {
597 my ($registry, $event, $prio, $cb) = @_; 536 my ($registry, $event, $prio, $cb) = @_;
598 537
599 use sort 'stable'; 538 use sort 'stable';
600 539
… …
771# object support 710# object support
772 711
773sub reattach { 712sub reattach {
774 # basically do the same as instantiate, without calling instantiate 713 # basically do the same as instantiate, without calling instantiate
775 my ($obj) = @_; 714 my ($obj) = @_;
715
716 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
776 717
777 my $registry = $obj->registry; 718 my $registry = $obj->registry;
778 719
779 @$registry = (); 720 @$registry = ();
780 721
… …
827 $filename, length $$rdata, scalar @$objs; 768 $filename, length $$rdata, scalar @$objs;
828 769
829 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 770 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
830 chmod SAVE_MODE, $fh; 771 chmod SAVE_MODE, $fh;
831 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 772 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
832 aio_fsync $fh; 773 aio_fsync $fh if $cf::USE_FSYNC;
833 close $fh; 774 close $fh;
834 775
835 if (@$objs) { 776 if (@$objs) {
836 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 777 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
837 chmod SAVE_MODE, $fh; 778 chmod SAVE_MODE, $fh;
838 my $data = Storable::nfreeze { version => 1, objs => $objs }; 779 my $data = Storable::nfreeze { version => 1, objs => $objs };
839 aio_write $fh, 0, (length $data), $data, 0; 780 aio_write $fh, 0, (length $data), $data, 0;
840 aio_fsync $fh; 781 aio_fsync $fh if $cf::USE_FSYNC;
841 close $fh; 782 close $fh;
842 aio_rename "$filename.pst~", "$filename.pst"; 783 aio_rename "$filename.pst~", "$filename.pst";
843 } 784 }
844 } else { 785 } else {
845 aio_unlink "$filename.pst"; 786 aio_unlink "$filename.pst";
… …
912=cut 853=cut
913 854
914sub register_extcmd { 855sub register_extcmd {
915 my ($name, $cb) = @_; 856 my ($name, $cb) = @_;
916 857
917 my $caller = caller;
918 #warn "registering extcmd '$name' to '$caller'";
919
920 $EXTCMD{$name} = [$cb, $caller]; 858 $EXTCMD{$name} = $cb;
921} 859}
922 860
923cf::player->attach ( 861cf::player->attach (
924 on_command => sub { 862 on_command => sub {
925 my ($pl, $name, $params) = @_; 863 my ($pl, $name, $params) = @_;
… …
938 876
939 my $msg = eval { from_json $buf }; 877 my $msg = eval { from_json $buf };
940 878
941 if (ref $msg) { 879 if (ref $msg) {
942 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 880 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
943 if (my %reply = $cb->[0]->($pl, $msg)) { 881 if (my %reply = $cb->($pl, $msg)) {
944 $pl->ext_reply ($msg->{msgid}, %reply); 882 $pl->ext_reply ($msg->{msgid}, %reply);
945 } 883 }
946 } 884 }
947 } else { 885 } else {
948 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 886 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
950 888
951 cf::override; 889 cf::override;
952 }, 890 },
953); 891);
954 892
955sub register {
956 my ($base, $pkg) = @_;
957
958 #TODO
959}
960
961sub load_extension { 893sub load_extension {
962 my ($path) = @_; 894 my ($path) = @_;
963 895
964 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 896 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
965 my $base = $1; 897 my $base = $1;
966 my $pkg = $1; 898 my $pkg = $1;
967 $pkg =~ s/[^[:word:]]/_/g; 899 $pkg =~ s/[^[:word:]]/_/g;
968 $pkg = "ext::$pkg"; 900 $pkg = "ext::$pkg";
969 901
970 warn "loading '$path' into '$pkg'\n"; 902 warn "... loading '$path' into '$pkg'\n";
971 903
972 open my $fh, "<:utf8", $path 904 open my $fh, "<:utf8", $path
973 or die "$path: $!"; 905 or die "$path: $!";
974 906
975 my $source = 907 my $source =
976 "package $pkg; use strict; use utf8;\n" 908 "package $pkg; use strict; use utf8;\n"
977 . "#line 1 \"$path\"\n{\n" 909 . "#line 1 \"$path\"\n{\n"
978 . (do { local $/; <$fh> }) 910 . (do { local $/; <$fh> })
979 . "\n};\n1"; 911 . "\n};\n1";
980 912
981 eval $source 913 unless (eval $source) {
982 or die $@ ? "$path: $@\n" 914 my $msg = $@ ? "$path: $@\n"
983 : "extension disabled.\n"; 915 : "extension disabled.\n";
984 916 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
985 push @exts, $pkg; 917 warn $@;
986 $ext_pkg{$base} = $pkg; 918 warn "mandatory extension failed to load, exiting.\n";
987 919 exit 1;
988# no strict 'refs'; 920 }
989# @{"$pkg\::ISA"} = ext::; 921 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# } 922 }
1004 923
1005 # remove commands 924 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} 925}
1030 926
1031sub load_extensions { 927sub load_extensions {
1032 for my $ext (<$LIBDIR/*.ext>) { 928 for my $ext (<$LIBDIR/*.ext>) {
1033 next unless -r $ext; 929 next unless -r $ext;
… …
1037 } or warn "$ext not loaded: $@"; 933 } or warn "$ext not loaded: $@";
1038 } 934 }
1039} 935}
1040 936
1041############################################################################# 937#############################################################################
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 938
1079=head2 CORE EXTENSIONS 939=head2 CORE EXTENSIONS
1080 940
1081Functions and methods that extend core crossfire objects. 941Functions and methods that extend core crossfire objects.
1082 942
943=cut
944
945package cf::player;
946
947use Coro::AIO;
948
1083=head3 cf::player 949=head3 cf::player
1084 950
1085=over 4 951=over 4
1086 952
1087=item cf::player::exists $login 953=item cf::player::find $login
1088 954
1089Returns true when the given account exists. 955Returns the given player object, loading it if necessary (might block).
1090 956
1091=cut 957=cut
1092 958
1093sub cf::player::exists($) { 959sub playerdir($) {
1094 cf::player::find $_[0] 960 cf::localdir
1095 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 961 . "/"
962 . cf::playerdir
963 . "/"
964 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1096} 965}
1097 966
967sub path($) {
968 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
969
970 (playerdir $login) . "/playerdata"
971}
972
973sub find_active($) {
974 $cf::PLAYER{$_[0]}
975 and $cf::PLAYER{$_[0]}->active
976 and $cf::PLAYER{$_[0]}
977}
978
979sub exists($) {
980 my ($login) = @_;
981
982 $cf::PLAYER{$login}
983 or cf::sync_job { !aio_stat path $login }
984}
985
986sub find($) {
987 return $cf::PLAYER{$_[0]} || do {
988 my $login = $_[0];
989
990 my $guard = cf::lock_acquire "user_find:$login";
991
992 $cf::PLAYER{$_[0]} || do {
993 # rename old playerfiles to new ones
994 #TODO: remove when no longer required
995 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
996 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
997 aio_unlink +(playerdir $login) . "/$login.pl.pst";
998 aio_unlink +(playerdir $login) . "/$login.pl";
999
1000 my $pl = load_pl path $login
1001 or return;
1002 $cf::PLAYER{$login} = $pl
1003 }
1004 }
1005}
1006
1007sub save($) {
1008 my ($pl) = @_;
1009
1010 return if $pl->{deny_save};
1011
1012 my $path = path $pl;
1013 my $guard = cf::lock_acquire "user_save:$path";
1014
1015 return if $pl->{deny_save};
1016
1017 aio_mkdir playerdir $pl, 0770;
1018 $pl->{last_save} = $cf::RUNTIME;
1019
1020 $pl->save_pl ($path);
1021 Coro::cede;
1022}
1023
1024sub new($) {
1025 my ($login) = @_;
1026
1027 my $self = create;
1028
1029 $self->ob->name ($login);
1030 $self->{deny_save} = 1;
1031
1032 $cf::PLAYER{$login} = $self;
1033
1034 $self
1035}
1036
1037=item $pl->quit_character
1038
1039Nukes the player without looking back. If logged in, the connection will
1040be destroyed. May block for a long time.
1041
1042=cut
1043
1044sub quit_character {
1045 my ($pl) = @_;
1046
1047 my $name = $pl->ob->name;
1048
1049 $pl->{deny_save} = 1;
1050 $pl->password ("*"); # this should lock out the player until we nuked the dir
1051
1052 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1053 $pl->deactivate;
1054 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1055 $pl->ns->destroy if $pl->ns;
1056
1057 my $path = playerdir $pl;
1058 my $temp = "$path~$cf::RUNTIME~deleting~";
1059 aio_rename $path, $temp;
1060 delete $cf::PLAYER{$pl->ob->name};
1061 $pl->destroy;
1062
1063 my $prefix = qr<^~\Q$name\E/>;
1064
1065 # nuke player maps
1066 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1067
1068 IO::AIO::aio_rmtree $temp;
1069}
1070
1071=item $pl->kick
1072
1073Kicks a player out of the game. This destroys the connection.
1074
1075=cut
1076
1077sub kick {
1078 my ($pl, $kicker) = @_;
1079
1080 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1081 $pl->killer ("kicked");
1082 $pl->ns->destroy;
1083}
1084
1085=item cf::player::list_logins
1086
1087Returns am arrayref of all valid playernames in the system, can take a
1088while and may block, so not sync_job-capable, ever.
1089
1090=cut
1091
1092sub list_logins {
1093 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1094 or return [];
1095
1096 my @logins;
1097
1098 for my $login (@$dirs) {
1099 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1100 aio_read $fh, 0, 512, my $buf, 0 or next;
1101 $buf !~ /^password -------------$/m or next; # official not-valid tag
1102
1103 utf8::decode $login;
1104 push @logins, $login;
1105 }
1106
1107 \@logins
1108}
1109
1110=item $player->maps
1111
1112Returns an arrayref of map paths that are private for this
1113player. May block.
1114
1115=cut
1116
1117sub maps($) {
1118 my ($pl) = @_;
1119
1120 $pl = ref $pl ? $pl->ob->name : $pl;
1121
1122 my $files = aio_readdir playerdir $pl
1123 or return;
1124
1125 my @paths;
1126
1127 for (@$files) {
1128 utf8::decode $_;
1129 next if /\.(?:pl|pst)$/;
1130 next unless /^$PATH_SEP/o;
1131
1132 push @paths, cf::map::normalise "~$pl/$_";
1133 }
1134
1135 \@paths
1136}
1137
1098=item $player->ext_reply ($msgid, $msgtype, %msg) 1138=item $player->ext_reply ($msgid, %msg)
1099 1139
1100Sends an ext reply to the player. 1140Sends an ext reply to the player.
1101 1141
1102=cut 1142=cut
1103 1143
1104sub cf::player::ext_reply($$$%) { 1144sub ext_reply($$%) {
1105 my ($self, $id, %msg) = @_; 1145 my ($self, $id, %msg) = @_;
1106 1146
1107 $msg{msgid} = $id; 1147 $msg{msgid} = $id;
1108 1148
1109 $self->send ("ext " . to_json \%msg); 1149 $self->send ("ext " . cf::to_json \%msg);
1110} 1150}
1151
1152=item $player->ext_event ($type, %msg)
1153
1154Sends an ext event to the client.
1155
1156=cut
1157
1158sub ext_event($$%) {
1159 my ($self, $type, %msg) = @_;
1160
1161 $self->ns->ext_event ($type, %msg);
1162}
1163
1164package cf;
1111 1165
1112=back 1166=back
1113 1167
1114 1168
1115=head3 cf::map 1169=head3 cf::map
… …
1121package cf::map; 1175package cf::map;
1122 1176
1123use Fcntl; 1177use Fcntl;
1124use Coro::AIO; 1178use Coro::AIO;
1125 1179
1180use overload
1181 '""' => \&as_string,
1182 fallback => 1;
1183
1126our $MAX_RESET = 3600; 1184our $MAX_RESET = 3600;
1127our $DEFAULT_RESET = 3000; 1185our $DEFAULT_RESET = 3000;
1128 1186
1129sub generate_random_map { 1187sub generate_random_map {
1130 my ($path, $rmp) = @_; 1188 my ($self, $rmp) = @_;
1131
1132 # mit "rum" bekleckern, nicht 1189 # mit "rum" bekleckern, nicht
1133 cf::map::_create_random_map 1190 $self->_create_random_map (
1134 $path,
1135 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1191 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1136 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1192 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1137 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1193 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1138 $rmp->{exit_on_final_map}, 1194 $rmp->{exit_on_final_map},
1139 $rmp->{xsize}, $rmp->{ysize}, 1195 $rmp->{xsize}, $rmp->{ysize},
1140 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1196 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1141 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1197 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1142 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1198 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1143 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1199 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1144 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1200 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1145 (cf::region::find $rmp->{region}) 1201 (cf::region::find $rmp->{region}), $rmp->{custom}
1202 )
1203}
1204
1205=item cf::map->register ($regex, $prio)
1206
1207Register a handler for the map path matching the given regex at the
1208givne priority (higher is better, built-in handlers have priority 0, the
1209default).
1210
1211=cut
1212
1213sub register {
1214 my (undef, $regex, $prio) = @_;
1215 my $pkg = caller;
1216
1217 no strict;
1218 push @{"$pkg\::ISA"}, __PACKAGE__;
1219
1220 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1221}
1222
1223# also paths starting with '/'
1224$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1225
1226sub thawer_merge {
1227 my ($self, $merge) = @_;
1228
1229 # we have to keep some variables in memory intact
1230 local $self->{path};
1231 local $self->{load_path};
1232 local $self->{deny_save};
1233 local $self->{deny_reset};
1234
1235 $self->SUPER::thawer_merge ($merge);
1236}
1237
1238sub normalise {
1239 my ($path, $base) = @_;
1240
1241 $path = "$path"; # make sure its a string
1242
1243 $path =~ s/\.map$//;
1244
1245 # map plan:
1246 #
1247 # /! non-realised random map exit (special hack!)
1248 # {... are special paths that are not being touched
1249 # ?xxx/... are special absolute paths
1250 # ?random/... random maps
1251 # /... normal maps
1252 # ~user/... per-player map of a specific user
1253
1254 $path =~ s/$PATH_SEP/\//go;
1255
1256 # treat it as relative path if it starts with
1257 # something that looks reasonable
1258 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1259 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1260
1261 $base =~ s{[^/]+/?$}{};
1262 $path = "$base/$path";
1263 }
1264
1265 for ($path) {
1266 redo if s{//}{/};
1267 redo if s{/\.?/}{/};
1268 redo if s{/[^/]+/\.\./}{/};
1269 }
1270
1271 $path
1272}
1273
1274sub new_from_path {
1275 my (undef, $path, $base) = @_;
1276
1277 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1278
1279 $path = normalise $path, $base;
1280
1281 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1282 if ($path =~ $EXT_MAP{$pkg}[1]) {
1283 my $self = bless cf::map::new, $pkg;
1284 $self->{path} = $path; $self->path ($path);
1285 $self->init; # pass $1 etc.
1286 return $self;
1287 }
1288 }
1289
1290 Carp::carp "unable to resolve path '$path' (base '$base').";
1291 ()
1292}
1293
1294sub init {
1295 my ($self) = @_;
1296
1297 $self
1298}
1299
1300sub as_string {
1301 my ($self) = @_;
1302
1303 "$self->{path}"
1304}
1305
1306# the displayed name, this is a one way mapping
1307sub visible_name {
1308 &as_string
1309}
1310
1311# the original (read-only) location
1312sub load_path {
1313 my ($self) = @_;
1314
1315 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path}
1316}
1317
1318# the temporary/swap location
1319sub save_path {
1320 my ($self) = @_;
1321
1322 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1323 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path
1324}
1325
1326# the unique path, undef == no special unique path
1327sub uniq_path {
1328 my ($self) = @_;
1329
1330 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1331 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path
1146} 1332}
1147 1333
1148# and all this just because we cannot iterate over 1334# and all this just because we cannot iterate over
1149# all maps in C++... 1335# all maps in C++...
1150sub change_all_map_light { 1336sub change_all_map_light {
… …
1152 1338
1153 $_->change_map_light ($change) 1339 $_->change_map_light ($change)
1154 for grep $_->outdoor, values %cf::MAP; 1340 for grep $_->outdoor, values %cf::MAP;
1155} 1341}
1156 1342
1343sub unlink_save {
1344 my ($self) = @_;
1345
1346 utf8::encode (my $save = $self->save_path);
1347 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1348 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1349}
1350
1157sub try_load_header($) { 1351sub load_header_from($) {
1158 my ($path) = @_; 1352 my ($self, $path) = @_;
1159 1353
1160 utf8::encode $path; 1354 utf8::encode $path;
1161 aio_open $path, O_RDONLY, 0 1355 #aio_open $path, O_RDONLY, 0
1356 # or return;
1357
1358 $self->_load_header ($path)
1162 or return; 1359 or return;
1163 1360
1164 my $map = cf::map::new 1361 $self->{load_path} = $path;
1362
1363 1
1364}
1365
1366sub load_header_orig {
1367 my ($self) = @_;
1368
1369 $self->load_header_from ($self->load_path)
1370}
1371
1372sub load_header_temp {
1373 my ($self) = @_;
1374
1375 $self->load_header_from ($self->save_path)
1376}
1377
1378sub prepare_temp {
1379 my ($self) = @_;
1380
1381 $self->last_access ((delete $self->{last_access})
1382 || $cf::RUNTIME); #d#
1383 # safety
1384 $self->{instantiate_time} = $cf::RUNTIME
1385 if $self->{instantiate_time} > $cf::RUNTIME;
1386}
1387
1388sub prepare_orig {
1389 my ($self) = @_;
1390
1391 $self->{load_original} = 1;
1392 $self->{instantiate_time} = $cf::RUNTIME;
1393 $self->last_access ($cf::RUNTIME);
1394 $self->instantiate;
1395}
1396
1397sub load_header {
1398 my ($self) = @_;
1399
1400 if ($self->load_header_temp) {
1401 $self->prepare_temp;
1402 } else {
1403 $self->load_header_orig
1165 or return; 1404 or return;
1405 $self->prepare_orig;
1406 }
1166 1407
1167 # for better error messages only, will be overwritten 1408 1
1168 $map->path ($path);
1169
1170 $map->load_header ($path)
1171 or return;
1172
1173 $map->{load_path} = $path;
1174
1175 $map
1176} 1409}
1177 1410
1178sub find; 1411sub find;
1179sub find { 1412sub find {
1180 my ($path, $origin) = @_; 1413 my ($path, $origin) = @_;
1181 1414
1182 #warn "find<$path,$origin>\n";#d#
1183
1184 $path = new cf::path $path, $origin && $origin->path; 1415 $path = normalise $path, $origin && $origin->path;
1185 my $key = $path->as_string;
1186 1416
1187 cf::lock_wait "map_find:$key"; 1417 cf::lock_wait "map_find:$path";
1188 1418
1189 $cf::MAP{$key} || do { 1419 $cf::MAP{$path} || do {
1190 my $guard = cf::lock_acquire "map_find:$key"; 1420 my $guard = cf::lock_acquire "map_find:$path";
1191 1421 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; 1422 or return;
1211 1423
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; 1424 $map->{last_save} = $cf::RUNTIME;
1224 1425
1225 Coro::cede; 1426 $map->load_header
1427 or return;
1226 1428
1227 if ($map->should_reset) { 1429 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?)
1430 # doing this can freeze the server in a sync job, obviously
1431 #$cf::WAIT_FOR_TICK->wait;
1228 $map->reset; 1432 $map->reset;
1229 undef $guard; 1433 undef $guard;
1230 $map = find $path 1434 return find $path;
1231 or return;
1232 } 1435 }
1233 1436
1234 $cf::MAP{$key} = $map 1437 $cf::MAP{$path} = $map
1235 } 1438 }
1236} 1439}
1440
1441sub pre_load { }
1442sub post_load { }
1237 1443
1238sub load { 1444sub load {
1239 my ($self) = @_; 1445 my ($self) = @_;
1240 1446
1447 local $self->{deny_reset} = 1; # loading can take a long time
1448
1241 my $path = $self->{path}; 1449 my $path = $self->{path};
1242 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1450 my $guard = cf::lock_acquire "map_load:$path";
1243 1451
1244 return if $self->in_memory != cf::MAP_SWAPPED; 1452 return if $self->in_memory != cf::MAP_SWAPPED;
1245 1453
1246 $self->in_memory (cf::MAP_LOADING); 1454 $self->in_memory (cf::MAP_LOADING);
1247 1455
1248 $self->alloc; 1456 $self->alloc;
1457
1458 $self->pre_load;
1459
1249 $self->load_objects ($self->{load_path}, 1) 1460 $self->_load_objects ($self->{load_path}, 1)
1250 or return; 1461 or return;
1251 1462
1252 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1463 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1253 if delete $self->{load_original}; 1464 if delete $self->{load_original};
1254 1465
1255 if (my $uniq = $path->uniq_path) { 1466 if (my $uniq = $self->uniq_path) {
1256 utf8::encode $uniq; 1467 utf8::encode $uniq;
1257 if (aio_open $uniq, O_RDONLY, 0) { 1468 if (aio_open $uniq, O_RDONLY, 0) {
1258 $self->clear_unique_items; 1469 $self->clear_unique_items;
1259 $self->load_objects ($uniq, 0); 1470 $self->_load_objects ($uniq, 0);
1260 } 1471 }
1261 } 1472 }
1262 1473
1263 Coro::cede; 1474 Coro::cede;
1264 1475
1265 # now do the right thing for maps 1476 # now do the right thing for maps
1266 $self->link_multipart_objects; 1477 $self->link_multipart_objects;
1267 1478
1268 if ($self->{path}->is_style_map) { 1479 unless ($self->{deny_activate}) {
1269 $self->{deny_save} = 1; 1480 $self->decay_objects;
1270 $self->{deny_reset} = 1;
1271 } else {
1272 $self->fix_auto_apply; 1481 $self->fix_auto_apply;
1273 $self->decay_objects;
1274 $self->update_buttons; 1482 $self->update_buttons;
1483 Coro::cede;
1275 $self->set_darkness_map; 1484 $self->set_darkness_map;
1276 $self->difficulty ($self->estimate_difficulty) 1485 $self->difficulty ($self->estimate_difficulty)
1277 unless $self->difficulty; 1486 unless $self->difficulty;
1487 Coro::cede;
1278 $self->activate; 1488 $self->activate;
1279 } 1489 }
1280 1490
1281 Coro::cede; 1491 $self->post_load;
1282 1492
1283 $self->in_memory (cf::MAP_IN_MEMORY); 1493 $self->in_memory (cf::MAP_IN_MEMORY);
1494}
1495
1496sub customise_for {
1497 my ($self, $ob) = @_;
1498
1499 return find "~" . $ob->name . "/" . $self->{path}
1500 if $self->per_player;
1501
1502 $self
1503}
1504
1505# find and load all maps in the 3x3 area around a map
1506sub load_diag {
1507 my ($map) = @_;
1508
1509 my @diag; # diagonal neighbours
1510
1511 for (0 .. 3) {
1512 my $neigh = $map->tile_path ($_)
1513 or next;
1514 $neigh = find $neigh, $map
1515 or next;
1516 $neigh->load;
1517
1518 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1519 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1520 }
1521
1522 for (@diag) {
1523 my $neigh = find @$_
1524 or next;
1525 $neigh->load;
1526 }
1284} 1527}
1285 1528
1286sub find_sync { 1529sub find_sync {
1287 my ($path, $origin) = @_; 1530 my ($path, $origin) = @_;
1288 1531
1289 cf::sync_job { cf::map::find $path, $origin } 1532 cf::sync_job { find $path, $origin }
1290} 1533}
1291 1534
1292sub do_load_sync { 1535sub do_load_sync {
1293 my ($map) = @_; 1536 my ($map) = @_;
1294 1537
1295 cf::sync_job { $map->load }; 1538 cf::sync_job { $map->load };
1296} 1539}
1297 1540
1541our %MAP_PREFETCH;
1542our $MAP_PREFETCHER = undef;
1543
1544sub find_async {
1545 my ($path, $origin) = @_;
1546
1547 $path = normalise $path, $origin && $origin->{path};
1548
1549 if (my $map = $cf::MAP{$path}) {
1550 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1551 }
1552
1553 undef $MAP_PREFETCH{$path};
1554 $MAP_PREFETCHER ||= cf::async {
1555 while (%MAP_PREFETCH) {
1556 for my $path (keys %MAP_PREFETCH) {
1557 my $map = find $path
1558 or next;
1559 $map->load;
1560
1561 delete $MAP_PREFETCH{$path};
1562 }
1563 }
1564 undef $MAP_PREFETCHER;
1565 };
1566 $MAP_PREFETCHER->prio (6);
1567
1568 ()
1569}
1570
1298sub save { 1571sub save {
1299 my ($self) = @_; 1572 my ($self) = @_;
1300 1573
1301 my $lock = cf::lock_acquire "map_data:" . $self->path; 1574 my $lock = cf::lock_acquire "map_data:" . $self->path;
1302 1575
1303 $self->{last_save} = $cf::RUNTIME; 1576 $self->{last_save} = $cf::RUNTIME;
1304 1577
1305 return unless $self->dirty; 1578 return unless $self->dirty;
1306 1579
1307 my $save = $self->{path}->save_path; utf8::encode $save; 1580 my $save = $self->save_path; utf8::encode $save;
1308 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1581 my $uniq = $self->uniq_path; utf8::encode $uniq;
1309 1582
1310 $self->{load_path} = $save; 1583 $self->{load_path} = $save;
1311 1584
1312 return if $self->{deny_save}; 1585 return if $self->{deny_save};
1313 1586
1314 local $self->{last_access} = $self->last_access;#d# 1587 local $self->{last_access} = $self->last_access;#d#
1315 1588
1589 cf::async {
1590 $_->contr->save for $self->players;
1591 };
1592
1316 if ($uniq) { 1593 if ($uniq) {
1317 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1594 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1318 $self->save_objects ($uniq, cf::IO_UNIQUES); 1595 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1319 } else { 1596 } else {
1320 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 1597 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1321 } 1598 }
1322} 1599}
1323 1600
1324sub swap_out { 1601sub swap_out {
1325 my ($self) = @_; 1602 my ($self) = @_;
… …
1339 1616
1340sub reset_at { 1617sub reset_at {
1341 my ($self) = @_; 1618 my ($self) = @_;
1342 1619
1343 # TODO: safety, remove and allow resettable per-player maps 1620 # TODO: safety, remove and allow resettable per-player maps
1344 return 1e99 if $self->{path}{user_rel}; 1621 return 1e99 if $self->isa ("ext::map_per_player");#d#
1345 return 1e99 if $self->{deny_reset}; 1622 return 1e99 if $self->{deny_reset};
1346 1623
1347 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1624 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1348 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1625 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1349 1626
… …
1354 my ($self) = @_; 1631 my ($self) = @_;
1355 1632
1356 $self->reset_at <= $cf::RUNTIME 1633 $self->reset_at <= $cf::RUNTIME
1357} 1634}
1358 1635
1359sub unlink_save {
1360 my ($self) = @_;
1361
1362 utf8::encode (my $save = $self->{path}->save_path);
1363 aioreq_pri 3; IO::AIO::aio_unlink $save;
1364 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1365}
1366
1367sub rename {
1368 my ($self, $new_path) = @_;
1369
1370 $self->unlink_save;
1371
1372 delete $cf::MAP{$self->path};
1373 $self->{path} = new cf::path $new_path;
1374 $self->path ($self->{path}->as_string);
1375 $cf::MAP{$self->path} = $self;
1376
1377 $self->save;
1378}
1379
1380sub reset { 1636sub reset {
1381 my ($self) = @_; 1637 my ($self) = @_;
1382 1638
1383 my $lock = cf::lock_acquire "map_data:" . $self->path; 1639 my $lock = cf::lock_acquire "map_data:$self->{path}";
1384 1640
1385 return if $self->players; 1641 return if $self->players;
1386 return if $self->{path}{user_rel};#d# 1642 return if $self->isa ("ext::map_per_player");#d#
1387 1643
1388 warn "resetting map ", $self->path;#d# 1644 warn "resetting map ", $self->path;#d#
1389 1645
1646 $self->in_memory (cf::MAP_SWAPPED);
1647
1648 # need to save uniques path
1649 unless ($self->{deny_save}) {
1650 my $uniq = $self->uniq_path; utf8::encode $uniq;
1651
1652 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1653 if $uniq;
1654 }
1655
1390 delete $cf::MAP{$self->path}; 1656 delete $cf::MAP{$self->path};
1657
1658 $self->clear;
1391 1659
1392 $_->clear_links_to ($self) for values %cf::MAP; 1660 $_->clear_links_to ($self) for values %cf::MAP;
1393 1661
1394 $self->unlink_save; 1662 $self->unlink_save;
1395 $self->destroy; 1663 $self->destroy;
… …
1398my $nuke_counter = "aaaa"; 1666my $nuke_counter = "aaaa";
1399 1667
1400sub nuke { 1668sub nuke {
1401 my ($self) = @_; 1669 my ($self) = @_;
1402 1670
1671 delete $cf::MAP{$self->path};
1672
1673 $self->unlink_save;
1674
1675 bless $self, "cf::map";
1676 delete $self->{deny_reset};
1403 $self->{deny_save} = 1; 1677 $self->{deny_save} = 1;
1404 $self->reset_timeout (1); 1678 $self->reset_timeout (1);
1405 $self->rename ("{nuke}/" . ($nuke_counter++)); 1679 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1680
1681 $cf::MAP{$self->path} = $self;
1682
1406 $self->reset; # polite request, might not happen 1683 $self->reset; # polite request, might not happen
1407} 1684}
1408 1685
1409sub customise_for { 1686=item cf::map::unique_maps
1410 my ($map, $ob) = @_;
1411 1687
1412 if ($map->per_player) { 1688Returns an arrayref of paths of all shared maps that have
1413 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1689instantiated unique items. May block.
1414 }
1415 1690
1416 $map 1691=cut
1417}
1418 1692
1419sub emergency_save { 1693sub unique_maps() {
1420 my $freeze_guard = cf::freeze_mainloop; 1694 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1695 or return;
1421 1696
1422 warn "enter emergency map save\n"; 1697 my @paths;
1423 1698
1424 cf::sync_job { 1699 for (@$files) {
1425 warn "begin emergency map save\n"; 1700 utf8::decode $_;
1426 $_->save for values %cf::MAP; 1701 next if /\.pst$/;
1702 next unless /^$PATH_SEP/o;
1703
1704 push @paths, cf::map::normalise $_;
1427 }; 1705 }
1428 1706
1429 warn "end emergency map save\n"; 1707 \@paths
1430} 1708}
1431 1709
1432package cf; 1710package cf;
1433 1711
1434=back 1712=back
1435 1713
1714=head3 cf::object
1715
1716=cut
1717
1718package cf::object;
1719
1720=over 4
1721
1722=item $ob->inv_recursive
1723
1724Returns the inventory of the object _and_ their inventories, recursively.
1725
1726=cut
1727
1728sub inv_recursive_;
1729sub inv_recursive_ {
1730 map { $_, inv_recursive_ $_->inv } @_
1731}
1732
1733sub inv_recursive {
1734 inv_recursive_ inv $_[0]
1735}
1736
1737package cf;
1738
1739=back
1436 1740
1437=head3 cf::object::player 1741=head3 cf::object::player
1438 1742
1439=over 4 1743=over 4
1440 1744
… …
1480 1784
1481=item $player_object->enter_link 1785=item $player_object->enter_link
1482 1786
1483Freezes the player and moves him/her to a special map (C<{link}>). 1787Freezes the player and moves him/her to a special map (C<{link}>).
1484 1788
1485The player should be reaosnably safe there for short amounts of time. You 1789The player should be reasonably safe there for short amounts of time. You
1486I<MUST> call C<leave_link> as soon as possible, though. 1790I<MUST> call C<leave_link> as soon as possible, though.
1487 1791
1792Will never block.
1793
1488=item $player_object->leave_link ($map, $x, $y) 1794=item $player_object->leave_link ($map, $x, $y)
1489 1795
1490Moves the player out of the specila link map onto the given map. If the 1796Moves the player out of the special C<{link}> map onto the specified
1491map is not valid (or omitted), the player will be moved back to the 1797map. If the map is not valid (or omitted), the player will be moved back
1492location he/she was before the call to C<enter_link>, or, if that fails, 1798to the location he/she was before the call to C<enter_link>, or, if that
1493to the emergency map position. 1799fails, to the emergency map position.
1494 1800
1495Might block. 1801Might block.
1496 1802
1497=cut 1803=cut
1804
1805sub link_map {
1806 unless ($LINK_MAP) {
1807 $LINK_MAP = cf::map::find "{link}"
1808 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1809 $LINK_MAP->load;
1810 }
1811
1812 $LINK_MAP
1813}
1498 1814
1499sub cf::object::player::enter_link { 1815sub cf::object::player::enter_link {
1500 my ($self) = @_; 1816 my ($self) = @_;
1501 1817
1502 $self->deactivate_recursive; 1818 $self->deactivate_recursive;
1503 1819
1504 return if $self->map == $LINK_MAP; 1820 return if UNIVERSAL::isa $self->map, "ext::map_link";
1505 1821
1506 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 1822 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1507 if $self->map; 1823 if $self->map;
1508 1824
1509 $self->enter_map ($LINK_MAP, 20, 20); 1825 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1510} 1826}
1511 1827
1512sub cf::object::player::leave_link { 1828sub cf::object::player::leave_link {
1513 my ($self, $map, $x, $y) = @_; 1829 my ($self, $map, $x, $y) = @_;
1514 1830
… …
1532 # use -1 or undef as default coordinates, not 0, 0 1848 # use -1 or undef as default coordinates, not 0, 0
1533 ($x, $y) = ($map->enter_x, $map->enter_y) 1849 ($x, $y) = ($map->enter_x, $map->enter_y)
1534 if $x <=0 && $y <= 0; 1850 if $x <=0 && $y <= 0;
1535 1851
1536 $map->load; 1852 $map->load;
1853 $map->load_diag;
1537 1854
1855 return unless $self->contr->active;
1538 $self->activate_recursive; 1856 $self->activate_recursive;
1857
1858 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1539 $self->enter_map ($map, $x, $y); 1859 $self->enter_map ($map, $x, $y);
1540} 1860}
1541 1861
1542cf::player->attach ( 1862cf::player->attach (
1543 on_logout => sub { 1863 on_logout => sub {
… …
1555 1875
1556 # try to abort aborted map switching on player login :) 1876 # try to abort aborted map switching on player login :)
1557 # should happen only on crashes 1877 # should happen only on crashes
1558 if ($pl->ob->{_link_pos}) { 1878 if ($pl->ob->{_link_pos}) {
1559 $pl->ob->enter_link; 1879 $pl->ob->enter_link;
1560 cf::async { 1880 (async {
1881 $pl->ob->reply (undef,
1882 "There was an internal problem at your last logout, "
1883 . "the server will try to bring you to your intended destination in a second.",
1884 cf::NDI_RED);
1561 # we need this sleep as the login has a concurrent enter_exit running 1885 # we need this sleep as the login has a concurrent enter_exit running
1562 # and this sleep increases chances of the player not ending up in scorn 1886 # and this sleep increases chances of the player not ending up in scorn
1563 Coro::Timer::sleep 1; 1887 Coro::Timer::sleep 1;
1564 $pl->ob->leave_link; 1888 $pl->ob->leave_link;
1565 }; 1889 })->prio (2);
1566 } 1890 }
1567 }, 1891 },
1568); 1892);
1569 1893
1570=item $player_object->goto ($path, $x, $y) 1894=item $player_object->goto ($path, $x, $y)
… …
1574sub cf::object::player::goto { 1898sub cf::object::player::goto {
1575 my ($self, $path, $x, $y) = @_; 1899 my ($self, $path, $x, $y) = @_;
1576 1900
1577 $self->enter_link; 1901 $self->enter_link;
1578 1902
1579 (cf::async { 1903 (async {
1580 $path = new cf::path $path; 1904 my $map = eval {
1581
1582 my $map = cf::map::find $path->as_string; 1905 my $map = cf::map::find $path;
1583 $map = $map->customise_for ($self) if $map; 1906 $map = $map->customise_for ($self) if $map;
1584 1907 $map
1585# warn "entering ", $map->path, " at ($x, $y)\n" 1908 } or
1586# if $map;
1587
1588 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1909 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1589 1910
1590 $self->leave_link ($map, $x, $y); 1911 $self->leave_link ($map, $x, $y);
1591 })->prio (1); 1912 })->prio (1);
1592} 1913}
1593 1914
… …
1597 1918
1598sub parse_random_map_params { 1919sub parse_random_map_params {
1599 my ($spec) = @_; 1920 my ($spec) = @_;
1600 1921
1601 my $rmp = { # defaults 1922 my $rmp = { # defaults
1602 xsize => 10, 1923 xsize => (cf::rndm 15, 40),
1603 ysize => 10, 1924 ysize => (cf::rndm 15, 40),
1925 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
1926 #layout => string,
1604 }; 1927 };
1605 1928
1606 for (split /\n/, $spec) { 1929 for (split /\n/, $spec) {
1607 my ($k, $v) = split /\s+/, $_, 2; 1930 my ($k, $v) = split /\s+/, $_, 2;
1608 1931
… …
1612 $rmp 1935 $rmp
1613} 1936}
1614 1937
1615sub prepare_random_map { 1938sub prepare_random_map {
1616 my ($exit) = @_; 1939 my ($exit) = @_;
1940
1941 my $guard = cf::lock_acquire "exit_prepare:$exit";
1617 1942
1618 # all this does is basically replace the /! path by 1943 # all this does is basically replace the /! path by
1619 # a new random map path (?random/...) with a seed 1944 # a new random map path (?random/...) with a seed
1620 # that depends on the exit object 1945 # that depends on the exit object
1621 1946
1622 my $rmp = parse_random_map_params $exit->msg; 1947 my $rmp = parse_random_map_params $exit->msg;
1623 1948
1624 if ($exit->map) { 1949 if ($exit->map) {
1625 $rmp->{region} = $exit->map->region_name; 1950 $rmp->{region} = $exit->region->name;
1626 $rmp->{origin_map} = $exit->map->path; 1951 $rmp->{origin_map} = $exit->map->path;
1627 $rmp->{origin_x} = $exit->x; 1952 $rmp->{origin_x} = $exit->x;
1628 $rmp->{origin_y} = $exit->y; 1953 $rmp->{origin_y} = $exit->y;
1629 } 1954 }
1630 1955
1631 $rmp->{random_seed} ||= $exit->random_seed; 1956 $rmp->{random_seed} ||= $exit->random_seed;
1632 1957
1633 my $data = cf::to_json $rmp; 1958 my $data = cf::to_json $rmp;
1634 my $md5 = Digest::MD5::md5_hex $data; 1959 my $md5 = Digest::MD5::md5_hex $data;
1960 my $meta = "$cf::RANDOM_MAPS/$md5.meta";
1635 1961
1636 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 1962 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1637 aio_write $fh, 0, (length $data), $data, 0; 1963 aio_write $fh, 0, (length $data), $data, 0;
1964 undef $fh;
1965 aio_rename "$meta~", $meta;
1638 1966
1639 $exit->slaying ("?random/$md5"); 1967 $exit->slaying ("?random/$md5");
1640 $exit->msg (undef); 1968 $exit->msg (undef);
1641 } 1969 }
1642} 1970}
… …
1644sub cf::object::player::enter_exit { 1972sub cf::object::player::enter_exit {
1645 my ($self, $exit) = @_; 1973 my ($self, $exit) = @_;
1646 1974
1647 return unless $self->type == cf::PLAYER; 1975 return unless $self->type == cf::PLAYER;
1648 1976
1977 if ($exit->slaying eq "/!") {
1978 #TODO: this should de-fi-ni-te-ly not be a sync-job
1979 # the problem is that $exit might not survive long enough
1980 # so it needs to be done right now, right here
1981 cf::sync_job { prepare_random_map $exit };
1982 }
1983
1984 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1985 my $hp = $exit->stats->hp;
1986 my $sp = $exit->stats->sp;
1987
1649 $self->enter_link; 1988 $self->enter_link;
1650 1989
1651 (cf::async { 1990 (async {
1652 $self->deactivate_recursive; # just to be sure 1991 $self->deactivate_recursive; # just to be sure
1653 unless (eval { 1992 unless (eval {
1654 prepare_random_map $exit 1993 $self->goto ($slaying, $hp, $sp);
1655 if $exit->slaying eq "/!";
1656
1657 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1658 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1659 1994
1660 1; 1995 1;
1661 }) { 1996 }) {
1662 $self->message ("Something went wrong deep within the crossfire server. " 1997 $self->message ("Something went wrong deep within the crossfire server. "
1663 . "I'll try to bring you back to the map you were before. " 1998 . "I'll try to bring you back to the map you were before. "
1664 . "Please report this to the dungeon master", 1999 . "Please report this to the dungeon master!",
1665 cf::NDI_UNIQUE | cf::NDI_RED); 2000 cf::NDI_UNIQUE | cf::NDI_RED);
1666 2001
1667 warn "ERROR in enter_exit: $@"; 2002 warn "ERROR in enter_exit: $@";
1668 $self->leave_link; 2003 $self->leave_link;
1669 } 2004 }
1670 })->prio (1); 2005 })->prio (1);
… …
1683 2018
1684sub cf::client::send_drawinfo { 2019sub cf::client::send_drawinfo {
1685 my ($self, $text, $flags) = @_; 2020 my ($self, $text, $flags) = @_;
1686 2021
1687 utf8::encode $text; 2022 utf8::encode $text;
1688 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2023 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1689} 2024}
1690 2025
2026=item $client->ext_event ($type, %msg)
2027
2028Sends an exti event to the client.
2029
2030=cut
2031
2032sub cf::client::ext_event($$%) {
2033 my ($self, $type, %msg) = @_;
2034
2035 $msg{msgtype} = "event_$type";
2036 $self->send_packet ("ext " . cf::to_json \%msg);
2037}
1691 2038
1692=item $success = $client->query ($flags, "text", \&cb) 2039=item $success = $client->query ($flags, "text", \&cb)
1693 2040
1694Queues a query to the client, calling the given callback with 2041Queues a query to the client, calling the given callback with
1695the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2042the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
… …
1724 # get handled first 2071 # get handled first
1725 my $queue = delete $ns->{query_queue} 2072 my $queue = delete $ns->{query_queue}
1726 or return; # be conservative, not sure how that can happen, but we saw a crash here 2073 or return; # be conservative, not sure how that can happen, but we saw a crash here
1727 2074
1728 (shift @$queue)->[1]->($msg); 2075 (shift @$queue)->[1]->($msg);
2076 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1729 2077
1730 push @{ $ns->{query_queue} }, @$queue; 2078 push @{ $ns->{query_queue} }, @$queue;
1731 2079
1732 if (@{ $ns->{query_queue} } == @$queue) { 2080 if (@{ $ns->{query_queue} } == @$queue) {
1733 if (@$queue) { 2081 if (@$queue) {
… …
1737 } 2085 }
1738 } 2086 }
1739 }, 2087 },
1740); 2088);
1741 2089
1742=item $client->coro (\&cb) 2090=item $client->async (\&cb)
1743 2091
1744Create a new coroutine, running the specified callback. The coroutine will 2092Create a new coroutine, running the specified callback. The coroutine will
1745be automatically cancelled when the client gets destroyed (e.g. on logout, 2093be automatically cancelled when the client gets destroyed (e.g. on logout,
1746or loss of connection). 2094or loss of connection).
1747 2095
1748=cut 2096=cut
1749 2097
1750sub cf::client::coro { 2098sub cf::client::async {
1751 my ($self, $cb) = @_; 2099 my ($self, $cb) = @_;
1752 2100
1753 my $coro = &cf::async ($cb); 2101 my $coro = &Coro::async ($cb);
1754 2102
1755 $coro->on_destroy (sub { 2103 $coro->on_destroy (sub {
1756 delete $self->{_coro}{$coro+0}; 2104 delete $self->{_coro}{$coro+0};
1757 }); 2105 });
1758 2106
… …
1791 2139
1792# here we export the classes and methods available to script code 2140# here we export the classes and methods available to script code
1793 2141
1794=pod 2142=pod
1795 2143
1796The following fucntions and emthods are available within a safe environment: 2144The following functions and methods are available within a safe environment:
1797 2145
1798 cf::object contr pay_amount pay_player map 2146 cf::object contr pay_amount pay_player map
1799 cf::object::player player 2147 cf::object::player player
1800 cf::player peaceful 2148 cf::player peaceful
1801 cf::map trigger 2149 cf::map trigger
… …
1894The parameter C<$family> should best start with the name of the extension 2242The parameter C<$family> should best start with the name of the extension
1895using it, it should be unique. 2243using it, it should be unique.
1896 2244
1897=over 4 2245=over 4
1898 2246
1899=item $hashref = cf::db_get $family
1900
1901Return a hashref for use by the extension C<$family>, which can be
1902modified. After modifications, you have to call C<cf::db_dirty> or
1903C<cf::db_sync>.
1904
1905=item $value = cf::db_get $family => $key 2247=item $value = cf::db_get $family => $key
1906 2248
1907Returns a single value from the database 2249Returns a single value from the database.
1908
1909=item cf::db_put $family => $hashref
1910
1911Stores the given family hashref into the database. Updates are delayed, if
1912you want the data to be synced to disk immediately, use C<cf::db_sync>.
1913 2250
1914=item cf::db_put $family => $key => $value 2251=item cf::db_put $family => $key => $value
1915 2252
1916Stores the given C<$value> in the family hash. Updates are delayed, if you 2253Stores the given C<$value> in the family.
1917want the data to be synced to disk immediately, use C<cf::db_sync>.
1918
1919=item cf::db_dirty
1920
1921Marks the database as dirty, to be updated at a later time.
1922
1923=item cf::db_sync
1924
1925Immediately write the database to disk I<if it is dirty>.
1926 2254
1927=cut 2255=cut
1928 2256
1929our $DB; 2257our $DB;
1930 2258
1931{ 2259sub db_init {
2260 unless ($DB) {
2261 $DB = BDB::db_create $DB_ENV;
2262
2263 cf::sync_job {
2264 eval {
2265 $DB->set_flags (BDB::CHKSUM);
2266
2267 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2268 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2269 cf::cleanup "db_open(db): $!" if $!;
2270 };
2271 cf::cleanup "db_open(db): $@" if $@;
2272 };
2273
1932 my $path = cf::localdir . "/database.pst"; 2274 my $path = cf::localdir . "/database.pst";
2275 if (stat $path) {
2276 cf::sync_job {
2277 my $pst = Storable::retrieve $path;
1933 2278
1934 sub db_load() { 2279 cf::db_put (board => data => $pst->{board});
1935 $DB = stat $path ? Storable::retrieve $path : { }; 2280 cf::db_put (guildrules => data => $pst->{guildrules});
1936 } 2281 cf::db_put (rent => balance => $pst->{rent}{balance});
2282 BDB::db_env_txn_checkpoint $DB_ENV;
1937 2283
1938 my $pid; 2284 unlink $path;
1939
1940 sub db_save() {
1941 waitpid $pid, 0 if $pid;
1942 if (0 == ($pid = fork)) {
1943 $DB->{_meta}{version} = 1;
1944 Storable::nstore $DB, "$path~";
1945 rename "$path~", $path;
1946 cf::_exit 0 if defined $pid;
1947 } 2285 };
1948 }
1949
1950 my $dirty;
1951
1952 sub db_sync() {
1953 db_save if $dirty;
1954 undef $dirty;
1955 }
1956
1957 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1958 db_sync;
1959 });
1960
1961 sub db_dirty() {
1962 $dirty = 1;
1963 $idle->start;
1964 }
1965
1966 sub db_get($;$) {
1967 @_ >= 2
1968 ? $DB->{$_[0]}{$_[1]}
1969 : ($DB->{$_[0]} ||= { })
1970 }
1971
1972 sub db_put($$;$) {
1973 if (@_ >= 3) {
1974 $DB->{$_[0]}{$_[1]} = $_[2];
1975 } else {
1976 $DB->{$_[0]} = $_[1];
1977 }
1978 db_dirty;
1979 }
1980
1981 cf::global->attach (
1982 prio => 10000,
1983 on_cleanup => sub {
1984 db_sync;
1985 }, 2286 }
1986 ); 2287 }
2288}
2289
2290sub db_get($$) {
2291 my $key = "$_[0]/$_[1]";
2292
2293 cf::sync_job {
2294 BDB::db_get $DB, undef, $key, my $data;
2295
2296 $! ? ()
2297 : Compress::LZF::sthaw $data
2298 }
2299}
2300
2301sub db_put($$$) {
2302 BDB::dbreq_pri 4;
2303 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
1987} 2304}
1988 2305
1989############################################################################# 2306#############################################################################
1990# the server's main() 2307# the server's init and main functions
2308
2309sub load_facedata {
2310 my $path = sprintf "%s/facedata", cf::datadir;
2311
2312 warn "loading facedata from $path\n";
2313
2314 my $facedata;
2315 0 < aio_load $path, $facedata
2316 or die "$path: $!";
2317
2318 $facedata = Coro::Storable::thaw $facedata;
2319
2320 $facedata->{version} == 2
2321 or cf::cleanup "$path: version mismatch, cannot proceed.";
2322
2323 {
2324 my $faces = $facedata->{faceinfo};
2325
2326 while (my ($face, $info) = each %$faces) {
2327 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2328 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2329 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2330 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2331 Coro::cede;
2332 }
2333
2334 while (my ($face, $info) = each %$faces) {
2335 next unless $info->{smooth};
2336 my $idx = cf::face::find $face
2337 or next;
2338 if (my $smooth = cf::face::find $info->{smooth}) {
2339 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2340 } else {
2341 warn "smooth face '$info->{smooth}' not found for face '$face'";
2342 }
2343 Coro::cede;
2344 }
2345 }
2346
2347 {
2348 my $anims = $facedata->{animinfo};
2349
2350 while (my ($anim, $info) = each %$anims) {
2351 cf::anim::set $anim, $info->{frames}, $info->{facings};
2352 Coro::cede;
2353 }
2354
2355 cf::anim::invalidate_all; # d'oh
2356 }
2357
2358 1
2359}
2360
2361sub reload_resources {
2362 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir
2363 or die "unable to load regions file\n";#d#
2364 load_facedata
2365 or die "unable to load facedata\n";#d#
2366}
2367
2368sub init {
2369 reload_resources;
2370}
1991 2371
1992sub cfg_load { 2372sub cfg_load {
1993 open my $fh, "<:utf8", cf::confdir . "/config" 2373 open my $fh, "<:utf8", cf::confdir . "/config"
1994 or return; 2374 or return;
1995 2375
1996 local $/; 2376 local $/;
1997 *CFG = YAML::Syck::Load <$fh>; 2377 *CFG = YAML::Syck::Load <$fh>;
1998 2378
1999 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 2379 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2000 2380
2381 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2382 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2383
2001 if (exists $CFG{mlockall}) { 2384 if (exists $CFG{mlockall}) {
2002 eval { 2385 eval {
2003 $CFG{mlockall} ? &mlockall : &munlockall 2386 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2004 and die "WARNING: m(un)lockall failed: $!\n"; 2387 and die "WARNING: m(un)lockall failed: $!\n";
2005 }; 2388 };
2006 warn $@ if $@; 2389 warn $@ if $@;
2007 } 2390 }
2008} 2391}
2009 2392
2010sub main { 2393sub main {
2011 # we must not ever block the main coroutine 2394 # we must not ever block the main coroutine
2012 local $Coro::idle = sub { 2395 local $Coro::idle = sub {
2013 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2396 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2014 (Coro::unblock_sub { 2397 (async {
2015 Event::one_event; 2398 Event::one_event;
2016 })->(); 2399 })->prio (Coro::PRIO_MAX);
2017 }; 2400 };
2018 2401
2019 cfg_load; 2402 cfg_load;
2020 db_load; 2403 db_init;
2021 load_extensions; 2404 load_extensions;
2405
2406 $TICK_WATCHER->start;
2022 Event::loop; 2407 Event::loop;
2023} 2408}
2024 2409
2025############################################################################# 2410#############################################################################
2026# initialisation 2411# initialisation and cleanup
2412
2413# install some emergency cleanup handlers
2414BEGIN {
2415 for my $signal (qw(INT HUP TERM)) {
2416 Event->signal (
2417 reentrant => 0,
2418 data => WF_AUTOCANCEL,
2419 signal => $signal,
2420 prio => 0,
2421 cb => sub {
2422 cf::cleanup "SIG$signal";
2423 },
2424 );
2425 }
2426}
2427
2428sub emergency_save() {
2429 my $freeze_guard = cf::freeze_mainloop;
2430
2431 warn "enter emergency perl save\n";
2432
2433 cf::sync_job {
2434 # use a peculiar iteration method to avoid tripping on perl
2435 # refcount bugs in for. also avoids problems with players
2436 # and maps saved/destroyed asynchronously.
2437 warn "begin emergency player save\n";
2438 for my $login (keys %cf::PLAYER) {
2439 my $pl = $cf::PLAYER{$login} or next;
2440 $pl->valid or next;
2441 $pl->save;
2442 }
2443 warn "end emergency player save\n";
2444
2445 warn "begin emergency map save\n";
2446 for my $path (keys %cf::MAP) {
2447 my $map = $cf::MAP{$path} or next;
2448 $map->valid or next;
2449 $map->save;
2450 }
2451 warn "end emergency map save\n";
2452
2453 warn "begin emergency database checkpoint\n";
2454 BDB::db_env_txn_checkpoint $DB_ENV;
2455 warn "end emergency database checkpoint\n";
2456 };
2457
2458 warn "leave emergency perl save\n";
2459}
2460
2461sub post_cleanup {
2462 my ($make_core) = @_;
2463
2464 warn Carp::longmess "post_cleanup backtrace"
2465 if $make_core;
2466}
2027 2467
2028sub reload() { 2468sub reload() {
2029 # can/must only be called in main 2469 # can/must only be called in main
2030 if ($Coro::current != $Coro::main) { 2470 if ($Coro::current != $Coro::main) {
2031 warn "can only reload from main coroutine\n"; 2471 warn "can only reload from main coroutine";
2032 return; 2472 return;
2033 } 2473 }
2034 2474
2035 warn "reloading..."; 2475 warn "reloading...";
2036 2476
2037 my $guard = freeze_mainloop; 2477 warn "entering sync_job";
2478
2479 cf::sync_job {
2480 cf::write_runtime; # external watchdog should not bark
2038 cf::emergency_save; 2481 cf::emergency_save;
2482 cf::write_runtime; # external watchdog should not bark
2039 2483
2040 eval { 2484 warn "syncing database to disk";
2485 BDB::db_env_txn_checkpoint $DB_ENV;
2486
2041 # if anything goes wrong in here, we should simply crash as we already saved 2487 # if anything goes wrong in here, we should simply crash as we already saved
2042 2488
2043 # cancel all watchers 2489 warn "cancelling all WF_AUTOCANCEL watchers";
2044 for (Event::all_watchers) { 2490 for (Event::all_watchers) {
2045 $_->cancel if $_->data & WF_AUTOCANCEL; 2491 $_->cancel if $_->data & WF_AUTOCANCEL;
2046 } 2492 }
2047 2493
2494 warn "flushing outstanding aio requests";
2495 for (;;) {
2496 BDB::flush;
2497 IO::AIO::flush;
2498 Coro::cede;
2499 last unless IO::AIO::nreqs || BDB::nreqs;
2500 warn "iterate...";
2501 }
2502
2503 ++$RELOAD;
2504
2048 # cancel all extension coros 2505 warn "cancelling all extension coros";
2049 $_->cancel for values %EXT_CORO; 2506 $_->cancel for values %EXT_CORO;
2050 %EXT_CORO = (); 2507 %EXT_CORO = ();
2051 2508
2052 # unload all extensions 2509 warn "removing commands";
2053 for (@exts) { 2510 %COMMAND = ();
2511
2512 warn "removing ext commands";
2513 %EXTCMD = ();
2514
2515 warn "unloading/nuking all extensions";
2516 for my $pkg (@EXTS) {
2054 warn "unloading <$_>"; 2517 warn "... unloading $pkg";
2055 unload_extension $_; 2518
2519 if (my $cb = $pkg->can ("unload")) {
2520 eval {
2521 $cb->($pkg);
2522 1
2523 } or warn "$pkg unloaded, but with errors: $@";
2056 } 2524 }
2057 2525
2526 warn "... nuking $pkg";
2527 Symbol::delete_package $pkg;
2528 }
2529
2058 # unload all modules loaded from $LIBDIR 2530 warn "unloading all perl modules loaded from $LIBDIR";
2059 while (my ($k, $v) = each %INC) { 2531 while (my ($k, $v) = each %INC) {
2060 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2532 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2061 2533
2062 warn "removing <$k>"; 2534 warn "... unloading $k";
2063 delete $INC{$k}; 2535 delete $INC{$k};
2064 2536
2065 $k =~ s/\.pm$//; 2537 $k =~ s/\.pm$//;
2066 $k =~ s/\//::/g; 2538 $k =~ s/\//::/g;
2067 2539
… …
2070 } 2542 }
2071 2543
2072 Symbol::delete_package $k; 2544 Symbol::delete_package $k;
2073 } 2545 }
2074 2546
2075 # sync database to disk
2076 cf::db_sync;
2077 IO::AIO::flush;
2078
2079 # get rid of safe::, as good as possible 2547 warn "getting rid of safe::, as good as possible";
2080 Symbol::delete_package "safe::$_" 2548 Symbol::delete_package "safe::$_"
2081 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2549 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2082 2550
2083 # remove register_script_function callbacks
2084 # TODO
2085
2086 # unload cf.pm "a bit" 2551 warn "unloading cf.pm \"a bit\"";
2087 delete $INC{"cf.pm"}; 2552 delete $INC{"cf.pm"};
2088 2553
2089 # don't, removes xs symbols, too, 2554 # don't, removes xs symbols, too,
2090 # and global variables created in xs 2555 # and global variables created in xs
2091 #Symbol::delete_package __PACKAGE__; 2556 #Symbol::delete_package __PACKAGE__;
2092 2557
2093 # reload cf.pm 2558 warn "unload completed, starting to reload now";
2559
2094 warn "reloading cf.pm"; 2560 warn "reloading cf.pm";
2095 require cf; 2561 require cf;
2096 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2562 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2097 2563
2098 # load config and database again 2564 warn "loading config and database again";
2099 cf::cfg_load; 2565 cf::cfg_load;
2100 cf::db_load;
2101 2566
2102 # load extensions
2103 warn "load extensions"; 2567 warn "loading extensions";
2104 cf::load_extensions; 2568 cf::load_extensions;
2105 2569
2106 # reattach attachments to objects 2570 warn "reattaching attachments to objects/players";
2107 warn "reattach"; 2571 _global_reattach; # objects, sockets
2108 _global_reattach; 2572 warn "reattaching attachments to maps";
2109 }; 2573 reattach $_ for values %MAP;
2574 warn "reattaching attachments to players";
2575 reattach $_ for values %PLAYER;
2110 2576
2111 if ($@) { 2577 warn "loading reloadable resources";
2578 reload_resources;
2579
2580 warn "leaving sync_job";
2581
2582 1
2583 } or do {
2112 warn $@; 2584 warn $@;
2113 warn "error while reloading, exiting."; 2585 warn "error while reloading, exiting.";
2114 exit 1; 2586 exit 1;
2115 } 2587 };
2116 2588
2117 warn "reloaded successfully"; 2589 warn "reloaded";
2118}; 2590};
2119 2591
2120############################################################################# 2592our $RELOAD_WATCHER; # used only during reload
2121
2122unless ($LINK_MAP) {
2123 $LINK_MAP = cf::map::new;
2124
2125 $LINK_MAP->width (41);
2126 $LINK_MAP->height (41);
2127 $LINK_MAP->alloc;
2128 $LINK_MAP->path ("{link}");
2129 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2130 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2131
2132 # dirty hack because... archetypes are not yet loaded
2133 Event->timer (
2134 after => 2,
2135 cb => sub {
2136 $_[0]->w->cancel;
2137
2138 # provide some exits "home"
2139 my $exit = cf::object::new "exit";
2140
2141 $exit->slaying ($EMERGENCY_POSITION->[0]);
2142 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2143 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2144
2145 $LINK_MAP->insert ($exit->clone, 19, 19);
2146 $LINK_MAP->insert ($exit->clone, 19, 20);
2147 $LINK_MAP->insert ($exit->clone, 19, 21);
2148 $LINK_MAP->insert ($exit->clone, 20, 19);
2149 $LINK_MAP->insert ($exit->clone, 20, 21);
2150 $LINK_MAP->insert ($exit->clone, 21, 19);
2151 $LINK_MAP->insert ($exit->clone, 21, 20);
2152 $LINK_MAP->insert ($exit->clone, 21, 21);
2153
2154 $exit->destroy;
2155 });
2156
2157 $LINK_MAP->{deny_save} = 1;
2158 $LINK_MAP->{deny_reset} = 1;
2159
2160 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2161}
2162
2163register "<global>", __PACKAGE__;
2164 2593
2165register_command "reload" => sub { 2594register_command "reload" => sub {
2166 my ($who, $arg) = @_; 2595 my ($who, $arg) = @_;
2167 2596
2168 if ($who->flag (FLAG_WIZ)) { 2597 if ($who->flag (FLAG_WIZ)) {
2169 $who->message ("start of reload."); 2598 $who->message ("reloading server.");
2599
2600 # doing reload synchronously and two reloads happen back-to-back,
2601 # coro crashes during coro_state_free->destroy here.
2602
2603 $RELOAD_WATCHER ||= Event->timer (
2604 reentrant => 0,
2605 after => 0,
2606 data => WF_AUTOCANCEL,
2607 cb => sub {
2170 reload; 2608 reload;
2171 $who->message ("end of reload."); 2609 undef $RELOAD_WATCHER;
2610 },
2611 );
2172 } 2612 }
2173}; 2613};
2174 2614
2175unshift @INC, $LIBDIR; 2615unshift @INC, $LIBDIR;
2616
2617my $bug_warning = 0;
2176 2618
2177$TICK_WATCHER = Event->timer ( 2619$TICK_WATCHER = Event->timer (
2178 reentrant => 0, 2620 reentrant => 0,
2621 parked => 1,
2179 prio => 0, 2622 prio => 0,
2180 at => $NEXT_TICK || $TICK, 2623 at => $NEXT_TICK || $TICK,
2181 data => WF_AUTOCANCEL, 2624 data => WF_AUTOCANCEL,
2182 cb => sub { 2625 cb => sub {
2626 if ($Coro::current != $Coro::main) {
2627 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2628 unless ++$bug_warning > 10;
2629 return;
2630 }
2631
2632 $NOW = Event::time;
2633
2183 cf::server_tick; # one server iteration 2634 cf::server_tick; # one server iteration
2184 $RUNTIME += $TICK; 2635 $RUNTIME += $TICK;
2185 $NEXT_TICK += $TICK; 2636 $NEXT_TICK += $TICK;
2637
2638 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2639 $NEXT_RUNTIME_WRITE = $NOW + 10;
2640 Coro::async_pool {
2641 write_runtime
2642 or warn "ERROR: unable to write runtime file: $!";
2643 };
2644 }
2645
2646 $WAIT_FOR_TICK->broadcast;
2647 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2648
2649# my $AFTER = Event::time;
2650# warn $AFTER - $NOW;#d#
2186 2651
2187 # if we are delayed by four ticks or more, skip them all 2652 # if we are delayed by four ticks or more, skip them all
2188 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2653 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2189 2654
2190 $TICK_WATCHER->at ($NEXT_TICK); 2655 $TICK_WATCHER->at ($NEXT_TICK);
2191 $TICK_WATCHER->start; 2656 $TICK_WATCHER->start;
2192 }, 2657 },
2193); 2658);
2194 2659
2660{
2195IO::AIO::max_poll_time $TICK * 0.2; 2661 BDB::max_poll_time $TICK * 0.1;
2196 2662 $BDB_POLL_WATCHER = Event->io (
2197Event->io ( 2663 reentrant => 0,
2198 fd => IO::AIO::poll_fileno, 2664 fd => BDB::poll_fileno,
2199 poll => 'r', 2665 poll => 'r',
2200 prio => 5, 2666 prio => 0,
2201 data => WF_AUTOCANCEL,
2202 cb => \&IO::AIO::poll_cb,
2203);
2204
2205Event->timer (
2206 data => WF_AUTOCANCEL, 2667 data => WF_AUTOCANCEL,
2207 after => 0, 2668 cb => \&BDB::poll_cb,
2208 interval => 10, 2669 );
2209 cb => sub { 2670 BDB::min_parallel 8;
2210 (Coro::unblock_sub { 2671
2211 write_runtime 2672 BDB::set_sync_prepare {
2212 or warn "ERROR: unable to write runtime file: $!"; 2673 my $status;
2674 my $current = $Coro::current;
2675 (
2676 sub {
2677 $status = $!;
2678 $current->ready; undef $current;
2679 },
2680 sub {
2681 Coro::schedule while defined $current;
2682 $! = $status;
2683 },
2684 )
2685 };
2686
2687 unless ($DB_ENV) {
2688 $DB_ENV = BDB::db_env_create;
2689
2690 cf::sync_job {
2691 eval {
2692 BDB::db_env_open
2693 $DB_ENV,
2694 $BDB_ENV_DIR,
2695 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2696 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2697 0666;
2698
2699 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!;
2700
2701 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2702 $DB_ENV->set_lk_detect;
2703 };
2704
2705 cf::cleanup "db_env_open(db): $@" if $@;
2213 })->(); 2706 };
2214 }, 2707 }
2215); 2708}
2709
2710{
2711 IO::AIO::min_parallel 8;
2712
2713 undef $Coro::AIO::WATCHER;
2714 IO::AIO::max_poll_time $TICK * 0.1;
2715 $AIO_POLL_WATCHER = Event->io (
2716 reentrant => 0,
2717 data => WF_AUTOCANCEL,
2718 fd => IO::AIO::poll_fileno,
2719 poll => 'r',
2720 prio => 6,
2721 cb => \&IO::AIO::poll_cb,
2722 );
2723}
2216 2724
2217END { cf::emergency_save } 2725END { cf::emergency_save }
2218 2726
22191 27271
2220 2728

Diff Legend

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