ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cf.schmorp.de/server/lib/cf.pm
(Generate patch)

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

Diff Legend

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