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

Diff Legend

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