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.102 by root, Wed Dec 27 15:20:54 2006 UTC vs.
Revision 1.216 by root, Thu Feb 15 14:30:21 2007 UTC

… …
8use Storable; 8use Storable;
9use Opcode; 9use Opcode;
10use Safe; 10use Safe;
11use Safe::Hole; 11use Safe::Hole;
12 12
13use Coro; 13use Coro 3.5 ();
14use Coro::Event; 14use Coro::Event;
15use Coro::Timer; 15use Coro::Timer;
16use Coro::Signal; 16use Coro::Signal;
17use Coro::Semaphore; 17use Coro::Semaphore;
18use Coro::AIO;
18 19
20use BDB ();
21use Data::Dumper;
22use Digest::MD5;
23use Fcntl;
19use IO::AIO 2.3; 24use IO::AIO 2.32 ();
20use YAML::Syck (); 25use YAML::Syck ();
21use Time::HiRes; 26use Time::HiRes;
27use Compress::LZF;
28
29Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
22 30
23use Event; $Event::Eval = 1; # no idea why this is required, but it is 31use Event; $Event::Eval = 1; # no idea why this is required, but it is
32
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
24 34
25# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 35# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
26$YAML::Syck::ImplicitUnicode = 1; 36$YAML::Syck::ImplicitUnicode = 1;
27 37
28$Coro::main->prio (Coro::PRIO_MIN); 38$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
29
30sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
31 39
32our %COMMAND = (); 40our %COMMAND = ();
33our %COMMAND_TIME = (); 41our %COMMAND_TIME = ();
42
43our @EXTS = (); # list of extension package names
34our %EXTCMD = (); 44our %EXTCMD = ();
45our %EXT_CORO = (); # coroutines bound to extensions
46our %EXT_MAP = (); # pluggable maps
35 47
36our @EVENT; 48our @EVENT;
37our $LIBDIR = datadir . "/ext"; 49our $LIBDIR = datadir . "/ext";
38 50
39our $TICK = MAX_TIME * 1e-6; 51our $TICK = MAX_TIME * 1e-6;
40our $TICK_WATCHER; 52our $TICK_WATCHER;
53our $AIO_POLL_WATCHER;
54our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
41our $NEXT_TICK; 55our $NEXT_TICK;
56our $NOW;
57our $USE_FSYNC = 1; # use fsync to write maps - default off
58
59our $BDB_POLL_WATCHER;
60our $DB_ENV;
42 61
43our %CFG; 62our %CFG;
44 63
45our $UPTIME; $UPTIME ||= time; 64our $UPTIME; $UPTIME ||= time;
65our $RUNTIME;
66
67our %PLAYER; # all users
68our %MAP; # all maps
69our $LINK_MAP; # the special {link} map, which is always available
70our $RANDOM_MAPS = cf::localdir . "/random";
71our $BDB_ENV_DIR = cf::localdir . "/db";
72
73our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
74our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
75
76# used to convert map paths into valid unix filenames by replacing / by ∕
77our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
78
79binmode STDOUT;
80binmode STDERR;
81
82# read virtual server time, if available
83unless ($RUNTIME || !-e cf::localdir . "/runtime") {
84 open my $fh, "<", cf::localdir . "/runtime"
85 or die "unable to read runtime file: $!";
86 $RUNTIME = <$fh> + 0.;
87}
88
89mkdir cf::localdir;
90mkdir cf::localdir . "/" . cf::playerdir;
91mkdir cf::localdir . "/" . cf::tmpdir;
92mkdir cf::localdir . "/" . cf::uniquedir;
93mkdir $RANDOM_MAPS;
94mkdir $BDB_ENV_DIR;
95
96our $EMERGENCY_POSITION;
97
98sub cf::map::normalise;
46 99
47############################################################################# 100#############################################################################
48 101
49=head2 GLOBAL VARIABLES 102=head2 GLOBAL VARIABLES
50 103
51=over 4 104=over 4
52 105
53=item $cf::UPTIME 106=item $cf::UPTIME
54 107
55The timestamp of the server start (so not actually an uptime). 108The timestamp of the server start (so not actually an uptime).
109
110=item $cf::RUNTIME
111
112The time this server has run, starts at 0 and is increased by $cf::TICK on
113every server tick.
56 114
57=item $cf::LIBDIR 115=item $cf::LIBDIR
58 116
59The perl library directory, where extensions and cf-specific modules can 117The perl library directory, where extensions and cf-specific modules can
60be found. It will be added to C<@INC> automatically. 118be found. It will be added to C<@INC> automatically.
61 119
120=item $cf::NOW
121
122The time of the last (current) server tick.
123
62=item $cf::TICK 124=item $cf::TICK
63 125
64The interval between server ticks, in seconds. 126The interval between server ticks, in seconds.
65 127
66=item %cf::CFG 128=item %cf::CFG
67 129
68Configuration for the server, loaded from C</etc/crossfire/config>, or 130Configuration for the server, loaded from C</etc/crossfire/config>, or
69from wherever your confdir points to. 131from wherever your confdir points to.
132
133=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
134
135These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
136or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
137processing has been done. Call C<< ->wait >> on them to maximise the
138window of cpu time available, or simply to synchronise to the server tick.
70 139
71=back 140=back
72 141
73=cut 142=cut
74 143
75BEGIN { 144BEGIN {
76 *CORE::GLOBAL::warn = sub { 145 *CORE::GLOBAL::warn = sub {
77 my $msg = join "", @_; 146 my $msg = join "", @_;
147 utf8::encode $msg;
148
78 $msg .= "\n" 149 $msg .= "\n"
79 unless $msg =~ /\n$/; 150 unless $msg =~ /\n$/;
80 151
81 print STDERR "cfperl: $msg";
82 LOG llevError, "cfperl: $msg"; 152 LOG llevError, $msg;
83 }; 153 };
84} 154}
85 155
86@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 156@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
87@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 157@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
… …
105 175
106$Event::DIED = sub { 176$Event::DIED = sub {
107 warn "error in event callback: @_"; 177 warn "error in event callback: @_";
108}; 178};
109 179
110my %ext_pkg;
111my @exts;
112my @hook;
113
114=head2 UTILITY FUNCTIONS 180=head2 UTILITY FUNCTIONS
115 181
116=over 4 182=over 4
117 183
184=item dumpval $ref
185
118=cut 186=cut
187
188sub dumpval {
189 eval {
190 local $SIG{__DIE__};
191 my $d;
192 if (1) {
193 $d = new Data::Dumper([$_[0]], ["*var"]);
194 $d->Terse(1);
195 $d->Indent(2);
196 $d->Quotekeys(0);
197 $d->Useqq(1);
198 #$d->Bless(...);
199 $d->Seen($_[1]) if @_ > 1;
200 $d = $d->Dump();
201 }
202 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
203 $d
204 } || "[unable to dump $_[0]: '$@']";
205}
119 206
120use JSON::Syck (); # TODO# replace by JSON::PC once working 207use JSON::Syck (); # TODO# replace by JSON::PC once working
121 208
122=item $ref = cf::from_json $json 209=item $ref = cf::from_json $json
123 210
… …
137=cut 224=cut
138 225
139sub to_json($) { 226sub to_json($) {
140 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 227 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
141 JSON::Syck::Dump $_[0] 228 JSON::Syck::Dump $_[0]
229}
230
231=item cf::lock_wait $string
232
233Wait until the given lock is available. See cf::lock_acquire.
234
235=item my $lock = cf::lock_acquire $string
236
237Wait until the given lock is available and then acquires it and returns
238a Coro::guard object. If the guard object gets destroyed (goes out of scope,
239for example when the coroutine gets canceled), the lock is automatically
240returned.
241
242Lock names should begin with a unique identifier (for example, cf::map::find
243uses map_find and cf::map::load uses map_load).
244
245=cut
246
247our %LOCK;
248
249sub lock_wait($) {
250 my ($key) = @_;
251
252 # wait for lock, if any
253 while ($LOCK{$key}) {
254 push @{ $LOCK{$key} }, $Coro::current;
255 Coro::schedule;
256 }
257}
258
259sub lock_acquire($) {
260 my ($key) = @_;
261
262 # wait, to be sure we are not locked
263 lock_wait $key;
264
265 $LOCK{$key} = [];
266
267 Coro::guard {
268 # wake up all waiters, to be on the safe side
269 $_->ready for @{ delete $LOCK{$key} };
270 }
271}
272
273sub freeze_mainloop {
274 return unless $TICK_WATCHER->is_active;
275
276 my $guard = Coro::guard {
277 $TICK_WATCHER->start;
278 };
279 $TICK_WATCHER->stop;
280 $guard
281}
282
283=item cf::async { BLOCK }
284
285Currently the same as Coro::async_pool, meaning you cannot use
286C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
287thing you are allowed to do is call C<prio> on it.
288
289=cut
290
291BEGIN { *async = \&Coro::async_pool }
292
293=item cf::sync_job { BLOCK }
294
295The design of crossfire+ requires that the main coro ($Coro::main) is
296always able to handle events or runnable, as crossfire+ is only partly
297reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
298
299If it must be done, put the blocking parts into C<sync_job>. This will run
300the given BLOCK in another coroutine while waiting for the result. The
301server will be frozen during this time, so the block should either finish
302fast or be very important.
303
304=cut
305
306sub sync_job(&) {
307 my ($job) = @_;
308
309 if ($Coro::current == $Coro::main) {
310 # this is the main coro, too bad, we have to block
311 # till the operation succeeds, freezing the server :/
312
313 # TODO: use suspend/resume instead
314 # (but this is cancel-safe)
315 my $freeze_guard = freeze_mainloop;
316
317 my $busy = 1;
318 my @res;
319
320 (async {
321 @res = eval { $job->() };
322 warn $@ if $@;
323 undef $busy;
324 })->prio (Coro::PRIO_MAX);
325
326 while ($busy) {
327 Coro::cede or Event::one_event;
328 }
329
330 wantarray ? @res : $res[0]
331 } else {
332 # we are in another coroutine, how wonderful, everything just works
333
334 $job->()
335 }
336}
337
338=item $coro = cf::async_ext { BLOCK }
339
340Like async, but this coro is automatically being canceled when the
341extension calling this is being unloaded.
342
343=cut
344
345sub async_ext(&) {
346 my $cb = shift;
347
348 my $coro = &Coro::async ($cb);
349
350 $coro->on_destroy (sub {
351 delete $EXT_CORO{$coro+0};
352 });
353 $EXT_CORO{$coro+0} = $coro;
354
355 $coro
356}
357
358sub write_runtime {
359 my $runtime = cf::localdir . "/runtime";
360
361 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
362 or return;
363
364 my $value = $cf::RUNTIME + 90 + 10;
365 # 10 is the runtime save interval, for a monotonic clock
366 # 60 allows for the watchdog to kill the server.
367
368 (aio_write $fh, 0, (length $value), $value, 0) <= 0
369 and return;
370
371 # always fsync - this file is important
372 aio_fsync $fh
373 and return;
374
375 close $fh
376 or return;
377
378 aio_rename "$runtime~", $runtime
379 and return;
380
381 1
142} 382}
143 383
144=back 384=back
145 385
146=cut 386=cut
… …
277our @CB_TYPE = (); # registry for type (cf-object class) based events 517our @CB_TYPE = (); # registry for type (cf-object class) based events
278our @CB_MAP = (); 518our @CB_MAP = ();
279 519
280my %attachment; 520my %attachment;
281 521
522sub cf::attachable::thawer_merge {
523 # simply override everything except _meta
524 local $_[0]{_meta};
525 %{$_[0]} = %{$_[1]};
526}
527
282sub _attach_cb($$$$) { 528sub _attach_cb($$$$) {
283 my ($registry, $event, $prio, $cb) = @_; 529 my ($registry, $event, $prio, $cb) = @_;
284 530
285 use sort 'stable'; 531 use sort 'stable';
286 532
… …
457# object support 703# object support
458 704
459sub reattach { 705sub reattach {
460 # basically do the same as instantiate, without calling instantiate 706 # basically do the same as instantiate, without calling instantiate
461 my ($obj) = @_; 707 my ($obj) = @_;
708
709 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
462 710
463 my $registry = $obj->registry; 711 my $registry = $obj->registry;
464 712
465 @$registry = (); 713 @$registry = ();
466 714
… …
505); 753);
506 754
507sub object_freezer_save { 755sub object_freezer_save {
508 my ($filename, $rdata, $objs) = @_; 756 my ($filename, $rdata, $objs) = @_;
509 757
758 sync_job {
510 if (length $$rdata) { 759 if (length $$rdata) {
511 warn sprintf "saving %s (%d,%d)\n", 760 warn sprintf "saving %s (%d,%d)\n",
512 $filename, length $$rdata, scalar @$objs; 761 $filename, length $$rdata, scalar @$objs;
513 762
514 if (open my $fh, ">:raw", "$filename~") { 763 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
515 chmod SAVE_MODE, $fh;
516 syswrite $fh, $$rdata;
517 close $fh;
518
519 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
520 chmod SAVE_MODE, $fh; 764 chmod SAVE_MODE, $fh;
521 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 765 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
766 aio_fsync $fh if $cf::USE_FSYNC;
522 close $fh; 767 close $fh;
768
769 if (@$objs) {
770 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
771 chmod SAVE_MODE, $fh;
772 my $data = Storable::nfreeze { version => 1, objs => $objs };
773 aio_write $fh, 0, (length $data), $data, 0;
774 aio_fsync $fh if $cf::USE_FSYNC;
775 close $fh;
523 rename "$filename.pst~", "$filename.pst"; 776 aio_rename "$filename.pst~", "$filename.pst";
777 }
778 } else {
779 aio_unlink "$filename.pst";
780 }
781
782 aio_rename "$filename~", $filename;
524 } else { 783 } else {
525 unlink "$filename.pst"; 784 warn "FATAL: $filename~: $!\n";
526 } 785 }
527
528 rename "$filename~", $filename;
529 } else { 786 } else {
530 warn "FATAL: $filename~: $!\n";
531 }
532 } else {
533 unlink $filename; 787 aio_unlink $filename;
534 unlink "$filename.pst"; 788 aio_unlink "$filename.pst";
789 }
535 } 790 }
536} 791}
537 792
538sub object_freezer_as_string { 793sub object_freezer_as_string {
539 my ($rdata, $objs) = @_; 794 my ($rdata, $objs) = @_;
… …
544} 799}
545 800
546sub object_thawer_load { 801sub object_thawer_load {
547 my ($filename) = @_; 802 my ($filename) = @_;
548 803
549 local $/; 804 my ($data, $av);
550 805
551 my $av; 806 (aio_load $filename, $data) >= 0
807 or return;
552 808
553 #TODO: use sysread etc. 809 unless (aio_stat "$filename.pst") {
554 if (open my $data, "<:raw:perlio", $filename) { 810 (aio_load "$filename.pst", $av) >= 0
555 $data = <$data>; 811 or return;
556 if (open my $pst, "<:raw:perlio", "$filename.pst") {
557 $av = eval { (Storable::thaw <$pst>)->{objs} }; 812 $av = eval { (Storable::thaw $av)->{objs} };
558 } 813 }
814
815 warn sprintf "loading %s (%d)\n",
816 $filename, length $data, scalar @{$av || []};#d#
559 return ($data, $av); 817 return ($data, $av);
560 }
561
562 ()
563} 818}
564 819
565############################################################################# 820#############################################################################
566# command handling &c 821# command handling &c
567 822
… …
591=cut 846=cut
592 847
593sub register_extcmd { 848sub register_extcmd {
594 my ($name, $cb) = @_; 849 my ($name, $cb) = @_;
595 850
596 my $caller = caller;
597 #warn "registering extcmd '$name' to '$caller'";
598
599 $EXTCMD{$name} = [$cb, $caller]; 851 $EXTCMD{$name} = $cb;
600} 852}
601 853
602cf::player->attach ( 854cf::player->attach (
603 on_command => sub { 855 on_command => sub {
604 my ($pl, $name, $params) = @_; 856 my ($pl, $name, $params) = @_;
… …
617 869
618 my $msg = eval { from_json $buf }; 870 my $msg = eval { from_json $buf };
619 871
620 if (ref $msg) { 872 if (ref $msg) {
621 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 873 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
622 if (my %reply = $cb->[0]->($pl, $msg)) { 874 if (my %reply = $cb->($pl, $msg)) {
623 $pl->ext_reply ($msg->{msgid}, %reply); 875 $pl->ext_reply ($msg->{msgid}, %reply);
624 } 876 }
625 } 877 }
626 } else { 878 } else {
627 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 879 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
629 881
630 cf::override; 882 cf::override;
631 }, 883 },
632); 884);
633 885
634sub register {
635 my ($base, $pkg) = @_;
636
637 #TODO
638}
639
640sub load_extension { 886sub load_extension {
641 my ($path) = @_; 887 my ($path) = @_;
642 888
643 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 889 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
644 my $base = $1; 890 my $base = $1;
645 my $pkg = $1; 891 my $pkg = $1;
646 $pkg =~ s/[^[:word:]]/_/g; 892 $pkg =~ s/[^[:word:]]/_/g;
647 $pkg = "ext::$pkg"; 893 $pkg = "ext::$pkg";
648 894
649 warn "loading '$path' into '$pkg'\n"; 895 warn "... loading '$path' into '$pkg'\n";
650 896
651 open my $fh, "<:utf8", $path 897 open my $fh, "<:utf8", $path
652 or die "$path: $!"; 898 or die "$path: $!";
653 899
654 my $source = 900 my $source =
655 "package $pkg; use strict; use utf8;\n" 901 "package $pkg; use strict; use utf8;\n"
656 . "#line 1 \"$path\"\n{\n" 902 . "#line 1 \"$path\"\n{\n"
657 . (do { local $/; <$fh> }) 903 . (do { local $/; <$fh> })
658 . "\n};\n1"; 904 . "\n};\n1";
659 905
660 eval $source 906 unless (eval $source) {
661 or die $@ ? "$path: $@\n" 907 my $msg = $@ ? "$path: $@\n"
662 : "extension disabled.\n"; 908 : "extension disabled.\n";
663 909 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
664 push @exts, $pkg; 910 warn $@;
665 $ext_pkg{$base} = $pkg; 911 warn "mandatory extension failed to load, exiting.\n";
666 912 exit 1;
667# no strict 'refs'; 913 }
668# @{"$pkg\::ISA"} = ext::; 914 die $@;
669
670 register $base, $pkg;
671}
672
673sub unload_extension {
674 my ($pkg) = @_;
675
676 warn "removing extension $pkg\n";
677
678 # remove hooks
679 #TODO
680# for my $idx (0 .. $#PLUGIN_EVENT) {
681# delete $hook[$idx]{$pkg};
682# } 915 }
683 916
684 # remove commands 917 push @EXTS, $pkg;
685 for my $name (keys %COMMAND) {
686 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
687
688 if (@cb) {
689 $COMMAND{$name} = \@cb;
690 } else {
691 delete $COMMAND{$name};
692 }
693 }
694
695 # remove extcmds
696 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
697 delete $EXTCMD{$name};
698 }
699
700 if (my $cb = $pkg->can ("unload")) {
701 eval {
702 $cb->($pkg);
703 1
704 } or warn "$pkg unloaded, but with errors: $@";
705 }
706
707 Symbol::delete_package $pkg;
708} 918}
709 919
710sub load_extensions { 920sub load_extensions {
711 for my $ext (<$LIBDIR/*.ext>) { 921 for my $ext (<$LIBDIR/*.ext>) {
712 next unless -r $ext; 922 next unless -r $ext;
… …
716 } or warn "$ext not loaded: $@"; 926 } or warn "$ext not loaded: $@";
717 } 927 }
718} 928}
719 929
720############################################################################# 930#############################################################################
721# load/save/clean perl data associated with a map
722 931
723*cf::mapsupport::on_clean = sub { 932=head2 CORE EXTENSIONS
933
934Functions and methods that extend core crossfire objects.
935
936=cut
937
938package cf::player;
939
940use Coro::AIO;
941
942=head3 cf::player
943
944=over 4
945
946=item cf::player::find $login
947
948Returns the given player object, loading it if necessary (might block).
949
950=cut
951
952sub playerdir($) {
953 cf::localdir
954 . "/"
955 . cf::playerdir
956 . "/"
957 . (ref $_[0] ? $_[0]->ob->name : $_[0])
958}
959
960sub path($) {
961 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
962
963 (playerdir $login) . "/$login.pl"
964}
965
966sub find_active($) {
967 $cf::PLAYER{$_[0]}
968 and $cf::PLAYER{$_[0]}->active
969 and $cf::PLAYER{$_[0]}
970}
971
972sub exists($) {
973 my ($login) = @_;
974
975 $cf::PLAYER{$login}
976 or cf::sync_job { !aio_stat path $login }
977}
978
979sub find($) {
980 return $cf::PLAYER{$_[0]} || do {
981 my $login = $_[0];
982
983 my $guard = cf::lock_acquire "user_find:$login";
984
985 $cf::PLAYER{$_[0]} || do {
986 my $pl = load_pl path $login
987 or return;
988 $cf::PLAYER{$login} = $pl
989 }
990 }
991}
992
993sub save($) {
994 my ($pl) = @_;
995
996 return if $pl->{deny_save};
997
998 my $path = path $pl;
999 my $guard = cf::lock_acquire "user_save:$path";
1000
1001 return if $pl->{deny_save};
1002
1003 aio_mkdir playerdir $pl, 0770;
1004 $pl->{last_save} = $cf::RUNTIME;
1005
1006 $pl->save_pl ($path);
1007 Coro::cede;
1008}
1009
1010sub new($) {
1011 my ($login) = @_;
1012
1013 my $self = create;
1014
1015 $self->ob->name ($login);
1016 $self->{deny_save} = 1;
1017
1018 $cf::PLAYER{$login} = $self;
1019
1020 $self
1021}
1022
1023=item $pl->quit_character
1024
1025Nukes the player without looking back. If logged in, the connection will
1026be destroyed. May block for a long time.
1027
1028=cut
1029
1030sub quit_character {
1031 my ($pl) = @_;
1032
1033 $pl->{deny_save} = 1;
1034 $pl->password ("*"); # this should lock out the player until we nuked the dir
1035
1036 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1037 $pl->deactivate;
1038 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1039 $pl->ns->destroy if $pl->ns;
1040
1041 my $path = playerdir $pl;
1042 my $temp = "$path~$cf::RUNTIME~deleting~";
1043 aio_rename $path, $temp;
1044 delete $cf::PLAYER{$pl->ob->name};
1045 $pl->destroy;
1046 IO::AIO::aio_rmtree $temp;
1047}
1048
1049=item cf::player::list_logins
1050
1051Returns am arrayref of all valid playernames in the system, can take a
1052while and may block, so not sync_job-capable, ever.
1053
1054=cut
1055
1056sub list_logins {
1057 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1058 or return [];
1059
1060 my @logins;
1061
1062 for my $login (@$dirs) {
1063 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1064 aio_read $fh, 0, 512, my $buf, 0 or next;
1065 $buf !~ /^password -------------$/m or next; # official not-valid tag
1066
1067 utf8::decode $login;
1068 push @logins, $login;
1069 }
1070
1071 \@logins
1072}
1073
1074=item $player->maps
1075
1076Returns an arrayref of map paths that are private for this
1077player. May block.
1078
1079=cut
1080
1081sub maps($) {
1082 my ($pl) = @_;
1083
1084 $pl = ref $pl ? $pl->ob->name : $pl;
1085
1086 my $files = aio_readdir playerdir $pl
1087 or return;
1088
1089 my @paths;
1090
1091 for (@$files) {
1092 utf8::decode $_;
1093 next if /\.(?:pl|pst)$/;
1094 next unless /^$PATH_SEP/o;
1095
1096 push @paths, cf::map::normalise "~$pl/$_";
1097 }
1098
1099 \@paths
1100}
1101
1102=item $player->ext_reply ($msgid, $msgtype, %msg)
1103
1104Sends an ext reply to the player.
1105
1106=cut
1107
1108sub ext_reply($$$%) {
1109 my ($self, $id, %msg) = @_;
1110
1111 $msg{msgid} = $id;
1112
1113 $self->send ("ext " . cf::to_json \%msg);
1114}
1115
1116package cf;
1117
1118=back
1119
1120
1121=head3 cf::map
1122
1123=over 4
1124
1125=cut
1126
1127package cf::map;
1128
1129use Fcntl;
1130use Coro::AIO;
1131
1132use overload
1133 '""' => \&as_string,
1134 fallback => 1;
1135
1136our $MAX_RESET = 3600;
1137our $DEFAULT_RESET = 3000;
1138
1139sub generate_random_map {
1140 my ($self, $rmp) = @_;
1141 # mit "rum" bekleckern, nicht
1142 $self->_create_random_map (
1143 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1144 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1145 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1146 $rmp->{exit_on_final_map},
1147 $rmp->{xsize}, $rmp->{ysize},
1148 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1149 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1150 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1151 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1152 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1153 (cf::region::find $rmp->{region}), $rmp->{custom}
1154 )
1155}
1156
1157=item cf::map->register ($regex, $prio)
1158
1159Register a handler for the map path matching the given regex at the
1160givne priority (higher is better, built-in handlers have priority 0, the
1161default).
1162
1163=cut
1164
1165sub register {
1166 my (undef, $regex, $prio) = @_;
1167 my $pkg = caller;
1168
1169 no strict;
1170 push @{"$pkg\::ISA"}, __PACKAGE__;
1171
1172 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1173}
1174
1175# also paths starting with '/'
1176$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1177
1178sub thawer_merge {
1179 my ($self, $merge) = @_;
1180
1181 # we have to keep some variables in memory intact
1182 local $self->{path};
1183 local $self->{load_path};
1184 local $self->{deny_save};
1185 local $self->{deny_reset};
1186
1187 $self->SUPER::thawer_merge ($merge);
1188}
1189
1190sub normalise {
1191 my ($path, $base) = @_;
1192
1193 $path = "$path"; # make sure its a string
1194
1195 $path =~ s/\.map$//;
1196
1197 # map plan:
1198 #
1199 # /! non-realised random map exit (special hack!)
1200 # {... are special paths that are not being touched
1201 # ?xxx/... are special absolute paths
1202 # ?random/... random maps
1203 # /... normal maps
1204 # ~user/... per-player map of a specific user
1205
1206 $path =~ s/$PATH_SEP/\//go;
1207
1208 # treat it as relative path if it starts with
1209 # something that looks reasonable
1210 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1211 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1212
1213 $base =~ s{[^/]+/?$}{};
1214 $path = "$base/$path";
1215 }
1216
1217 for ($path) {
1218 redo if s{//}{/};
1219 redo if s{/\.?/}{/};
1220 redo if s{/[^/]+/\.\./}{/};
1221 }
1222
1223 $path
1224}
1225
1226sub new_from_path {
1227 my (undef, $path, $base) = @_;
1228
1229 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1230
1231 $path = normalise $path, $base;
1232
1233 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1234 if ($path =~ $EXT_MAP{$pkg}[1]) {
1235 my $self = bless cf::map::new, $pkg;
1236 $self->{path} = $path; $self->path ($path);
1237 $self->init; # pass $1 etc.
1238 return $self;
1239 }
1240 }
1241
1242 Carp::carp "unable to resolve path '$path' (base '$base').";
1243 ()
1244}
1245
1246sub init {
1247 my ($self) = @_;
1248
1249 $self
1250}
1251
1252sub as_string {
1253 my ($self) = @_;
1254
1255 "$self->{path}"
1256}
1257
1258# the displayed name, this is a one way mapping
1259sub visible_name {
1260 &as_string
1261}
1262
1263# the original (read-only) location
1264sub load_path {
1265 my ($self) = @_;
1266
1267 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path}
1268}
1269
1270# the temporary/swap location
1271sub save_path {
1272 my ($self) = @_;
1273
1274 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1275 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path
1276}
1277
1278# the unique path, undef == no special unique path
1279sub uniq_path {
1280 my ($self) = @_;
1281
1282 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1283 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path
1284}
1285
1286# and all this just because we cannot iterate over
1287# all maps in C++...
1288sub change_all_map_light {
1289 my ($change) = @_;
1290
1291 $_->change_map_light ($change)
1292 for grep $_->outdoor, values %cf::MAP;
1293}
1294
1295sub unlink_save {
1296 my ($self) = @_;
1297
1298 utf8::encode (my $save = $self->save_path);
1299 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1300 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1301}
1302
1303sub load_header_from($) {
1304 my ($self, $path) = @_;
1305
1306 utf8::encode $path;
1307 #aio_open $path, O_RDONLY, 0
1308 # or return;
1309
1310 $self->_load_header ($path)
1311 or return;
1312
1313 $self->{load_path} = $path;
1314
1315 1
1316}
1317
1318sub load_header_orig {
1319 my ($self) = @_;
1320
1321 $self->load_header_from ($self->load_path)
1322}
1323
1324sub load_header_temp {
1325 my ($self) = @_;
1326
1327 $self->load_header_from ($self->save_path)
1328}
1329
1330sub prepare_temp {
1331 my ($self) = @_;
1332
1333 $self->last_access ((delete $self->{last_access})
1334 || $cf::RUNTIME); #d#
1335 # safety
1336 $self->{instantiate_time} = $cf::RUNTIME
1337 if $self->{instantiate_time} > $cf::RUNTIME;
1338}
1339
1340sub prepare_orig {
1341 my ($self) = @_;
1342
1343 $self->{load_original} = 1;
1344 $self->{instantiate_time} = $cf::RUNTIME;
1345 $self->last_access ($cf::RUNTIME);
1346 $self->instantiate;
1347}
1348
1349sub load_header {
1350 my ($self) = @_;
1351
1352 if ($self->load_header_temp) {
1353 $self->prepare_temp;
1354 } else {
1355 $self->load_header_orig
1356 or return;
1357 $self->prepare_orig;
1358 }
1359
1360 1
1361}
1362
1363sub find;
1364sub find {
1365 my ($path, $origin) = @_;
1366
1367 $path = normalise $path, $origin && $origin->path;
1368
1369 cf::lock_wait "map_find:$path";
1370
1371 $cf::MAP{$path} || do {
1372 my $guard = cf::lock_acquire "map_find:$path";
1373 my $map = new_from_path cf::map $path
1374 or return;
1375
1376 $map->{last_save} = $cf::RUNTIME;
1377
1378 $map->load_header
1379 or return;
1380
1381 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?)
1382 # doing this can freeze the server in a sync job, obviously
1383 #$cf::WAIT_FOR_TICK->wait;
1384 $map->reset;
1385 undef $guard;
1386 return find $path;
1387 }
1388
1389 $cf::MAP{$path} = $map
1390 }
1391}
1392
1393sub pre_load { }
1394sub post_load { }
1395
1396sub load {
1397 my ($self) = @_;
1398
1399 local $self->{deny_reset} = 1; # loading can take a long time
1400
1401 my $path = $self->{path};
1402 my $guard = cf::lock_acquire "map_load:$path";
1403
1404 return if $self->in_memory != cf::MAP_SWAPPED;
1405
1406 $self->in_memory (cf::MAP_LOADING);
1407
1408 $self->alloc;
1409
1410 $self->pre_load;
1411
1412 $self->_load_objects ($self->{load_path}, 1)
1413 or return;
1414
1415 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1416 if delete $self->{load_original};
1417
1418 if (my $uniq = $self->uniq_path) {
1419 utf8::encode $uniq;
1420 if (aio_open $uniq, O_RDONLY, 0) {
1421 $self->clear_unique_items;
1422 $self->_load_objects ($uniq, 0);
1423 }
1424 }
1425
1426 Coro::cede;
1427
1428 # now do the right thing for maps
1429 $self->link_multipart_objects;
1430
1431 unless ($self->{deny_activate}) {
1432 $self->decay_objects;
1433 $self->fix_auto_apply;
1434 $self->update_buttons;
1435 Coro::cede;
1436 $self->set_darkness_map;
1437 $self->difficulty ($self->estimate_difficulty)
1438 unless $self->difficulty;
1439 Coro::cede;
1440 $self->activate;
1441 }
1442
1443 $self->post_load;
1444
1445 $self->in_memory (cf::MAP_IN_MEMORY);
1446}
1447
1448sub customise_for {
1449 my ($self, $ob) = @_;
1450
1451 return find "~" . $ob->name . "/" . $self->{path}
1452 if $self->per_player;
1453
1454 $self
1455}
1456
1457# find and load all maps in the 3x3 area around a map
1458sub load_diag {
724 my ($map) = @_; 1459 my ($map) = @_;
725 1460
726 my $path = $map->tmpname; 1461 my @diag; # diagonal neighbours
727 defined $path or return;
728 1462
729 unlink "$path.pst"; 1463 for (0 .. 3) {
730}; 1464 my $neigh = $map->tile_path ($_)
1465 or next;
1466 $neigh = find $neigh, $map
1467 or next;
1468 $neigh->load;
731 1469
732cf::map->attach (prio => -10000, package => cf::mapsupport::); 1470 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1471 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1472 }
733 1473
734############################################################################# 1474 for (@diag) {
735# load/save perl data associated with player->ob objects 1475 my $neigh = find @$_
736 1476 or next;
737sub all_objects(@) { 1477 $neigh->load;
738 @_, map all_objects ($_->inv), @_ 1478 }
739} 1479}
740 1480
741# TODO: compatibility cruft, remove when no longer needed 1481sub find_sync {
742cf::player->attach ( 1482 my ($path, $origin) = @_;
743 on_load => sub {
744 my ($pl, $path) = @_;
745 1483
746 for my $o (all_objects $pl->ob) { 1484 cf::sync_job { find $path, $origin }
747 if (my $value = $o->get_ob_key_value ("_perl_data")) { 1485}
748 $o->set_ob_key_value ("_perl_data");
749 1486
750 %$o = %{ Storable::thaw pack "H*", $value }; 1487sub do_load_sync {
1488 my ($map) = @_;
1489
1490 cf::sync_job { $map->load };
1491}
1492
1493our %MAP_PREFETCH;
1494our $MAP_PREFETCHER = undef;
1495
1496sub find_async {
1497 my ($path, $origin) = @_;
1498
1499 $path = normalise $path, $origin && $origin->{path};
1500
1501 if (my $map = $cf::MAP{$path}) {
1502 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1503 }
1504
1505 undef $MAP_PREFETCH{$path};
1506 $MAP_PREFETCHER ||= cf::async {
1507 while (%MAP_PREFETCH) {
1508 for my $path (keys %MAP_PREFETCH) {
1509 my $map = find $path
1510 or next;
1511 $map->load;
1512
1513 delete $MAP_PREFETCH{$path};
751 } 1514 }
752 } 1515 }
1516 undef $MAP_PREFETCHER;
1517 };
1518 $MAP_PREFETCHER->prio (6);
1519
1520 ()
1521}
1522
1523sub save {
1524 my ($self) = @_;
1525
1526 my $lock = cf::lock_acquire "map_data:" . $self->path;
1527
1528 $self->{last_save} = $cf::RUNTIME;
1529
1530 return unless $self->dirty;
1531
1532 my $save = $self->save_path; utf8::encode $save;
1533 my $uniq = $self->uniq_path; utf8::encode $uniq;
1534
1535 $self->{load_path} = $save;
1536
1537 return if $self->{deny_save};
1538
1539 local $self->{last_access} = $self->last_access;#d#
1540
1541 cf::async {
1542 $_->contr->save for $self->players;
1543 };
1544
1545 if ($uniq) {
1546 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1547 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1548 } else {
1549 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
753 }, 1550 }
754); 1551}
755 1552
756############################################################################# 1553sub swap_out {
1554 my ($self) = @_;
757 1555
758=head2 CORE EXTENSIONS 1556 # save first because save cedes
1557 $self->save;
759 1558
760Functions and methods that extend core crossfire objects. 1559 my $lock = cf::lock_acquire "map_data:" . $self->path;
761 1560
762=head3 cf::player 1561 return if $self->players;
1562 return if $self->in_memory != cf::MAP_IN_MEMORY;
1563 return if $self->{deny_save};
1564
1565 $self->clear;
1566 $self->in_memory (cf::MAP_SWAPPED);
1567}
1568
1569sub reset_at {
1570 my ($self) = @_;
1571
1572 # TODO: safety, remove and allow resettable per-player maps
1573 return 1e99 if $self->isa ("ext::map_per_player");#d#
1574 return 1e99 if $self->{deny_reset};
1575
1576 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1577 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1578
1579 $time + $to
1580}
1581
1582sub should_reset {
1583 my ($self) = @_;
1584
1585 $self->reset_at <= $cf::RUNTIME
1586}
1587
1588sub reset {
1589 my ($self) = @_;
1590
1591 my $lock = cf::lock_acquire "map_data:$self->{path}";
1592
1593 return if $self->players;
1594 return if $self->isa ("ext::map_per_player");#d#
1595
1596 warn "resetting map ", $self->path;#d#
1597
1598 $self->in_memory (cf::MAP_SWAPPED);
1599
1600 # need to save uniques path
1601 unless ($self->{deny_save}) {
1602 my $uniq = $self->uniq_path; utf8::encode $uniq;
1603
1604 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1605 if $uniq;
1606 }
1607
1608 delete $cf::MAP{$self->path};
1609
1610 $self->clear;
1611
1612 $_->clear_links_to ($self) for values %cf::MAP;
1613
1614 $self->unlink_save;
1615 $self->destroy;
1616}
1617
1618my $nuke_counter = "aaaa";
1619
1620sub nuke {
1621 my ($self) = @_;
1622
1623 delete $cf::MAP{$self->path};
1624
1625 $self->unlink_save;
1626
1627 bless $self, "cf::map";
1628 delete $self->{deny_reset};
1629 $self->{deny_save} = 1;
1630 $self->reset_timeout (1);
1631 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1632
1633 $cf::MAP{$self->path} = $self;
1634
1635 $self->reset; # polite request, might not happen
1636}
1637
1638=item cf::map::unique_maps
1639
1640Returns an arrayref of paths of all shared maps that have
1641instantiated unique items. May block.
1642
1643=cut
1644
1645sub unique_maps() {
1646 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1647 or return;
1648
1649 my @paths;
1650
1651 for (@$files) {
1652 utf8::decode $_;
1653 next if /\.pst$/;
1654 next unless /^$PATH_SEP/o;
1655
1656 push @paths, cf::map::normalise $_;
1657 }
1658
1659 \@paths
1660}
1661
1662package cf;
1663
1664=back
1665
1666=head3 cf::object
1667
1668=cut
1669
1670package cf::object;
763 1671
764=over 4 1672=over 4
765 1673
766=item cf::player::exists $login 1674=item $ob->inv_recursive
767 1675
768Returns true when the given account exists. 1676Returns the inventory of the object _and_ their inventories, recursively.
769 1677
770=cut 1678=cut
771 1679
772sub cf::player::exists($) { 1680sub inv_recursive_;
773 cf::player::find $_[0] 1681sub inv_recursive_ {
774 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 1682 map { $_, inv_recursive_ $_->inv } @_
775} 1683}
776 1684
777=item $player->ext_reply ($msgid, $msgtype, %msg) 1685sub inv_recursive {
778 1686 inv_recursive_ inv $_[0]
779Sends an ext reply to the player.
780
781=cut
782
783sub cf::player::ext_reply($$$%) {
784 my ($self, $id, %msg) = @_;
785
786 $msg{msgid} = $id;
787
788 $self->send ("ext " . to_json \%msg);
789} 1687}
1688
1689package cf;
790 1690
791=back 1691=back
792 1692
793=head3 cf::object::player 1693=head3 cf::object::player
794 1694
… …
832 (ref $cf::CFG{"may_$access"} 1732 (ref $cf::CFG{"may_$access"}
833 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 1733 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
834 : $cf::CFG{"may_$access"}) 1734 : $cf::CFG{"may_$access"})
835} 1735}
836 1736
1737=item $player_object->enter_link
1738
1739Freezes the player and moves him/her to a special map (C<{link}>).
1740
1741The player should be reasonably safe there for short amounts of time. You
1742I<MUST> call C<leave_link> as soon as possible, though.
1743
1744Will never block.
1745
1746=item $player_object->leave_link ($map, $x, $y)
1747
1748Moves the player out of the special C<{link}> map onto the specified
1749map. If the map is not valid (or omitted), the player will be moved back
1750to the location he/she was before the call to C<enter_link>, or, if that
1751fails, to the emergency map position.
1752
1753Might block.
1754
1755=cut
1756
1757sub link_map {
1758 unless ($LINK_MAP) {
1759 $LINK_MAP = cf::map::find "{link}"
1760 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1761 $LINK_MAP->load;
1762 }
1763
1764 $LINK_MAP
1765}
1766
1767sub cf::object::player::enter_link {
1768 my ($self) = @_;
1769
1770 $self->deactivate_recursive;
1771
1772 return if UNIVERSAL::isa $self->map, "ext::map_link";
1773
1774 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1775 if $self->map;
1776
1777 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1778}
1779
1780sub cf::object::player::leave_link {
1781 my ($self, $map, $x, $y) = @_;
1782
1783 my $link_pos = delete $self->{_link_pos};
1784
1785 unless ($map) {
1786 # restore original map position
1787 ($map, $x, $y) = @{ $link_pos || [] };
1788 $map = cf::map::find $map;
1789
1790 unless ($map) {
1791 ($map, $x, $y) = @$EMERGENCY_POSITION;
1792 $map = cf::map::find $map
1793 or die "FATAL: cannot load emergency map\n";
1794 }
1795 }
1796
1797 ($x, $y) = (-1, -1)
1798 unless (defined $x) && (defined $y);
1799
1800 # use -1 or undef as default coordinates, not 0, 0
1801 ($x, $y) = ($map->enter_x, $map->enter_y)
1802 if $x <=0 && $y <= 0;
1803
1804 $map->load;
1805 $map->load_diag;
1806
1807 return unless $self->contr->active;
1808 $self->activate_recursive;
1809
1810 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1811 $self->enter_map ($map, $x, $y);
1812}
1813
1814cf::player->attach (
1815 on_logout => sub {
1816 my ($pl) = @_;
1817
1818 # abort map switching before logout
1819 if ($pl->ob->{_link_pos}) {
1820 cf::sync_job {
1821 $pl->ob->leave_link
1822 };
1823 }
1824 },
1825 on_login => sub {
1826 my ($pl) = @_;
1827
1828 # try to abort aborted map switching on player login :)
1829 # should happen only on crashes
1830 if ($pl->ob->{_link_pos}) {
1831 $pl->ob->enter_link;
1832 (async {
1833 $pl->ob->reply (undef,
1834 "There was an internal problem at your last logout, "
1835 . "the server will try to bring you to your intended destination in a second.",
1836 cf::NDI_RED);
1837 # we need this sleep as the login has a concurrent enter_exit running
1838 # and this sleep increases chances of the player not ending up in scorn
1839 Coro::Timer::sleep 1;
1840 $pl->ob->leave_link;
1841 })->prio (2);
1842 }
1843 },
1844);
1845
1846=item $player_object->goto ($path, $x, $y)
1847
1848=cut
1849
1850sub cf::object::player::goto {
1851 my ($self, $path, $x, $y) = @_;
1852
1853 $self->enter_link;
1854
1855 (async {
1856 my $map = eval {
1857 my $map = cf::map::find $path;
1858 $map = $map->customise_for ($self) if $map;
1859 $map
1860 } or
1861 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1862
1863 $self->leave_link ($map, $x, $y);
1864 })->prio (1);
1865}
1866
1867=item $player_object->enter_exit ($exit_object)
1868
1869=cut
1870
1871sub parse_random_map_params {
1872 my ($spec) = @_;
1873
1874 my $rmp = { # defaults
1875 xsize => (cf::rndm 15, 40),
1876 ysize => (cf::rndm 15, 40),
1877 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
1878 #layout => string,
1879 };
1880
1881 for (split /\n/, $spec) {
1882 my ($k, $v) = split /\s+/, $_, 2;
1883
1884 $rmp->{lc $k} = $v if (length $k) && (length $v);
1885 }
1886
1887 $rmp
1888}
1889
1890sub prepare_random_map {
1891 my ($exit) = @_;
1892
1893 my $guard = cf::lock_acquire "exit_prepare:$exit";
1894
1895 # all this does is basically replace the /! path by
1896 # a new random map path (?random/...) with a seed
1897 # that depends on the exit object
1898
1899 my $rmp = parse_random_map_params $exit->msg;
1900
1901 if ($exit->map) {
1902 $rmp->{region} = $exit->region->name;
1903 $rmp->{origin_map} = $exit->map->path;
1904 $rmp->{origin_x} = $exit->x;
1905 $rmp->{origin_y} = $exit->y;
1906 }
1907
1908 $rmp->{random_seed} ||= $exit->random_seed;
1909
1910 my $data = cf::to_json $rmp;
1911 my $md5 = Digest::MD5::md5_hex $data;
1912 my $meta = "$cf::RANDOM_MAPS/$md5.meta";
1913
1914 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1915 aio_write $fh, 0, (length $data), $data, 0;
1916 undef $fh;
1917 aio_rename "$meta~", $meta;
1918
1919 $exit->slaying ("?random/$md5");
1920 $exit->msg (undef);
1921 }
1922}
1923
1924sub cf::object::player::enter_exit {
1925 my ($self, $exit) = @_;
1926
1927 return unless $self->type == cf::PLAYER;
1928
1929 if ($exit->slaying eq "/!") {
1930 #TODO: this should de-fi-ni-te-ly not be a sync-job
1931 cf::sync_job { prepare_random_map $exit };
1932 }
1933
1934 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1935 my $hp = $exit->stats->hp;
1936 my $sp = $exit->stats->sp;
1937
1938 $self->enter_link;
1939
1940 (async {
1941 $self->deactivate_recursive; # just to be sure
1942 unless (eval {
1943 $self->goto ($slaying, $hp, $sp);
1944
1945 1;
1946 }) {
1947 $self->message ("Something went wrong deep within the crossfire server. "
1948 . "I'll try to bring you back to the map you were before. "
1949 . "Please report this to the dungeon master!",
1950 cf::NDI_UNIQUE | cf::NDI_RED);
1951
1952 warn "ERROR in enter_exit: $@";
1953 $self->leave_link;
1954 }
1955 })->prio (1);
1956}
1957
837=head3 cf::client 1958=head3 cf::client
838 1959
839=over 4 1960=over 4
840 1961
841=item $client->send_drawinfo ($text, $flags) 1962=item $client->send_drawinfo ($text, $flags)
… …
884 on_reply => sub { 2005 on_reply => sub {
885 my ($ns, $msg) = @_; 2006 my ($ns, $msg) = @_;
886 2007
887 # this weird shuffling is so that direct followup queries 2008 # this weird shuffling is so that direct followup queries
888 # get handled first 2009 # get handled first
889 my $queue = delete $ns->{query_queue}; 2010 my $queue = delete $ns->{query_queue}
2011 or return; # be conservative, not sure how that can happen, but we saw a crash here
890 2012
891 (shift @$queue)->[1]->($msg); 2013 (shift @$queue)->[1]->($msg);
2014 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
892 2015
893 push @{ $ns->{query_queue} }, @$queue; 2016 push @{ $ns->{query_queue} }, @$queue;
894 2017
895 if (@{ $ns->{query_queue} } == @$queue) { 2018 if (@{ $ns->{query_queue} } == @$queue) {
896 if (@$queue) { 2019 if (@$queue) {
… …
900 } 2023 }
901 } 2024 }
902 }, 2025 },
903); 2026);
904 2027
905=item $client->coro (\&cb) 2028=item $client->async (\&cb)
906 2029
907Create a new coroutine, running the specified callback. The coroutine will 2030Create a new coroutine, running the specified callback. The coroutine will
908be automatically cancelled when the client gets destroyed (e.g. on logout, 2031be automatically cancelled when the client gets destroyed (e.g. on logout,
909or loss of connection). 2032or loss of connection).
910 2033
911=cut 2034=cut
912 2035
913sub cf::client::coro { 2036sub cf::client::async {
914 my ($self, $cb) = @_; 2037 my ($self, $cb) = @_;
915 2038
916 my $coro; $coro = async { 2039 my $coro = &Coro::async ($cb);
917 eval { 2040
918 $cb->(); 2041 $coro->on_destroy (sub {
919 };
920 warn $@ if $@;
921 delete $self->{_coro}{$coro+0}; 2042 delete $self->{_coro}{$coro+0};
922 }; 2043 });
923 2044
924 $self->{_coro}{$coro+0} = $coro; 2045 $self->{_coro}{$coro+0} = $coro;
2046
2047 $coro
925} 2048}
926 2049
927cf::client->attach ( 2050cf::client->attach (
928 on_destroy => sub { 2051 on_destroy => sub {
929 my ($ns) = @_; 2052 my ($ns) = @_;
… …
1057The parameter C<$family> should best start with the name of the extension 2180The parameter C<$family> should best start with the name of the extension
1058using it, it should be unique. 2181using it, it should be unique.
1059 2182
1060=over 4 2183=over 4
1061 2184
1062=item $hashref = cf::db_get $family
1063
1064Return a hashref for use by the extension C<$family>, which can be
1065modified. After modifications, you have to call C<cf::db_dirty> or
1066C<cf::db_sync>.
1067
1068=item $value = cf::db_get $family => $key 2185=item $value = cf::db_get $family => $key
1069 2186
1070Returns a single value from the database 2187Returns a single value from the database.
1071
1072=item cf::db_put $family => $hashref
1073
1074Stores the given family hashref into the database. Updates are delayed, if
1075you want the data to be synced to disk immediately, use C<cf::db_sync>.
1076 2188
1077=item cf::db_put $family => $key => $value 2189=item cf::db_put $family => $key => $value
1078 2190
1079Stores the given C<$value> in the family hash. Updates are delayed, if you 2191Stores the given C<$value> in the family.
1080want the data to be synced to disk immediately, use C<cf::db_sync>.
1081
1082=item cf::db_dirty
1083
1084Marks the database as dirty, to be updated at a later time.
1085
1086=item cf::db_sync
1087
1088Immediately write the database to disk I<if it is dirty>.
1089 2192
1090=cut 2193=cut
1091 2194
1092our $DB; 2195our $DB;
1093 2196
1094{ 2197sub db_init {
2198 unless ($DB) {
2199 $DB = BDB::db_create $DB_ENV;
2200
2201 cf::sync_job {
2202 eval {
2203 $DB->set_flags (BDB::CHKSUM);
2204
2205 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2206 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2207 cf::cleanup "db_open(db): $!" if $!;
2208 };
2209 cf::cleanup "db_open(db): $@" if $@;
2210 };
2211
1095 my $path = cf::localdir . "/database.pst"; 2212 my $path = cf::localdir . "/database.pst";
2213 if (stat $path) {
2214 cf::sync_job {
2215 my $pst = Storable::retrieve $path;
1096 2216
1097 sub db_load() { 2217 cf::db_put (board => data => $pst->{board});
1098 warn "loading database $path\n";#d# remove later 2218 cf::db_put (guildrules => data => $pst->{guildrules});
1099 $DB = stat $path ? Storable::retrieve $path : { }; 2219 cf::db_put (rent => balance => $pst->{rent}{balance});
1100 } 2220 BDB::db_env_txn_checkpoint $DB_ENV;
1101 2221
1102 my $pid; 2222 unlink $path;
1103
1104 sub db_save() {
1105 warn "saving database $path\n";#d# remove later
1106 waitpid $pid, 0 if $pid;
1107 if (0 == ($pid = fork)) {
1108 $DB->{_meta}{version} = 1;
1109 Storable::nstore $DB, "$path~";
1110 rename "$path~", $path;
1111 cf::_exit 0 if defined $pid;
1112 } 2223 };
1113 }
1114
1115 my $dirty;
1116
1117 sub db_sync() {
1118 db_save if $dirty;
1119 undef $dirty;
1120 }
1121
1122 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1123 db_sync;
1124 });
1125
1126 sub db_dirty() {
1127 $dirty = 1;
1128 $idle->start;
1129 }
1130
1131 sub db_get($;$) {
1132 @_ >= 2
1133 ? $DB->{$_[0]}{$_[1]}
1134 : ($DB->{$_[0]} ||= { })
1135 }
1136
1137 sub db_put($$;$) {
1138 if (@_ >= 3) {
1139 $DB->{$_[0]}{$_[1]} = $_[2];
1140 } else {
1141 $DB->{$_[0]} = $_[1];
1142 }
1143 db_dirty;
1144 }
1145
1146 cf::global->attach (
1147 prio => 10000,
1148 on_cleanup => sub {
1149 db_sync;
1150 }, 2224 }
1151 ); 2225 }
2226}
2227
2228sub db_get($$) {
2229 my $key = "$_[0]/$_[1]";
2230
2231 cf::sync_job {
2232 BDB::db_get $DB, undef, $key, my $data;
2233
2234 $! ? ()
2235 : Compress::LZF::sthaw $data
2236 }
2237}
2238
2239sub db_put($$$) {
2240 BDB::dbreq_pri 4;
2241 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
1152} 2242}
1153 2243
1154############################################################################# 2244#############################################################################
1155# the server's main() 2245# the server's init and main functions
2246
2247sub load_resources {
2248 load_regions sprintf "%s/%s/regions", cf::datadir, cf::mapdir
2249 or die "unable to load regions file\n";#d#
2250}
1156 2251
1157sub cfg_load { 2252sub cfg_load {
1158 open my $fh, "<:utf8", cf::confdir . "/config" 2253 open my $fh, "<:utf8", cf::confdir . "/config"
1159 or return; 2254 or return;
1160 2255
1161 local $/; 2256 local $/;
1162 *CFG = YAML::Syck::Load <$fh>; 2257 *CFG = YAML::Syck::Load <$fh>;
2258
2259 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2260
2261 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2262 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2263
2264 if (exists $CFG{mlockall}) {
2265 eval {
2266 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2267 and die "WARNING: m(un)lockall failed: $!\n";
2268 };
2269 warn $@ if $@;
2270 }
2271}
2272
2273sub init {
2274 load_resources;
1163} 2275}
1164 2276
1165sub main { 2277sub main {
2278 # we must not ever block the main coroutine
2279 local $Coro::idle = sub {
2280 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2281 (async {
2282 Event::one_event;
2283 })->prio (Coro::PRIO_MAX);
2284 };
2285
1166 cfg_load; 2286 cfg_load;
1167 db_load; 2287 db_init;
1168 load_extensions; 2288 load_extensions;
2289
2290 $TICK_WATCHER->start;
1169 Event::loop; 2291 Event::loop;
1170} 2292}
1171 2293
1172############################################################################# 2294#############################################################################
1173# initialisation 2295# initialisation and cleanup
1174 2296
2297# install some emergency cleanup handlers
2298BEGIN {
2299 for my $signal (qw(INT HUP TERM)) {
2300 Event->signal (
2301 reentrant => 0,
2302 data => WF_AUTOCANCEL,
2303 signal => $signal,
2304 prio => 0,
2305 cb => sub {
2306 cf::cleanup "SIG$signal";
2307 },
2308 );
2309 }
2310}
2311
2312sub emergency_save() {
2313 my $freeze_guard = cf::freeze_mainloop;
2314
2315 warn "enter emergency perl save\n";
2316
2317 cf::sync_job {
2318 # use a peculiar iteration method to avoid tripping on perl
2319 # refcount bugs in for. also avoids problems with players
2320 # and maps saved/destroyed asynchronously.
2321 warn "begin emergency player save\n";
2322 for my $login (keys %cf::PLAYER) {
2323 my $pl = $cf::PLAYER{$login} or next;
2324 $pl->valid or next;
2325 $pl->save;
2326 }
2327 warn "end emergency player save\n";
2328
2329 warn "begin emergency map save\n";
2330 for my $path (keys %cf::MAP) {
2331 my $map = $cf::MAP{$path} or next;
2332 $map->valid or next;
2333 $map->save;
2334 }
2335 warn "end emergency map save\n";
2336
2337 warn "begin emergency database checkpoint\n";
2338 BDB::db_env_txn_checkpoint $DB_ENV;
2339 warn "end emergency database checkpoint\n";
2340 };
2341
2342 warn "leave emergency perl save\n";
2343}
2344
2345sub post_cleanup {
2346 my ($make_core) = @_;
2347
2348 warn Carp::longmess "post_cleanup backtrace"
2349 if $make_core;
2350}
2351
1175sub _perl_reload(&) { 2352sub reload() {
1176 my ($msg) = @_; 2353 # can/must only be called in main
2354 if ($Coro::current != $Coro::main) {
2355 warn "can only reload from main coroutine";
2356 return;
2357 }
1177 2358
1178 $msg->("reloading..."); 2359 warn "reloading...";
1179 2360
1180 eval { 2361 warn "entering sync_job";
1181 # cancel all watchers 2362
2363 cf::sync_job {
2364 cf::write_runtime; # external watchdog should not bark
2365 cf::emergency_save;
2366 cf::write_runtime; # external watchdog should not bark
2367
2368 warn "syncing database to disk";
2369 BDB::db_env_txn_checkpoint $DB_ENV;
2370
2371 # if anything goes wrong in here, we should simply crash as we already saved
2372
2373 warn "cancelling all WF_AUTOCANCEL watchers";
1182 for (Event::all_watchers) { 2374 for (Event::all_watchers) {
1183 $_->cancel if $_->data & WF_AUTOCANCEL; 2375 $_->cancel if $_->data & WF_AUTOCANCEL;
1184 } 2376 }
1185 2377
1186 # unload all extensions 2378 warn "flushing outstanding aio requests";
1187 for (@exts) { 2379 for (;;) {
1188 $msg->("unloading <$_>"); 2380 BDB::flush;
1189 unload_extension $_; 2381 IO::AIO::flush;
2382 Coro::cede;
2383 last unless IO::AIO::nreqs || BDB::nreqs;
2384 warn "iterate...";
2385 }
2386
2387 warn "cancelling all extension coros";
2388 $_->cancel for values %EXT_CORO;
2389 %EXT_CORO = ();
2390
2391 warn "removing commands";
2392 %COMMAND = ();
2393
2394 warn "removing ext commands";
2395 %EXTCMD = ();
2396
2397 warn "unloading/nuking all extensions";
2398 for my $pkg (@EXTS) {
2399 warn "... unloading $pkg";
2400
2401 if (my $cb = $pkg->can ("unload")) {
2402 eval {
2403 $cb->($pkg);
2404 1
2405 } or warn "$pkg unloaded, but with errors: $@";
1190 } 2406 }
1191 2407
2408 warn "... nuking $pkg";
2409 Symbol::delete_package $pkg;
2410 }
2411
1192 # unload all modules loaded from $LIBDIR 2412 warn "unloading all perl modules loaded from $LIBDIR";
1193 while (my ($k, $v) = each %INC) { 2413 while (my ($k, $v) = each %INC) {
1194 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2414 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1195 2415
1196 $msg->("removing <$k>"); 2416 warn "... unloading $k";
1197 delete $INC{$k}; 2417 delete $INC{$k};
1198 2418
1199 $k =~ s/\.pm$//; 2419 $k =~ s/\.pm$//;
1200 $k =~ s/\//::/g; 2420 $k =~ s/\//::/g;
1201 2421
… …
1204 } 2424 }
1205 2425
1206 Symbol::delete_package $k; 2426 Symbol::delete_package $k;
1207 } 2427 }
1208 2428
1209 # sync database to disk
1210 cf::db_sync;
1211
1212 # get rid of safe::, as good as possible 2429 warn "getting rid of safe::, as good as possible";
1213 Symbol::delete_package "safe::$_" 2430 Symbol::delete_package "safe::$_"
1214 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region); 2431 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1215 2432
1216 # remove register_script_function callbacks
1217 # TODO
1218
1219 # unload cf.pm "a bit" 2433 warn "unloading cf.pm \"a bit\"";
1220 delete $INC{"cf.pm"}; 2434 delete $INC{"cf.pm"};
1221 2435
1222 # don't, removes xs symbols, too, 2436 # don't, removes xs symbols, too,
1223 # and global variables created in xs 2437 # and global variables created in xs
1224 #Symbol::delete_package __PACKAGE__; 2438 #Symbol::delete_package __PACKAGE__;
1225 2439
1226 # reload cf.pm 2440 warn "unload completed, starting to reload now";
2441
1227 $msg->("reloading cf.pm"); 2442 warn "reloading cf.pm";
1228 require cf; 2443 require cf;
1229 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2444 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1230 2445
1231 # load config and database again 2446 warn "loading config and database again";
1232 cf::cfg_load; 2447 cf::cfg_load;
1233 cf::db_load;
1234 2448
1235 # load extensions 2449 warn "loading extensions";
1236 $msg->("load extensions");
1237 cf::load_extensions; 2450 cf::load_extensions;
1238 2451
1239 # reattach attachments to objects 2452 warn "reattaching attachments to objects/players";
1240 $msg->("reattach");
1241 _global_reattach; 2453 _global_reattach;
2454 warn "reattaching attachments to maps";
2455 reattach $_ for values %MAP;
2456
2457 warn "loading reloadable resources";
2458 load_resources;
2459
2460 warn "leaving sync_job";
2461
2462 1
2463 } or do {
2464 warn $@;
2465 warn "error while reloading, exiting.";
2466 exit 1;
1242 }; 2467 };
1243 $msg->($@) if $@;
1244 2468
1245 $msg->("reloaded"); 2469 warn "reloaded";
1246}; 2470};
1247 2471
1248sub perl_reload() { 2472our $RELOAD_WATCHER; # used only during reload
1249 _perl_reload {
1250 warn $_[0];
1251 print "$_[0]\n";
1252 };
1253}
1254 2473
1255register "<global>", __PACKAGE__;
1256
1257register_command "perl-reload" => sub { 2474register_command "reload" => sub {
1258 my ($who, $arg) = @_; 2475 my ($who, $arg) = @_;
1259 2476
1260 if ($who->flag (FLAG_WIZ)) { 2477 if ($who->flag (FLAG_WIZ)) {
1261 _perl_reload { 2478 $who->message ("reloading server.");
1262 warn $_[0]; 2479
1263 $who->message ($_[0]); 2480 # doing reload synchronously and two reloads happen back-to-back,
2481 # coro crashes during coro_state_free->destroy here.
2482
2483 $RELOAD_WATCHER ||= Event->timer (
2484 reentrant => 0,
2485 after => 0,
2486 data => WF_AUTOCANCEL,
2487 cb => sub {
2488 reload;
2489 undef $RELOAD_WATCHER;
2490 },
1264 }; 2491 );
1265 } 2492 }
1266}; 2493};
1267 2494
1268unshift @INC, $LIBDIR; 2495unshift @INC, $LIBDIR;
1269 2496
2497my $bug_warning = 0;
2498
1270$TICK_WATCHER = Event->timer ( 2499$TICK_WATCHER = Event->timer (
2500 reentrant => 0,
2501 parked => 1,
1271 prio => 0, 2502 prio => 0,
1272 at => $NEXT_TICK || 1, 2503 at => $NEXT_TICK || $TICK,
1273 data => WF_AUTOCANCEL, 2504 data => WF_AUTOCANCEL,
1274 cb => sub { 2505 cb => sub {
2506 if ($Coro::current != $Coro::main) {
2507 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2508 unless ++$bug_warning > 10;
2509 return;
2510 }
2511
2512 $NOW = Event::time;
2513
1275 cf::server_tick; # one server iteration 2514 cf::server_tick; # one server iteration
1276 2515 $RUNTIME += $TICK;
1277 my $NOW = Event::time;
1278 $NEXT_TICK += $TICK; 2516 $NEXT_TICK += $TICK;
1279 2517
2518 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2519 $NEXT_RUNTIME_WRITE = $NOW + 10;
2520 Coro::async_pool {
2521 write_runtime
2522 or warn "ERROR: unable to write runtime file: $!";
2523 };
2524 }
2525
2526
2527 $WAIT_FOR_TICK->broadcast;
2528 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2529
2530# my $AFTER = Event::time;
2531# warn $AFTER - $NOW;#d#
2532
1280 # if we are delayed by four ticks or more, skip them all 2533 # if we are delayed by four ticks or more, skip them all
1281 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 2534 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1282 2535
1283 $TICK_WATCHER->at ($NEXT_TICK); 2536 $TICK_WATCHER->at ($NEXT_TICK);
1284 $TICK_WATCHER->start; 2537 $TICK_WATCHER->start;
1285 }, 2538 },
1286); 2539);
1287 2540
2541{
2542 BDB::max_poll_time $TICK * 0.1;
2543 $BDB_POLL_WATCHER = Event->io (
2544 reentrant => 0,
2545 fd => BDB::poll_fileno,
2546 poll => 'r',
2547 prio => 0,
2548 data => WF_AUTOCANCEL,
2549 cb => \&BDB::poll_cb,
2550 );
2551 BDB::min_parallel 8;
2552
2553 BDB::set_sync_prepare {
2554 my $status;
2555 my $current = $Coro::current;
2556 (
2557 sub {
2558 $status = $!;
2559 $current->ready; undef $current;
2560 },
2561 sub {
2562 Coro::schedule while defined $current;
2563 $! = $status;
2564 },
2565 )
2566 };
2567
2568 unless ($DB_ENV) {
2569 $DB_ENV = BDB::db_env_create;
2570
2571 cf::sync_job {
2572 eval {
2573 BDB::db_env_open
2574 $DB_ENV,
2575 $BDB_ENV_DIR,
2576 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2577 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2578 0666;
2579
2580 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!;
2581
2582 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2583 $DB_ENV->set_lk_detect;
2584 };
2585
2586 cf::cleanup "db_env_open(db): $@" if $@;
2587 };
2588 }
2589}
2590
2591{
2592 IO::AIO::min_parallel 8;
2593
2594 undef $Coro::AIO::WATCHER;
1288IO::AIO::max_poll_time $TICK * 0.2; 2595 IO::AIO::max_poll_time $TICK * 0.1;
1289 2596 $AIO_POLL_WATCHER = Event->io (
1290Event->io (fd => IO::AIO::poll_fileno, 2597 reentrant => 0,
1291 poll => 'r',
1292 prio => 5,
1293 data => WF_AUTOCANCEL, 2598 data => WF_AUTOCANCEL,
2599 fd => IO::AIO::poll_fileno,
2600 poll => 'r',
2601 prio => 6,
1294 cb => \&IO::AIO::poll_cb); 2602 cb => \&IO::AIO::poll_cb,
2603 );
2604}
2605
2606END { cf::emergency_save }
1295 2607
12961 26081
1297 2609

Diff Legend

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