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.403 by root, Mon Dec 17 07:09:18 2007 UTC vs.
Revision 1.440 by root, Mon Aug 11 23:23:41 2008 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>.
18#
19# The authors can be reached via e-mail to <support@deliantra.net>
20#
21
1package cf; 22package cf;
2 23
3use utf8; 24use utf8;
4use strict; 25use strict;
5 26
… …
10use Opcode; 31use Opcode;
11use Safe; 32use Safe;
12use Safe::Hole; 33use Safe::Hole;
13use Storable (); 34use Storable ();
14 35
15use Coro 4.32 (); 36use Coro ();
16use Coro::State; 37use Coro::State;
17use Coro::Handle; 38use Coro::Handle;
18use Coro::EV; 39use Coro::AnyEvent;
19use Coro::Timer; 40use Coro::Timer;
20use Coro::Signal; 41use Coro::Signal;
21use Coro::Semaphore; 42use Coro::Semaphore;
43use Coro::AnyEvent;
22use Coro::AIO; 44use Coro::AIO;
23use Coro::BDB; 45use Coro::BDB 1.6;
24use Coro::Storable; 46use Coro::Storable;
25use Coro::Util (); 47use Coro::Util ();
26 48
27use JSON::XS 2.01 (); 49use JSON::XS 2.01 ();
28use BDB (); 50use BDB ();
29use Data::Dumper; 51use Data::Dumper;
30use Digest::MD5; 52use Digest::MD5;
31use Fcntl; 53use Fcntl;
32use YAML::Syck (); 54use YAML ();
33use IO::AIO 2.51 (); 55use IO::AIO ();
34use Time::HiRes; 56use Time::HiRes;
35use Compress::LZF; 57use Compress::LZF;
36use Digest::MD5 (); 58use Digest::MD5 ();
59
60AnyEvent::detect;
37 61
38# configure various modules to our taste 62# configure various modules to our taste
39# 63#
40$Storable::canonical = 1; # reduce rsync transfers 64$Storable::canonical = 1; # reduce rsync transfers
41Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 65Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
42Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 66Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
43
44# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
45$YAML::Syck::ImplicitUnicode = 1;
46 67
47$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 68$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
48 69
49sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 70sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
50 71
… …
69our $TMPDIR = "$LOCALDIR/" . tmpdir; 90our $TMPDIR = "$LOCALDIR/" . tmpdir;
70our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 91our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
71our $PLAYERDIR = "$LOCALDIR/" . playerdir; 92our $PLAYERDIR = "$LOCALDIR/" . playerdir;
72our $RANDOMDIR = "$LOCALDIR/random"; 93our $RANDOMDIR = "$LOCALDIR/random";
73our $BDBDIR = "$LOCALDIR/db"; 94our $BDBDIR = "$LOCALDIR/db";
95our %RESOURCE;
74 96
75our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 97our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
76our $TICK_WATCHER;
77our $AIO_POLL_WATCHER;
78our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 98our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
79our $NEXT_TICK; 99our $NEXT_TICK;
80our $USE_FSYNC = 1; # use fsync to write maps - default off 100our $USE_FSYNC = 1; # use fsync to write maps - default off
81 101
82our $BDB_POLL_WATCHER;
83our $BDB_DEADLOCK_WATCHER; 102our $BDB_DEADLOCK_WATCHER;
84our $BDB_CHECKPOINT_WATCHER; 103our $BDB_CHECKPOINT_WATCHER;
85our $BDB_TRICKLE_WATCHER; 104our $BDB_TRICKLE_WATCHER;
86our $DB_ENV; 105our $DB_ENV;
87 106
… …
98# used to convert map paths into valid unix filenames by replacing / by ∕ 117# used to convert map paths into valid unix filenames by replacing / by ∕
99our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 118our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
100 119
101our $LOAD; # a number between 0 (idle) and 1 (too many objects) 120our $LOAD; # a number between 0 (idle) and 1 (too many objects)
102our $LOADAVG; # same thing, but with alpha-smoothing 121our $LOADAVG; # same thing, but with alpha-smoothing
122our $JITTER; # average jitter
103our $tick_start; # for load detecting purposes 123our $TICK_START; # for load detecting purposes
104 124
105binmode STDOUT; 125binmode STDOUT;
106binmode STDERR; 126binmode STDERR;
107 127
108# read virtual server time, if available 128# read virtual server time, if available
… …
192 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 212 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
193 213
194 LOG llevError, $msg; 214 LOG llevError, $msg;
195 }; 215 };
196} 216}
217
218$Coro::State::DIEHOOK = sub {
219 return unless $^S eq 0; # "eq", not "=="
220
221 if ($Coro::current == $Coro::main) {#d#
222 warn "DIEHOOK called in main context, Coro bug?\n";#d#
223 return;#d#
224 }#d#
225
226 # kill coroutine otherwise
227 warn Carp::longmess $_[0];
228 Coro::terminate
229};
230
231$SIG{__DIE__} = sub { }; #d#?
197 232
198@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 233@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
199@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 234@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
200@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 235@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
201@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 236@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
208for my $pkg (qw( 243for my $pkg (qw(
209 cf::global cf::attachable 244 cf::global cf::attachable
210 cf::object cf::object::player 245 cf::object cf::object::player
211 cf::client cf::player 246 cf::client cf::player
212 cf::arch cf::living 247 cf::arch cf::living
248 cf::map cf::mapspace
213 cf::map cf::party cf::region 249 cf::party cf::region
214)) { 250)) {
215 no strict 'refs'; 251 no strict 'refs';
216 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 252 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
217} 253}
218 254
… …
326 362
327 ! ! $LOCK{$key} 363 ! ! $LOCK{$key}
328} 364}
329 365
330sub freeze_mainloop { 366sub freeze_mainloop {
331 return unless $TICK_WATCHER->is_active; 367 tick_inhibit_inc;
332 368
333 my $guard = Coro::guard { 369 Coro::guard \&tick_inhibit_dec;
334 $TICK_WATCHER->start;
335 };
336 $TICK_WATCHER->stop;
337 $guard
338} 370}
339 371
340=item cf::periodic $interval, $cb 372=item cf::periodic $interval, $cb
341 373
342Like EV::periodic, but randomly selects a starting point so that the actions 374Like EV::periodic, but randomly selects a starting point so that the actions
… …
397 } 429 }
398 } 430 }
399}; 431};
400 432
401sub get_slot($;$$) { 433sub get_slot($;$$) {
434 return if tick_inhibit || $Coro::current == $Coro::main;
435
402 my ($time, $pri, $name) = @_; 436 my ($time, $pri, $name) = @_;
403 437
404 $time = $TICK * .6 if $time > $TICK * .6; 438 $time = $TICK * .6 if $time > $TICK * .6;
405 my $sig = new Coro::Signal; 439 my $sig = new Coro::Signal;
406 440
… …
443 # this is the main coro, too bad, we have to block 477 # this is the main coro, too bad, we have to block
444 # till the operation succeeds, freezing the server :/ 478 # till the operation succeeds, freezing the server :/
445 479
446 LOG llevError, Carp::longmess "sync job";#d# 480 LOG llevError, Carp::longmess "sync job";#d#
447 481
448 # TODO: use suspend/resume instead
449 # (but this is cancel-safe)
450 my $freeze_guard = freeze_mainloop; 482 my $freeze_guard = freeze_mainloop;
451 483
452 my $busy = 1; 484 my $busy = 1;
453 my @res; 485 my @res;
454 486
… …
465 } else { 497 } else {
466 EV::loop EV::LOOP_ONESHOT; 498 EV::loop EV::LOOP_ONESHOT;
467 } 499 }
468 } 500 }
469 501
470 $time = EV::time - $time; 502 my $time = EV::time - $time;
471 503
472 LOG llevError | logBacktrace, Carp::longmess "long sync job"
473 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
474
475 $tick_start += $time; # do not account sync jobs to server load 504 $TICK_START += $time; # do not account sync jobs to server load
476 505
477 wantarray ? @res : $res[0] 506 wantarray ? @res : $res[0]
478 } else { 507 } else {
479 # we are in another coroutine, how wonderful, everything just works 508 # we are in another coroutine, how wonderful, everything just works
480 509
… …
522 reset_signals; 551 reset_signals;
523 &$cb 552 &$cb
524 }, @args; 553 }, @args;
525 554
526 wantarray ? @res : $res[-1] 555 wantarray ? @res : $res[-1]
556}
557
558=item $coin = coin_from_name $name
559
560=cut
561
562our %coin_alias = (
563 "silver" => "silvercoin",
564 "silvercoin" => "silvercoin",
565 "silvercoins" => "silvercoin",
566 "gold" => "goldcoin",
567 "goldcoin" => "goldcoin",
568 "goldcoins" => "goldcoin",
569 "platinum" => "platinacoin",
570 "platinumcoin" => "platinacoin",
571 "platinumcoins" => "platinacoin",
572 "platina" => "platinacoin",
573 "platinacoin" => "platinacoin",
574 "platinacoins" => "platinacoin",
575 "royalty" => "royalty",
576 "royalties" => "royalty",
577);
578
579sub coin_from_name($) {
580 $coin_alias{$_[0]}
581 ? cf::arch::find $coin_alias{$_[0]}
582 : undef
527} 583}
528 584
529=item $value = cf::db_get $family => $key 585=item $value = cf::db_get $family => $key
530 586
531Returns a single value from the environment database. 587Returns a single value from the environment database.
… …
968 } 1024 }
969 1025
970 0 1026 0
971} 1027}
972 1028
973=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1029=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
974 1030
975=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1031=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
976 1032
977Generate an object-specific event with the given arguments. 1033Generate an object-specific event with the given arguments.
978 1034
… …
1087 utf8::decode (my $decname = $filename); 1143 utf8::decode (my $decname = $filename);
1088 warn sprintf "saving %s (%d,%d)\n", 1144 warn sprintf "saving %s (%d,%d)\n",
1089 $decname, length $$rdata, scalar @$objs; 1145 $decname, length $$rdata, scalar @$objs;
1090 1146
1091 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1147 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1092 chmod SAVE_MODE, $fh; 1148 aio_chmod $fh, SAVE_MODE;
1093 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1149 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1094 aio_fsync $fh if $cf::USE_FSYNC; 1150 aio_fsync $fh if $cf::USE_FSYNC;
1095 close $fh; 1151 aio_close $fh;
1096 1152
1097 if (@$objs) { 1153 if (@$objs) {
1098 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1154 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1099 chmod SAVE_MODE, $fh; 1155 aio_chmod $fh, SAVE_MODE;
1100 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1156 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1101 aio_write $fh, 0, (length $data), $data, 0; 1157 aio_write $fh, 0, (length $data), $data, 0;
1102 aio_fsync $fh if $cf::USE_FSYNC; 1158 aio_fsync $fh if $cf::USE_FSYNC;
1103 close $fh; 1159 aio_close $fh;
1104 aio_rename "$filename.pst~", "$filename.pst"; 1160 aio_rename "$filename.pst~", "$filename.pst";
1105 } 1161 }
1106 } else { 1162 } else {
1107 aio_unlink "$filename.pst"; 1163 aio_unlink "$filename.pst";
1108 } 1164 }
… …
1303 my $msg = $@ ? "$v->{path}: $@\n" 1359 my $msg = $@ ? "$v->{path}: $@\n"
1304 : "$v->{base}: extension inactive.\n"; 1360 : "$v->{base}: extension inactive.\n";
1305 1361
1306 if (exists $v->{meta}{mandatory}) { 1362 if (exists $v->{meta}{mandatory}) {
1307 warn $msg; 1363 warn $msg;
1308 warn "mandatory extension failed to load, exiting.\n"; 1364 cf::cleanup "mandatory extension failed to load, exiting.";
1309 exit 1;
1310 } 1365 }
1311 1366
1312 warn $msg; 1367 warn $msg;
1313 } 1368 }
1314 1369
… …
1403 my $f = new_from_file cf::object::thawer path $login 1458 my $f = new_from_file cf::object::thawer path $login
1404 or return; 1459 or return;
1405 1460
1406 my $pl = cf::player::load_pl $f 1461 my $pl = cf::player::load_pl $f
1407 or return; 1462 or return;
1463
1408 local $cf::PLAYER_LOADING{$login} = $pl; 1464 local $cf::PLAYER_LOADING{$login} = $pl;
1409 $f->resolve_delayed_derefs; 1465 $f->resolve_delayed_derefs;
1410 $cf::PLAYER{$login} = $pl 1466 $cf::PLAYER{$login} = $pl
1411 } 1467 }
1412 } 1468 }
… …
1422 1478
1423 return if $pl->{deny_save}; 1479 return if $pl->{deny_save};
1424 1480
1425 aio_mkdir playerdir $pl, 0770; 1481 aio_mkdir playerdir $pl, 0770;
1426 $pl->{last_save} = $cf::RUNTIME; 1482 $pl->{last_save} = $cf::RUNTIME;
1483
1484 cf::get_slot 0.01;
1427 1485
1428 $pl->save_pl ($path); 1486 $pl->save_pl ($path);
1429 cf::cede_to_tick; 1487 cf::cede_to_tick;
1430} 1488}
1431 1489
… …
1467 $pl->{deny_save} = 1; 1525 $pl->{deny_save} = 1;
1468 $pl->password ("*"); # this should lock out the player until we nuked the dir 1526 $pl->password ("*"); # this should lock out the player until we nuked the dir
1469 1527
1470 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1528 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1471 $pl->deactivate; 1529 $pl->deactivate;
1530 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1531 $pl->ob->check_score;
1472 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1532 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1473 $pl->ns->destroy if $pl->ns; 1533 $pl->ns->destroy if $pl->ns;
1474 1534
1475 my $path = playerdir $pl; 1535 my $path = playerdir $pl;
1476 my $temp = "$path~$cf::RUNTIME~deleting~"; 1536 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1515 1575
1516 for my $login (@$dirs) { 1576 for my $login (@$dirs) {
1517 my $path = path $login; 1577 my $path = path $login;
1518 1578
1519 # a .pst is a dead give-away for a valid player 1579 # a .pst is a dead give-away for a valid player
1520 unless (-e "$path.pst") { 1580 # if no pst file found, open and chekc for blocked users
1581 if (aio_stat "$path.pst") {
1521 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1582 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1522 aio_read $fh, 0, 512, my $buf, 0 or next; 1583 aio_read $fh, 0, 512, my $buf, 0 or next;
1523 $buf !~ /^password -------------$/m or next; # official not-valid tag 1584 $buf !~ /^password -------------$/m or next; # official not-valid tag
1524 } 1585 }
1525 1586
… …
1724our $MAX_RESET = 3600; 1785our $MAX_RESET = 3600;
1725our $DEFAULT_RESET = 3000; 1786our $DEFAULT_RESET = 3000;
1726 1787
1727sub generate_random_map { 1788sub generate_random_map {
1728 my ($self, $rmp) = @_; 1789 my ($self, $rmp) = @_;
1790
1791 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1792
1729 # mit "rum" bekleckern, nicht 1793 # mit "rum" bekleckern, nicht
1730 $self->_create_random_map ( 1794 $self->_create_random_map (
1731 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1795 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1732 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1796 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1733 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1797 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1855 1919
1856# the temporary/swap location 1920# the temporary/swap location
1857sub save_path { 1921sub save_path {
1858 my ($self) = @_; 1922 my ($self) = @_;
1859 1923
1860 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1924 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1861 "$TMPDIR/$path.map" 1925 "$TMPDIR/$path.map"
1862} 1926}
1863 1927
1864# the unique path, undef == no special unique path 1928# the unique path, undef == no special unique path
1865sub uniq_path { 1929sub uniq_path {
1866 my ($self) = @_; 1930 my ($self) = @_;
1867 1931
1868 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1932 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1869 "$UNIQUEDIR/$path" 1933 "$UNIQUEDIR/$path"
1870} 1934}
1871 1935
1872# and all this just because we cannot iterate over 1936# and all this just because we cannot iterate over
1873# all maps in C++... 1937# all maps in C++...
… …
1971 2035
1972 cf::lock_wait "map_data:$path";#d#remove 2036 cf::lock_wait "map_data:$path";#d#remove
1973 cf::lock_wait "map_find:$path"; 2037 cf::lock_wait "map_find:$path";
1974 2038
1975 $cf::MAP{$path} || do { 2039 $cf::MAP{$path} || do {
1976 my $guard1 = cf::lock_acquire "map_find:$path";
1977 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it 2040 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
2041 my $guard2 = cf::lock_acquire "map_find:$path";
1978 2042
1979 my $map = new_from_path cf::map $path 2043 my $map = new_from_path cf::map $path
1980 or return; 2044 or return;
1981 2045
1982 $map->{last_save} = $cf::RUNTIME; 2046 $map->{last_save} = $cf::RUNTIME;
… …
1985 or return; 2049 or return;
1986 2050
1987 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2051 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1988 # doing this can freeze the server in a sync job, obviously 2052 # doing this can freeze the server in a sync job, obviously
1989 #$cf::WAIT_FOR_TICK->wait; 2053 #$cf::WAIT_FOR_TICK->wait;
2054 undef $guard2;
1990 undef $guard1; 2055 undef $guard1;
1991 undef $guard2;
1992 $map->reset; 2056 $map->reset;
1993 return find $path; 2057 return find $path;
1994 } 2058 }
1995 2059
1996 $cf::MAP{$path} = $map 2060 $cf::MAP{$path} = $map
… …
2023 my $f = new_from_file cf::object::thawer $self->{load_path}; 2087 my $f = new_from_file cf::object::thawer $self->{load_path};
2024 $f->skip_block; 2088 $f->skip_block;
2025 $self->_load_objects ($f) 2089 $self->_load_objects ($f)
2026 or return; 2090 or return;
2027 2091
2028 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2092 $self->post_load_original
2029 if delete $self->{load_original}; 2093 if delete $self->{load_original};
2030 2094
2031 if (my $uniq = $self->uniq_path) { 2095 if (my $uniq = $self->uniq_path) {
2032 utf8::encode $uniq; 2096 utf8::encode $uniq;
2033 unless (aio_stat $uniq) { 2097 unless (aio_stat $uniq) {
… …
2059 } 2123 }
2060 2124
2061 $self->{last_save} = $cf::RUNTIME; 2125 $self->{last_save} = $cf::RUNTIME;
2062 $self->last_access ($cf::RUNTIME); 2126 $self->last_access ($cf::RUNTIME);
2063 2127
2064 $self->in_memory (cf::MAP_IN_MEMORY); 2128 $self->in_memory (cf::MAP_ACTIVE);
2065 } 2129 }
2066 2130
2067 $self->post_load; 2131 $self->post_load;
2068} 2132}
2069 2133
… …
2127 my ($path, $origin, $load) = @_; 2191 my ($path, $origin, $load) = @_;
2128 2192
2129 $path = normalise $path, $origin && $origin->{path}; 2193 $path = normalise $path, $origin && $origin->{path};
2130 2194
2131 if (my $map = $cf::MAP{$path}) { 2195 if (my $map = $cf::MAP{$path}) {
2132 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2196 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2133 } 2197 }
2134 2198
2135 $MAP_PREFETCH{$path} |= $load; 2199 $MAP_PREFETCH{$path} |= $load;
2136 2200
2137 $MAP_PREFETCHER ||= cf::async { 2201 $MAP_PREFETCHER ||= cf::async {
… …
2174 cf::async { 2238 cf::async {
2175 $Coro::current->{desc} = "map player save"; 2239 $Coro::current->{desc} = "map player save";
2176 $_->contr->save for $self->players; 2240 $_->contr->save for $self->players;
2177 }; 2241 };
2178 2242
2243 cf::get_slot 0.02;
2244
2179 if ($uniq) { 2245 if ($uniq) {
2180 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2246 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2181 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2247 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2182 } else { 2248 } else {
2183 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2249 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
… …
2191 $self->save; 2257 $self->save;
2192 2258
2193 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2259 my $lock = cf::lock_acquire "map_data:$self->{path}";
2194 2260
2195 return if $self->players; 2261 return if $self->players;
2196 return if $self->in_memory != cf::MAP_IN_MEMORY; 2262 return if $self->in_memory != cf::MAP_ACTIVE;
2197 return if $self->{deny_save}; 2263 return if $self->{deny_save};
2198 2264
2199 $self->in_memory (cf::MAP_SWAPPED); 2265 $self->in_memory (cf::MAP_SWAPPED);
2200 2266
2201 $self->deactivate; 2267 $self->deactivate;
… …
2319 2385
2320sub unique_maps() { 2386sub unique_maps() {
2321 [ 2387 [
2322 map { 2388 map {
2323 utf8::decode $_; 2389 utf8::decode $_;
2324 /\.map$/ 2390 s/\.map$//; # TODO future compatibility hack
2391 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2392 ? ()
2325 ? normalise $_ 2393 : normalise $_
2326 : ()
2327 } @{ aio_readdir $UNIQUEDIR or [] } 2394 } @{ aio_readdir $UNIQUEDIR or [] }
2328 ] 2395 ]
2329} 2396}
2330 2397
2331package cf;
2332
2333=back 2398=back
2334 2399
2335=head3 cf::object 2400=head3 cf::object
2336 2401
2337=cut 2402=cut
… …
2340 2405
2341=over 4 2406=over 4
2342 2407
2343=item $ob->inv_recursive 2408=item $ob->inv_recursive
2344 2409
2345Returns the inventory of the object _and_ their inventories, recursively. 2410Returns the inventory of the object I<and> their inventories, recursively,
2411but I<not> the object itself.
2346 2412
2347=cut 2413=cut
2348 2414
2349sub inv_recursive_; 2415sub inv_recursive_;
2350sub inv_recursive_ { 2416sub inv_recursive_ {
… …
2355 inv_recursive_ inv $_[0] 2421 inv_recursive_ inv $_[0]
2356} 2422}
2357 2423
2358=item $ref = $ob->ref 2424=item $ref = $ob->ref
2359 2425
2360creates and returns a persistent reference to an objetc that can be stored as a string. 2426Creates and returns a persistent reference to an object that can be stored as a string.
2361 2427
2362=item $ob = cf::object::deref ($refstring) 2428=item $ob = cf::object::deref ($refstring)
2363 2429
2364returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2430returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2365even if the object actually exists. May block. 2431even if the object actually exists. May block.
… …
2397can be C<undef>. Does the right thing when the player is currently in a 2463can be C<undef>. Does the right thing when the player is currently in a
2398dialogue with the given NPC character. 2464dialogue with the given NPC character.
2399 2465
2400=cut 2466=cut
2401 2467
2468our $SAY_CHANNEL = {
2469 id => "say",
2470 title => "Map",
2471 reply => "say ",
2472 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2473};
2474
2475our $CHAT_CHANNEL = {
2476 id => "chat",
2477 title => "Chat",
2478 reply => "chat ",
2479 tooltip => "Player chat and shouts, global to the server.",
2480};
2481
2402# rough implementation of a future "reply" method that works 2482# rough implementation of a future "reply" method that works
2403# with dialog boxes. 2483# with dialog boxes.
2404#TODO: the first argument must go, split into a $npc->reply_to ( method 2484#TODO: the first argument must go, split into a $npc->reply_to ( method
2405sub cf::object::player::reply($$$;$) { 2485sub cf::object::player::reply($$$;$) {
2406 my ($self, $npc, $msg, $flags) = @_; 2486 my ($self, $npc, $msg, $flags) = @_;
… …
2417 my $dialog = $pl->{npc_dialog}; 2497 my $dialog = $pl->{npc_dialog};
2418 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2498 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2419 2499
2420 } else { 2500 } else {
2421 $msg = $npc->name . " says: $msg" if $npc; 2501 $msg = $npc->name . " says: $msg" if $npc;
2422 $self->message ($msg, $flags); 2502 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2423 } 2503 }
2424 } 2504 }
2425} 2505}
2426 2506
2427=item $object->send_msg ($channel, $msg, $color, [extra...]) 2507=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2534Moves the player to the given map-path and coordinates by first freezing 2614Moves the player to the given map-path and coordinates by first freezing
2535her, loading and preparing them map, calling the provided $check callback 2615her, loading and preparing them map, calling the provided $check callback
2536that has to return the map if sucecssful, and then unfreezes the player on 2616that has to return the map if sucecssful, and then unfreezes the player on
2537the new (success) or old (failed) map position. In either case, $done will 2617the new (success) or old (failed) map position. In either case, $done will
2538be called at the end of this process. 2618be called at the end of this process.
2619
2620Note that $check will be called with a potentially non-loaded map, so if
2621it needs a loaded map it has to call C<< ->load >>.
2539 2622
2540=cut 2623=cut
2541 2624
2542our $GOTOGEN; 2625our $GOTOGEN;
2543 2626
… …
2622} 2705}
2623 2706
2624sub prepare_random_map { 2707sub prepare_random_map {
2625 my ($exit) = @_; 2708 my ($exit) = @_;
2626 2709
2627 my $guard = cf::lock_acquire "exit_prepare:$exit";
2628
2629 # all this does is basically replace the /! path by 2710 # all this does is basically replace the /! path by
2630 # a new random map path (?random/...) with a seed 2711 # a new random map path (?random/...) with a seed
2631 # that depends on the exit object 2712 # that depends on the exit object
2632 2713
2633 my $rmp = parse_random_map_params $exit->msg; 2714 my $rmp = parse_random_map_params $exit->msg;
… …
2635 if ($exit->map) { 2716 if ($exit->map) {
2636 $rmp->{region} = $exit->region->name; 2717 $rmp->{region} = $exit->region->name;
2637 $rmp->{origin_map} = $exit->map->path; 2718 $rmp->{origin_map} = $exit->map->path;
2638 $rmp->{origin_x} = $exit->x; 2719 $rmp->{origin_x} = $exit->x;
2639 $rmp->{origin_y} = $exit->y; 2720 $rmp->{origin_y} = $exit->y;
2721
2722 $exit->map->touch;
2640 } 2723 }
2641 2724
2642 $rmp->{random_seed} ||= $exit->random_seed; 2725 $rmp->{random_seed} ||= $exit->random_seed;
2643 2726
2644 my $data = cf::encode_json $rmp; 2727 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2645 my $md5 = Digest::MD5::md5_hex $data; 2728 my $md5 = Digest::MD5::md5_hex $data;
2646 my $meta = "$RANDOMDIR/$md5.meta"; 2729 my $meta = "$RANDOMDIR/$md5.meta";
2647 2730
2648 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2731 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2649 aio_write $fh, 0, (length $data), $data, 0; 2732 aio_write $fh, 0, (length $data), $data, 0;
2650 undef $fh; 2733 undef $fh;
2651 aio_rename "$meta~", $meta; 2734 aio_rename "$meta~", $meta;
2652 2735
2736 my $slaying = "?random/$md5";
2737
2738 if ($exit->valid) {
2653 $exit->slaying ("?random/$md5"); 2739 $exit->slaying ("?random/$md5");
2654 $exit->msg (undef); 2740 $exit->msg (undef);
2741 }
2655 } 2742 }
2656} 2743}
2657 2744
2658sub cf::object::player::enter_exit { 2745sub cf::object::player::enter_exit {
2659 my ($self, $exit) = @_; 2746 my ($self, $exit) = @_;
2660 2747
2661 return unless $self->type == cf::PLAYER; 2748 return unless $self->type == cf::PLAYER;
2662 2749
2663 if ($exit->slaying eq "/!") {
2664 #TODO: this should de-fi-ni-te-ly not be a sync-job
2665 # the problem is that $exit might not survive long enough
2666 # so it needs to be done right now, right here
2667 cf::sync_job { prepare_random_map $exit };
2668 }
2669
2670 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2671 my $hp = $exit->stats->hp;
2672 my $sp = $exit->stats->sp;
2673
2674 $self->enter_link; 2750 $self->enter_link;
2675 2751
2676 # if exit is damned, update players death & WoR home-position
2677 $self->contr->savebed ($slaying, $hp, $sp)
2678 if $exit->flag (FLAG_DAMNED);
2679
2680 (async { 2752 (async {
2681 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2753 $Coro::current->{desc} = "enter_exit";
2682 2754
2683 $self->deactivate_recursive; # just to be sure
2684 unless (eval { 2755 unless (eval {
2756 $self->deactivate_recursive; # just to be sure
2757
2758 # random map handling
2759 {
2760 my $guard = cf::lock_acquire "exit_prepare:$exit";
2761
2762 prepare_random_map $exit
2763 if $exit->slaying eq "/!";
2764 }
2765
2766 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2767 my $x = $exit->stats->hp;
2768 my $y = $exit->stats->sp;
2769
2685 $self->goto ($slaying, $hp, $sp); 2770 $self->goto ($map, $x, $y);
2686 2771
2772 # if exit is damned, update players death & WoR home-position
2773 $self->contr->savebed ($map, $x, $y)
2774 if $exit->flag (cf::FLAG_DAMNED);
2775
2687 1; 2776 1
2688 }) { 2777 }) {
2689 $self->message ("Something went wrong deep within the crossfire server. " 2778 $self->message ("Something went wrong deep within the crossfire server. "
2690 . "I'll try to bring you back to the map you were before. " 2779 . "I'll try to bring you back to the map you were before. "
2691 . "Please report this to the dungeon master!", 2780 . "Please report this to the dungeon master!",
2692 cf::NDI_UNIQUE | cf::NDI_RED); 2781 cf::NDI_UNIQUE | cf::NDI_RED);
… …
2772 id => "infobox", 2861 id => "infobox",
2773 title => "Map Info", 2862 title => "Map Info",
2774 reply => undef, 2863 reply => undef,
2775 tooltip => "Information related to the maps", 2864 tooltip => "Information related to the maps",
2776 }, 2865 },
2866 "c/party" => {
2867 id => "party",
2868 title => "Party",
2869 reply => "gsay ",
2870 tooltip => "Messages and chat related to your party",
2871 },
2777); 2872);
2778 2873
2779sub cf::client::send_msg { 2874sub cf::client::send_msg {
2780 my ($self, $channel, $msg, $color, @extra) = @_; 2875 my ($self, $channel, $msg, $color, @extra) = @_;
2781 2876
… …
3018 3113
3019The following functions and methods are available within a safe environment: 3114The following functions and methods are available within a safe environment:
3020 3115
3021 cf::object 3116 cf::object
3022 contr pay_amount pay_player map x y force_find force_add destroy 3117 contr pay_amount pay_player map x y force_find force_add destroy
3023 insert remove name archname title slaying race decrease_ob_nr 3118 insert remove name archname title slaying race decrease split
3024 3119
3025 cf::object::player 3120 cf::object::player
3026 player 3121 player
3027 3122
3028 cf::player 3123 cf::player
… …
3033 3128
3034=cut 3129=cut
3035 3130
3036for ( 3131for (
3037 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3132 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3038 insert remove inv name archname title slaying race 3133 insert remove inv nrof name archname title slaying race
3039 decrease_ob_nr destroy)], 3134 decrease split destroy change_exp)],
3040 ["cf::object::player" => qw(player)], 3135 ["cf::object::player" => qw(player)],
3041 ["cf::player" => qw(peaceful)], 3136 ["cf::player" => qw(peaceful)],
3042 ["cf::map" => qw(trigger)], 3137 ["cf::map" => qw(trigger)],
3043) { 3138) {
3044 no strict 'refs'; 3139 no strict 'refs';
… …
3149 { 3244 {
3150 my $faces = $facedata->{faceinfo}; 3245 my $faces = $facedata->{faceinfo};
3151 3246
3152 while (my ($face, $info) = each %$faces) { 3247 while (my ($face, $info) = each %$faces) {
3153 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3248 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3249
3154 cf::face::set_visibility $idx, $info->{visibility}; 3250 cf::face::set_visibility $idx, $info->{visibility};
3155 cf::face::set_magicmap $idx, $info->{magicmap}; 3251 cf::face::set_magicmap $idx, $info->{magicmap};
3156 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3252 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3157 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3253 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3158 3254
3159 cf::cede_to_tick; 3255 cf::cede_to_tick;
3160 } 3256 }
3161 3257
3162 while (my ($face, $info) = each %$faces) { 3258 while (my ($face, $info) = each %$faces) {
3163 next unless $info->{smooth}; 3259 next unless $info->{smooth};
3260
3164 my $idx = cf::face::find $face 3261 my $idx = cf::face::find $face
3165 or next; 3262 or next;
3263
3166 if (my $smooth = cf::face::find $info->{smooth}) { 3264 if (my $smooth = cf::face::find $info->{smooth}) {
3167 cf::face::set_smooth $idx, $smooth; 3265 cf::face::set_smooth $idx, $smooth;
3168 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3266 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3169 } else { 3267 } else {
3170 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3268 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
3188 { 3286 {
3189 # TODO: for gcfclient pleasure, we should give resources 3287 # TODO: for gcfclient pleasure, we should give resources
3190 # that gcfclient doesn't grok a >10000 face index. 3288 # that gcfclient doesn't grok a >10000 face index.
3191 my $res = $facedata->{resource}; 3289 my $res = $facedata->{resource};
3192 3290
3193 my $soundconf = delete $res->{"res/sound.conf"};
3194
3195 while (my ($name, $info) = each %$res) { 3291 while (my ($name, $info) = each %$res) {
3292 if (defined $info->{type}) {
3196 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3293 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3197 my $data; 3294 my $data;
3198 3295
3199 if ($info->{type} & 1) { 3296 if ($info->{type} & 1) {
3200 # prepend meta info 3297 # prepend meta info
3201 3298
3202 my $meta = $enc->encode ({ 3299 my $meta = $enc->encode ({
3203 name => $name, 3300 name => $name,
3204 %{ $info->{meta} || {} }, 3301 %{ $info->{meta} || {} },
3205 }); 3302 });
3206 3303
3207 $data = pack "(w/a*)*", $meta, $info->{data}; 3304 $data = pack "(w/a*)*", $meta, $info->{data};
3305 } else {
3306 $data = $info->{data};
3307 }
3308
3309 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3310 cf::face::set_type $idx, $info->{type};
3208 } else { 3311 } else {
3209 $data = $info->{data}; 3312 $RESOURCE{$name} = $info;
3210 } 3313 }
3211 3314
3212 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3213 cf::face::set_type $idx, $info->{type};
3214
3215 cf::cede_to_tick; 3315 cf::cede_to_tick;
3216 } 3316 }
3217
3218 if ($soundconf) {
3219 $soundconf = $enc->decode (delete $soundconf->{data});
3220
3221 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3222 my $sound = $soundconf->{compat}[$_]
3223 or next;
3224
3225 my $face = cf::face::find "sound/$sound->[1]";
3226 cf::sound::set $sound->[0] => $face;
3227 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3228 }
3229
3230 while (my ($k, $v) = each %{$soundconf->{event}}) {
3231 my $face = cf::face::find "sound/$v";
3232 cf::sound::set $k => $face;
3233 }
3234 }
3235 } 3317 }
3318
3319 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3236 3320
3237 1 3321 1
3238} 3322}
3323
3324cf::global->attach (on_resource_update => sub {
3325 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3326 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3327
3328 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3329 my $sound = $soundconf->{compat}[$_]
3330 or next;
3331
3332 my $face = cf::face::find "sound/$sound->[1]";
3333 cf::sound::set $sound->[0] => $face;
3334 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3335 }
3336
3337 while (my ($k, $v) = each %{$soundconf->{event}}) {
3338 my $face = cf::face::find "sound/$v";
3339 cf::sound::set $k => $face;
3340 }
3341 }
3342});
3239 3343
3240register_exticmd fx_want => sub { 3344register_exticmd fx_want => sub {
3241 my ($ns, $want) = @_; 3345 my ($ns, $want) = @_;
3242 3346
3243 while (my ($k, $v) = each %$want) { 3347 while (my ($k, $v) = each %$want) {
3244 $ns->fx_want ($k, $v); 3348 $ns->fx_want ($k, $v);
3245 } 3349 }
3246}; 3350};
3351
3352sub load_resource_file($) {
3353 my $guard = lock_acquire "load_resource_file";
3354
3355 my $status = load_resource_file_ $_[0];
3356 get_slot 0.1, 100;
3357 cf::arch::commit_load;
3358
3359 $status
3360}
3247 3361
3248sub reload_regions { 3362sub reload_regions {
3249 # HACK to clear player env face cache, we need some signal framework 3363 # HACK to clear player env face cache, we need some signal framework
3250 # for this (global event?) 3364 # for this (global event?)
3251 %ext::player_env::MUSIC_FACE_CACHE = (); 3365 %ext::player_env::MUSIC_FACE_CACHE = ();
… …
3265} 3379}
3266 3380
3267sub reload_archetypes { 3381sub reload_archetypes {
3268 load_resource_file "$DATADIR/archetypes" 3382 load_resource_file "$DATADIR/archetypes"
3269 or die "unable to load archetypes\n"; 3383 or die "unable to load archetypes\n";
3270 #d# NEED to laod twice to resolve forward references
3271 # this really needs to be done in an extra post-pass
3272 # (which needs to be synchronous, so solve it differently)
3273 load_resource_file "$DATADIR/archetypes"
3274 or die "unable to load archetypes\n";
3275} 3384}
3276 3385
3277sub reload_treasures { 3386sub reload_treasures {
3278 load_resource_file "$DATADIR/treasures" 3387 load_resource_file "$DATADIR/treasures"
3279 or die "unable to load treasurelists\n"; 3388 or die "unable to load treasurelists\n";
3280} 3389}
3281 3390
3282sub reload_resources { 3391sub reload_resources {
3283 warn "reloading resource files...\n"; 3392 warn "reloading resource files...\n";
3284 3393
3394 reload_facedata;
3395 reload_archetypes;
3285 reload_regions; 3396 reload_regions;
3286 reload_facedata;
3287 #reload_archetypes;#d#
3288 reload_archetypes;
3289 reload_treasures; 3397 reload_treasures;
3290 3398
3291 warn "finished reloading resource files\n"; 3399 warn "finished reloading resource files\n";
3292} 3400}
3293 3401
3294sub init { 3402sub init {
3403 my $guard = freeze_mainloop;
3404
3405 evthread_start IO::AIO::poll_fileno;
3406
3295 reload_resources; 3407 reload_resources;
3296} 3408}
3297 3409
3298sub reload_config { 3410sub reload_config {
3299 open my $fh, "<:utf8", "$CONFDIR/config" 3411 open my $fh, "<:utf8", "$CONFDIR/config"
3300 or return; 3412 or return;
3301 3413
3302 local $/; 3414 local $/;
3303 *CFG = YAML::Syck::Load <$fh>; 3415 *CFG = YAML::Load <$fh>;
3304 3416
3305 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3417 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3306 3418
3307 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3419 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3308 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3420 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3324 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3436 $Coro::current->{desc} = "IDLE BUG HANDLER";
3325 EV::loop EV::LOOP_ONESHOT; 3437 EV::loop EV::LOOP_ONESHOT;
3326 })->prio (Coro::PRIO_MAX); 3438 })->prio (Coro::PRIO_MAX);
3327 }; 3439 };
3328 3440
3441 {
3442 my $guard = freeze_mainloop;
3329 reload_config; 3443 reload_config;
3330 db_init; 3444 db_init;
3331 load_extensions; 3445 load_extensions;
3332 3446
3333 $TICK_WATCHER->start;
3334 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3447 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3448 }
3449
3335 EV::loop; 3450 EV::loop;
3336} 3451}
3337 3452
3338############################################################################# 3453#############################################################################
3339# initialisation and cleanup 3454# initialisation and cleanup
… …
3346 cf::cleanup "SIG$signal"; 3461 cf::cleanup "SIG$signal";
3347 }; 3462 };
3348 } 3463 }
3349} 3464}
3350 3465
3351sub write_runtime { 3466sub write_runtime_sync {
3352 my $runtime = "$LOCALDIR/runtime"; 3467 my $runtime = "$LOCALDIR/runtime";
3353 3468
3354 # first touch the runtime file to show we are still running: 3469 # first touch the runtime file to show we are still running:
3355 # the fsync below can take a very very long time. 3470 # the fsync below can take a very very long time.
3356 3471
… …
3382 and return; 3497 and return;
3383 3498
3384 warn "runtime file written.\n"; 3499 warn "runtime file written.\n";
3385 3500
3386 1 3501 1
3502}
3503
3504our $uuid_lock;
3505our $uuid_skip;
3506
3507sub write_uuid_sync($) {
3508 $uuid_skip ||= $_[0];
3509
3510 return if $uuid_lock;
3511 local $uuid_lock = 1;
3512
3513 my $uuid = "$LOCALDIR/uuid";
3514
3515 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3516 or return;
3517
3518 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3519 $uuid_skip = 0;
3520
3521 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3522 and return;
3523
3524 # always fsync - this file is important
3525 aio_fsync $fh
3526 and return;
3527
3528 close $fh
3529 or return;
3530
3531 aio_rename "$uuid~", $uuid
3532 and return;
3533
3534 warn "uuid file written ($value).\n";
3535
3536 1
3537
3538}
3539
3540sub write_uuid($$) {
3541 my ($skip, $sync) = @_;
3542
3543 $sync ? write_uuid_sync $skip
3544 : async { write_uuid_sync $skip };
3387} 3545}
3388 3546
3389sub emergency_save() { 3547sub emergency_save() {
3390 my $freeze_guard = cf::freeze_mainloop; 3548 my $freeze_guard = cf::freeze_mainloop;
3391 3549
… …
3413 warn "end emergency map save\n"; 3571 warn "end emergency map save\n";
3414 3572
3415 warn "begin emergency database checkpoint\n"; 3573 warn "begin emergency database checkpoint\n";
3416 BDB::db_env_txn_checkpoint $DB_ENV; 3574 BDB::db_env_txn_checkpoint $DB_ENV;
3417 warn "end emergency database checkpoint\n"; 3575 warn "end emergency database checkpoint\n";
3576
3577 warn "begin write uuid\n";
3578 write_uuid_sync 1;
3579 warn "end write uuid\n";
3418 }; 3580 };
3419 3581
3420 warn "leave emergency perl save\n"; 3582 warn "leave emergency perl save\n";
3421} 3583}
3422 3584
… …
3437 warn "reloading..."; 3599 warn "reloading...";
3438 3600
3439 warn "entering sync_job"; 3601 warn "entering sync_job";
3440 3602
3441 cf::sync_job { 3603 cf::sync_job {
3442 cf::write_runtime; # external watchdog should not bark 3604 cf::write_runtime_sync; # external watchdog should not bark
3443 cf::emergency_save; 3605 cf::emergency_save;
3444 cf::write_runtime; # external watchdog should not bark 3606 cf::write_runtime_sync; # external watchdog should not bark
3445 3607
3446 warn "syncing database to disk"; 3608 warn "syncing database to disk";
3447 BDB::db_env_txn_checkpoint $DB_ENV; 3609 BDB::db_env_txn_checkpoint $DB_ENV;
3448 3610
3449 # if anything goes wrong in here, we should simply crash as we already saved 3611 # if anything goes wrong in here, we should simply crash as we already saved
… …
3536 warn "leaving sync_job"; 3698 warn "leaving sync_job";
3537 3699
3538 1 3700 1
3539 } or do { 3701 } or do {
3540 warn $@; 3702 warn $@;
3541 warn "error while reloading, exiting."; 3703 cf::cleanup "error while reloading, exiting.";
3542 exit 1;
3543 }; 3704 };
3544 3705
3545 warn "reloaded"; 3706 warn "reloaded";
3546}; 3707};
3547 3708
… …
3550sub reload_perl() { 3711sub reload_perl() {
3551 # doing reload synchronously and two reloads happen back-to-back, 3712 # doing reload synchronously and two reloads happen back-to-back,
3552 # coro crashes during coro_state_free->destroy here. 3713 # coro crashes during coro_state_free->destroy here.
3553 3714
3554 $RELOAD_WATCHER ||= EV::timer 0, 0, sub { 3715 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3716 do_reload_perl;
3555 undef $RELOAD_WATCHER; 3717 undef $RELOAD_WATCHER;
3556 do_reload_perl;
3557 }; 3718 };
3558} 3719}
3559 3720
3560register_command "reload" => sub { 3721register_command "reload" => sub {
3561 my ($who, $arg) = @_; 3722 my ($who, $arg) = @_;
… …
3575 3736
3576our @WAIT_FOR_TICK; 3737our @WAIT_FOR_TICK;
3577our @WAIT_FOR_TICK_BEGIN; 3738our @WAIT_FOR_TICK_BEGIN;
3578 3739
3579sub wait_for_tick { 3740sub wait_for_tick {
3580 return unless $TICK_WATCHER->is_active;
3581 return if $Coro::current == $Coro::main; 3741 return if tick_inhibit || $Coro::current == $Coro::main;
3582 3742
3583 my $signal = new Coro::Signal; 3743 my $signal = new Coro::Signal;
3584 push @WAIT_FOR_TICK, $signal; 3744 push @WAIT_FOR_TICK, $signal;
3585 $signal->wait; 3745 $signal->wait;
3586} 3746}
3587 3747
3588sub wait_for_tick_begin { 3748sub wait_for_tick_begin {
3589 return unless $TICK_WATCHER->is_active;
3590 return if $Coro::current == $Coro::main; 3749 return if tick_inhibit || $Coro::current == $Coro::main;
3591 3750
3592 my $signal = new Coro::Signal; 3751 my $signal = new Coro::Signal;
3593 push @WAIT_FOR_TICK_BEGIN, $signal; 3752 push @WAIT_FOR_TICK_BEGIN, $signal;
3594 $signal->wait; 3753 $signal->wait;
3595} 3754}
3596 3755
3597$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub { 3756sub tick {
3598 if ($Coro::current != $Coro::main) { 3757 if ($Coro::current != $Coro::main) {
3599 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3758 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3600 unless ++$bug_warning > 10; 3759 unless ++$bug_warning > 10;
3601 return; 3760 return;
3602 } 3761 }
3603 3762
3604 $NOW = $tick_start = EV::now;
3605
3606 cf::server_tick; # one server iteration 3763 cf::server_tick; # one server iteration
3607
3608 $RUNTIME += $TICK;
3609 $NEXT_TICK += $TICK;
3610 3764
3611 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3765 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3612 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 3766 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3613 Coro::async_pool { 3767 Coro::async_pool {
3614 $Coro::current->{desc} = "runtime saver"; 3768 $Coro::current->{desc} = "runtime saver";
3615 write_runtime 3769 write_runtime_sync
3616 or warn "ERROR: unable to write runtime file: $!"; 3770 or warn "ERROR: unable to write runtime file: $!";
3617 }; 3771 };
3618 } 3772 }
3619 3773
3620 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3774 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
… …
3622 } 3776 }
3623 while (my $sig = shift @WAIT_FOR_TICK) { 3777 while (my $sig = shift @WAIT_FOR_TICK) {
3624 $sig->send; 3778 $sig->send;
3625 } 3779 }
3626 3780
3627 $LOAD = ($NOW - $tick_start) / $TICK; 3781 $LOAD = ($NOW - $TICK_START) / $TICK;
3628 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3782 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3629 3783
3630 _post_tick; 3784 if (0) {
3631}; 3785 if ($NEXT_TICK) {
3632$TICK_WATCHER->priority (EV::MAXPRI); 3786 my $jitter = $TICK_START - $NEXT_TICK;
3787 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3788 warn "jitter $JITTER\n";#d#
3789 }
3790 }
3791}
3633 3792
3634{ 3793{
3635 # configure BDB 3794 # configure BDB
3636 3795
3637 BDB::min_parallel 8; 3796 BDB::min_parallel 8;
3638 BDB::max_poll_reqs $TICK * 0.1; 3797 BDB::max_poll_reqs $TICK * 0.1;
3639 $Coro::BDB::WATCHER->priority (1); 3798 $AnyEvent::BDB::WATCHER->priority (1);
3640 3799
3641 unless ($DB_ENV) { 3800 unless ($DB_ENV) {
3642 $DB_ENV = BDB::db_env_create; 3801 $DB_ENV = BDB::db_env_create;
3643 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3802 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3644 | BDB::LOG_AUTOREMOVE, 1); 3803 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3804 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3645 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3805 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3646 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3806 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3647 3807
3648 cf::sync_job { 3808 cf::sync_job {
3649 eval { 3809 eval {
… …
3675{ 3835{
3676 # configure IO::AIO 3836 # configure IO::AIO
3677 3837
3678 IO::AIO::min_parallel 8; 3838 IO::AIO::min_parallel 8;
3679 IO::AIO::max_poll_time $TICK * 0.1; 3839 IO::AIO::max_poll_time $TICK * 0.1;
3680 $Coro::AIO::WATCHER->priority (1); 3840 undef $AnyEvent::AIO::WATCHER;
3681} 3841}
3682 3842
3683my $_log_backtrace; 3843my $_log_backtrace;
3684 3844
3685sub _log_backtrace { 3845sub _log_backtrace {

Diff Legend

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