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.393 by root, Fri Oct 26 04:47:00 2007 UTC vs.
Revision 1.423 by root, Sun Apr 20 00:44:13 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
6use Symbol; 27use Symbol;
7use List::Util; 28use List::Util;
8use Socket; 29use Socket;
9use Event; 30use EV 3.2;
10use Opcode; 31use Opcode;
11use Safe; 32use Safe;
12use Safe::Hole; 33use Safe::Hole;
13use Storable (); 34use Storable ();
14 35
15use Coro 4.1 (); 36use Coro 4.50 ();
16use Coro::State; 37use Coro::State;
17use Coro::Handle; 38use Coro::Handle;
18use Coro::Event; 39use Coro::EV;
19use Coro::Timer; 40use Coro::Timer;
20use Coro::Signal; 41use Coro::Signal;
21use Coro::Semaphore; 42use Coro::Semaphore;
22use Coro::AIO; 43use Coro::AIO;
44use Coro::BDB;
23use Coro::Storable; 45use Coro::Storable;
24use Coro::Util (); 46use Coro::Util ();
25 47
26use JSON::XS (); 48use JSON::XS 2.01 ();
27use BDB (); 49use BDB ();
28use Data::Dumper; 50use Data::Dumper;
29use Digest::MD5; 51use Digest::MD5;
30use Fcntl; 52use Fcntl;
31use YAML::Syck (); 53use YAML ();
32use IO::AIO 2.51 (); 54use IO::AIO 2.51 ();
33use Time::HiRes; 55use Time::HiRes;
34use Compress::LZF; 56use Compress::LZF;
35use Digest::MD5 (); 57use Digest::MD5 ();
36 58
37# configure various modules to our taste 59# configure various modules to our taste
38# 60#
39$Storable::canonical = 1; # reduce rsync transfers 61$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 62Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 63Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42
43$Event::Eval = 1; # no idea why this is required, but it is
44
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
47 64
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 65$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49 66
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 67sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 68
… …
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 87our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 88our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 89our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 90our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 91our $BDBDIR = "$LOCALDIR/db";
92our %RESOURCE;
75 93
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 94our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER; 95our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 96our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 97our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 98our $USE_FSYNC = 1; # use fsync to write maps - default off
83 99
84our $BDB_POLL_WATCHER; 100our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER; 101our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER; 102our $BDB_CHECKPOINT_WATCHER;
… …
89 105
90our %CFG; 106our %CFG;
91 107
92our $UPTIME; $UPTIME ||= time; 108our $UPTIME; $UPTIME ||= time;
93our $RUNTIME; 109our $RUNTIME;
110our $NOW;
94 111
95our (%PLAYER, %PLAYER_LOADING); # all users 112our (%PLAYER, %PLAYER_LOADING); # all users
96our (%MAP, %MAP_LOADING ); # all maps 113our (%MAP, %MAP_LOADING ); # all maps
97our $LINK_MAP; # the special {link} map, which is always available 114our $LINK_MAP; # the special {link} map, which is always available
98 115
99# used to convert map paths into valid unix filenames by replacing / by ∕ 116# used to convert map paths into valid unix filenames by replacing / by ∕
100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 117our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
101 118
102our $LOAD; # a number between 0 (idle) and 1 (too many objects) 119our $LOAD; # a number between 0 (idle) and 1 (too many objects)
103our $LOADAVG; # same thing, but with alpha-smoothing 120our $LOADAVG; # same thing, but with alpha-smoothing
121our $JITTER; # average jitter
104our $tick_start; # for load detecting purposes 122our $TICK_START; # for load detecting purposes
105 123
106binmode STDOUT; 124binmode STDOUT;
107binmode STDERR; 125binmode STDERR;
108 126
109# read virtual server time, if available 127# read virtual server time, if available
… …
162 180
163The raw value load value from the last tick. 181The raw value load value from the last tick.
164 182
165=item %cf::CFG 183=item %cf::CFG
166 184
167Configuration for the server, loaded from C</etc/crossfire/config>, or 185Configuration for the server, loaded from C</etc/deliantra-server/config>, or
168from wherever your confdir points to. 186from wherever your confdir points to.
169 187
170=item cf::wait_for_tick, cf::wait_for_tick_begin 188=item cf::wait_for_tick, cf::wait_for_tick_begin
171 189
172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 190These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
… …
193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 211 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
194 212
195 LOG llevError, $msg; 213 LOG llevError, $msg;
196 }; 214 };
197} 215}
216
217$Coro::State::DIEHOOK = sub {
218 return unless $^S eq 0; # "eq", not "=="
219
220 if ($Coro::current == $Coro::main) {#d#
221 warn "DIEHOOK called in main context, Coro bug?\n";#d#
222 return;#d#
223 }#d#
224
225 # kill coroutine otherwise
226 warn Carp::longmess $_[0];
227 Coro::terminate
228};
229
230$SIG{__DIE__} = sub { }; #d#?
198 231
199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 232@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 233@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 234@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 235@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
215)) { 248)) {
216 no strict 'refs'; 249 no strict 'refs';
217 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 250 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
218} 251}
219 252
220$Event::DIED = sub { 253$EV::DIED = sub {
221 warn "error in event callback: @_"; 254 warn "error in event callback: @_";
222}; 255};
223 256
224############################################################################# 257#############################################################################
225 258
… …
248 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 281 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
249 $d 282 $d
250 } || "[unable to dump $_[0]: '$@']"; 283 } || "[unable to dump $_[0]: '$@']";
251} 284}
252 285
253=item $ref = cf::from_json $json 286=item $ref = cf::decode_json $json
254 287
255Converts a JSON string into the corresponding perl data structure. 288Converts a JSON string into the corresponding perl data structure.
256 289
257=item $json = cf::to_json $ref 290=item $json = cf::encode_json $ref
258 291
259Converts a perl data structure into its JSON representation. 292Converts a perl data structure into its JSON representation.
260 293
261=cut 294=cut
262 295
263our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 296our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264 297
265sub to_json ($) { $json_coder->encode ($_[0]) } 298sub encode_json($) { $json_coder->encode ($_[0]) }
266sub from_json ($) { $json_coder->decode ($_[0]) } 299sub decode_json($) { $json_coder->decode ($_[0]) }
267 300
268=item cf::lock_wait $string 301=item cf::lock_wait $string
269 302
270Wait until the given lock is available. See cf::lock_acquire. 303Wait until the given lock is available. See cf::lock_acquire.
271 304
… …
327 360
328 ! ! $LOCK{$key} 361 ! ! $LOCK{$key}
329} 362}
330 363
331sub freeze_mainloop { 364sub freeze_mainloop {
332 return unless $TICK_WATCHER->is_active; 365 tick_inhibit_inc;
333 366
334 my $guard = Coro::guard { 367 Coro::guard \&tick_inhibit_dec;
335 $TICK_WATCHER->start; 368}
336 }; 369
337 $TICK_WATCHER->stop; 370=item cf::periodic $interval, $cb
338 $guard 371
372Like EV::periodic, but randomly selects a starting point so that the actions
373get spread over timer.
374
375=cut
376
377sub periodic($$) {
378 my ($interval, $cb) = @_;
379
380 my $start = rand List::Util::min 180, $interval;
381
382 EV::periodic $start, $interval, 0, $cb
339} 383}
340 384
341=item cf::get_slot $time[, $priority[, $name]] 385=item cf::get_slot $time[, $priority[, $name]]
342 386
343Allocate $time seconds of blocking CPU time at priority C<$priority>: 387Allocate $time seconds of blocking CPU time at priority C<$priority>:
… …
383 } 427 }
384 } 428 }
385}; 429};
386 430
387sub get_slot($;$$) { 431sub get_slot($;$$) {
432 return if tick_inhibit || $Coro::current == $Coro::main;
433
388 my ($time, $pri, $name) = @_; 434 my ($time, $pri, $name) = @_;
389 435
390 $time = $TICK * .6 if $time > $TICK * .6; 436 $time = $TICK * .6 if $time > $TICK * .6;
391 my $sig = new Coro::Signal; 437 my $sig = new Coro::Signal;
392 438
… …
406 452
407BEGIN { *async = \&Coro::async_pool } 453BEGIN { *async = \&Coro::async_pool }
408 454
409=item cf::sync_job { BLOCK } 455=item cf::sync_job { BLOCK }
410 456
411The design of Crossfire TRT requires that the main coroutine ($Coro::main) 457The design of Deliantra requires that the main coroutine ($Coro::main)
412is always able to handle events or runnable, as Crossfire TRT is only 458is always able to handle events or runnable, as Deliantra is only
413partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 459partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
414acceptable. 460acceptable.
415 461
416If it must be done, put the blocking parts into C<sync_job>. This will run 462If it must be done, put the blocking parts into C<sync_job>. This will run
417the given BLOCK in another coroutine while waiting for the result. The 463the given BLOCK in another coroutine while waiting for the result. The
… …
422 468
423sub sync_job(&) { 469sub sync_job(&) {
424 my ($job) = @_; 470 my ($job) = @_;
425 471
426 if ($Coro::current == $Coro::main) { 472 if ($Coro::current == $Coro::main) {
427 my $time = Event::time; 473 my $time = EV::time;
428 474
429 # this is the main coro, too bad, we have to block 475 # this is the main coro, too bad, we have to block
430 # till the operation succeeds, freezing the server :/ 476 # till the operation succeeds, freezing the server :/
431 477
432 LOG llevError, Carp::longmess "sync job";#d# 478 LOG llevError, Carp::longmess "sync job";#d#
433 479
434 # TODO: use suspend/resume instead
435 # (but this is cancel-safe)
436 my $freeze_guard = freeze_mainloop; 480 my $freeze_guard = freeze_mainloop;
437 481
438 my $busy = 1; 482 my $busy = 1;
439 my @res; 483 my @res;
440 484
… …
447 491
448 while ($busy) { 492 while ($busy) {
449 if (Coro::nready) { 493 if (Coro::nready) {
450 Coro::cede_notself; 494 Coro::cede_notself;
451 } else { 495 } else {
452 Event::one_event; 496 EV::loop EV::LOOP_ONESHOT;
453 } 497 }
454 } 498 }
455 499
456 $time = Event::time - $time; 500 my $time = EV::time - $time;
457 501
458 LOG llevError | logBacktrace, Carp::longmess "long sync job"
459 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
460
461 $tick_start += $time; # do not account sync jobs to server load 502 $TICK_START += $time; # do not account sync jobs to server load
462 503
463 wantarray ? @res : $res[0] 504 wantarray ? @res : $res[0]
464 } else { 505 } else {
465 # we are in another coroutine, how wonderful, everything just works 506 # we are in another coroutine, how wonderful, everything just works
466 507
… …
491=item fork_call { }, $args 532=item fork_call { }, $args
492 533
493Executes the given code block with the given arguments in a seperate 534Executes the given code block with the given arguments in a seperate
494process, returning the results. Everything must be serialisable with 535process, returning the results. Everything must be serialisable with
495Coro::Storable. May, of course, block. Note that the executed sub may 536Coro::Storable. May, of course, block. Note that the executed sub may
496never block itself or use any form of Event handling. 537never block itself or use any form of event handling.
497 538
498=cut 539=cut
499 540
500sub fork_call(&@) { 541sub fork_call(&@) {
501 my ($cb, @args) = @_; 542 my ($cb, @args) = @_;
… …
508 reset_signals; 549 reset_signals;
509 &$cb 550 &$cb
510 }, @args; 551 }, @args;
511 552
512 wantarray ? @res : $res[-1] 553 wantarray ? @res : $res[-1]
554}
555
556=item $coin = coin_from_name $name
557
558=cut
559
560our %coin_alias = (
561 "silver" => "silvercoin",
562 "silvercoin" => "silvercoin",
563 "silvercoins" => "silvercoin",
564 "gold" => "goldcoin",
565 "goldcoin" => "goldcoin",
566 "goldcoins" => "goldcoin",
567 "platinum" => "platinacoin",
568 "platinumcoin" => "platinacoin",
569 "platinumcoins" => "platinacoin",
570 "platina" => "platinacoin",
571 "platinacoin" => "platinacoin",
572 "platinacoins" => "platinacoin",
573 "royalty" => "royalty",
574 "royalties" => "royalty",
575);
576
577sub coin_from_name($) {
578 $coin_alias{$_[0]}
579 ? cf::arch::find $coin_alias{$_[0]}
580 : undef
513} 581}
514 582
515=item $value = cf::db_get $family => $key 583=item $value = cf::db_get $family => $key
516 584
517Returns a single value from the environment database. 585Returns a single value from the environment database.
… …
662attach callbacks/event handlers (a collection of which is called an "attachment") 730attach callbacks/event handlers (a collection of which is called an "attachment")
663to it. All such attachable objects support the following methods. 731to it. All such attachable objects support the following methods.
664 732
665In the following description, CLASS can be any of C<global>, C<object> 733In the following description, CLASS can be any of C<global>, C<object>
666C<player>, C<client> or C<map> (i.e. the attachable objects in 734C<player>, C<client> or C<map> (i.e. the attachable objects in
667Crossfire TRT). 735Deliantra).
668 736
669=over 4 737=over 4
670 738
671=item $attachable->attach ($attachment, key => $value...) 739=item $attachable->attach ($attachment, key => $value...)
672 740
… …
954 } 1022 }
955 1023
956 0 1024 0
957} 1025}
958 1026
959=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1027=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
960 1028
961=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1029=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
962 1030
963Generate an object-specific event with the given arguments. 1031Generate an object-specific event with the given arguments.
964 1032
… …
1042cf::attachable->attach ( 1110cf::attachable->attach (
1043 prio => -1000000, 1111 prio => -1000000,
1044 on_instantiate => sub { 1112 on_instantiate => sub {
1045 my ($obj, $data) = @_; 1113 my ($obj, $data) = @_;
1046 1114
1047 $data = from_json $data; 1115 $data = decode_json $data;
1048 1116
1049 for (@$data) { 1117 for (@$data) {
1050 my ($name, $args) = @$_; 1118 my ($name, $args) = @$_;
1051 1119
1052 $obj->attach ($name, %{$args || {} }); 1120 $obj->attach ($name, %{$args || {} });
… …
1289 my $msg = $@ ? "$v->{path}: $@\n" 1357 my $msg = $@ ? "$v->{path}: $@\n"
1290 : "$v->{base}: extension inactive.\n"; 1358 : "$v->{base}: extension inactive.\n";
1291 1359
1292 if (exists $v->{meta}{mandatory}) { 1360 if (exists $v->{meta}{mandatory}) {
1293 warn $msg; 1361 warn $msg;
1294 warn "mandatory extension failed to load, exiting.\n"; 1362 cf::cleanup "mandatory extension failed to load, exiting.";
1295 exit 1;
1296 } 1363 }
1297 1364
1298 warn $msg; 1365 warn $msg;
1299 } 1366 }
1300 1367
… …
1408 1475
1409 return if $pl->{deny_save}; 1476 return if $pl->{deny_save};
1410 1477
1411 aio_mkdir playerdir $pl, 0770; 1478 aio_mkdir playerdir $pl, 0770;
1412 $pl->{last_save} = $cf::RUNTIME; 1479 $pl->{last_save} = $cf::RUNTIME;
1480
1481 cf::get_slot 0.01;
1413 1482
1414 $pl->save_pl ($path); 1483 $pl->save_pl ($path);
1415 cf::cede_to_tick; 1484 cf::cede_to_tick;
1416} 1485}
1417 1486
… …
1710our $MAX_RESET = 3600; 1779our $MAX_RESET = 3600;
1711our $DEFAULT_RESET = 3000; 1780our $DEFAULT_RESET = 3000;
1712 1781
1713sub generate_random_map { 1782sub generate_random_map {
1714 my ($self, $rmp) = @_; 1783 my ($self, $rmp) = @_;
1784
1785 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1786
1715 # mit "rum" bekleckern, nicht 1787 # mit "rum" bekleckern, nicht
1716 $self->_create_random_map ( 1788 $self->_create_random_map (
1717 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1789 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1718 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1790 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1719 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1791 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1841 1913
1842# the temporary/swap location 1914# the temporary/swap location
1843sub save_path { 1915sub save_path {
1844 my ($self) = @_; 1916 my ($self) = @_;
1845 1917
1846 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1918 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1847 "$TMPDIR/$path.map" 1919 "$TMPDIR/$path.map"
1848} 1920}
1849 1921
1850# the unique path, undef == no special unique path 1922# the unique path, undef == no special unique path
1851sub uniq_path { 1923sub uniq_path {
1852 my ($self) = @_; 1924 my ($self) = @_;
1853 1925
1854 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1926 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1855 "$UNIQUEDIR/$path" 1927 "$UNIQUEDIR/$path"
1856} 1928}
1857 1929
1858# and all this just because we cannot iterate over 1930# and all this just because we cannot iterate over
1859# all maps in C++... 1931# all maps in C++...
… …
2045 } 2117 }
2046 2118
2047 $self->{last_save} = $cf::RUNTIME; 2119 $self->{last_save} = $cf::RUNTIME;
2048 $self->last_access ($cf::RUNTIME); 2120 $self->last_access ($cf::RUNTIME);
2049 2121
2050 $self->in_memory (cf::MAP_IN_MEMORY); 2122 $self->in_memory (cf::MAP_ACTIVE);
2051 } 2123 }
2052 2124
2053 $self->post_load; 2125 $self->post_load;
2054} 2126}
2055 2127
… …
2113 my ($path, $origin, $load) = @_; 2185 my ($path, $origin, $load) = @_;
2114 2186
2115 $path = normalise $path, $origin && $origin->{path}; 2187 $path = normalise $path, $origin && $origin->{path};
2116 2188
2117 if (my $map = $cf::MAP{$path}) { 2189 if (my $map = $cf::MAP{$path}) {
2118 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2190 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2119 } 2191 }
2120 2192
2121 $MAP_PREFETCH{$path} |= $load; 2193 $MAP_PREFETCH{$path} |= $load;
2122 2194
2123 $MAP_PREFETCHER ||= cf::async { 2195 $MAP_PREFETCHER ||= cf::async {
… …
2160 cf::async { 2232 cf::async {
2161 $Coro::current->{desc} = "map player save"; 2233 $Coro::current->{desc} = "map player save";
2162 $_->contr->save for $self->players; 2234 $_->contr->save for $self->players;
2163 }; 2235 };
2164 2236
2237 cf::get_slot 0.02;
2238
2165 if ($uniq) { 2239 if ($uniq) {
2166 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2240 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2167 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2241 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2168 } else { 2242 } else {
2169 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2243 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
… …
2177 $self->save; 2251 $self->save;
2178 2252
2179 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2253 my $lock = cf::lock_acquire "map_data:$self->{path}";
2180 2254
2181 return if $self->players; 2255 return if $self->players;
2182 return if $self->in_memory != cf::MAP_IN_MEMORY; 2256 return if $self->in_memory != cf::MAP_ACTIVE;
2183 return if $self->{deny_save}; 2257 return if $self->{deny_save};
2184 2258
2185 $self->in_memory (cf::MAP_SWAPPED); 2259 $self->in_memory (cf::MAP_SWAPPED);
2186 2260
2187 $self->deactivate; 2261 $self->deactivate;
… …
2305 2379
2306sub unique_maps() { 2380sub unique_maps() {
2307 [ 2381 [
2308 map { 2382 map {
2309 utf8::decode $_; 2383 utf8::decode $_;
2310 /\.map$/ 2384 s/\.map$//; # TODO future compatibility hack
2385 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2386 ? ()
2311 ? normalise $_ 2387 : normalise $_
2312 : ()
2313 } @{ aio_readdir $UNIQUEDIR or [] } 2388 } @{ aio_readdir $UNIQUEDIR or [] }
2314 ] 2389 ]
2315} 2390}
2316 2391
2317package cf;
2318
2319=back 2392=back
2320 2393
2321=head3 cf::object 2394=head3 cf::object
2322 2395
2323=cut 2396=cut
… …
2326 2399
2327=over 4 2400=over 4
2328 2401
2329=item $ob->inv_recursive 2402=item $ob->inv_recursive
2330 2403
2331Returns the inventory of the object _and_ their inventories, recursively. 2404Returns the inventory of the object I<and> their inventories, recursively,
2405but I<not> the object itself.
2332 2406
2333=cut 2407=cut
2334 2408
2335sub inv_recursive_; 2409sub inv_recursive_;
2336sub inv_recursive_ { 2410sub inv_recursive_ {
… …
2341 inv_recursive_ inv $_[0] 2415 inv_recursive_ inv $_[0]
2342} 2416}
2343 2417
2344=item $ref = $ob->ref 2418=item $ref = $ob->ref
2345 2419
2346creates and returns a persistent reference to an objetc that can be stored as a string. 2420Creates and returns a persistent reference to an object that can be stored as a string.
2347 2421
2348=item $ob = cf::object::deref ($refstring) 2422=item $ob = cf::object::deref ($refstring)
2349 2423
2350returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2424returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2351even if the object actually exists. May block. 2425even if the object actually exists. May block.
… …
2625 $rmp->{origin_y} = $exit->y; 2699 $rmp->{origin_y} = $exit->y;
2626 } 2700 }
2627 2701
2628 $rmp->{random_seed} ||= $exit->random_seed; 2702 $rmp->{random_seed} ||= $exit->random_seed;
2629 2703
2630 my $data = cf::to_json $rmp; 2704 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2631 my $md5 = Digest::MD5::md5_hex $data; 2705 my $md5 = Digest::MD5::md5_hex $data;
2632 my $meta = "$RANDOMDIR/$md5.meta"; 2706 my $meta = "$RANDOMDIR/$md5.meta";
2633 2707
2634 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2708 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2635 aio_write $fh, 0, (length $data), $data, 0; 2709 aio_write $fh, 0, (length $data), $data, 0;
… …
3135 { 3209 {
3136 my $faces = $facedata->{faceinfo}; 3210 my $faces = $facedata->{faceinfo};
3137 3211
3138 while (my ($face, $info) = each %$faces) { 3212 while (my ($face, $info) = each %$faces) {
3139 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3213 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3214
3140 cf::face::set_visibility $idx, $info->{visibility}; 3215 cf::face::set_visibility $idx, $info->{visibility};
3141 cf::face::set_magicmap $idx, $info->{magicmap}; 3216 cf::face::set_magicmap $idx, $info->{magicmap};
3142 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3217 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3143 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3218 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3144 3219
3145 cf::cede_to_tick; 3220 cf::cede_to_tick;
3146 } 3221 }
3147 3222
3148 while (my ($face, $info) = each %$faces) { 3223 while (my ($face, $info) = each %$faces) {
3149 next unless $info->{smooth}; 3224 next unless $info->{smooth};
3225
3150 my $idx = cf::face::find $face 3226 my $idx = cf::face::find $face
3151 or next; 3227 or next;
3228
3152 if (my $smooth = cf::face::find $info->{smooth}) { 3229 if (my $smooth = cf::face::find $info->{smooth}) {
3153 cf::face::set_smooth $idx, $smooth; 3230 cf::face::set_smooth $idx, $smooth;
3154 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3231 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3155 } else { 3232 } else {
3156 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3233 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
3174 { 3251 {
3175 # TODO: for gcfclient pleasure, we should give resources 3252 # TODO: for gcfclient pleasure, we should give resources
3176 # that gcfclient doesn't grok a >10000 face index. 3253 # that gcfclient doesn't grok a >10000 face index.
3177 my $res = $facedata->{resource}; 3254 my $res = $facedata->{resource};
3178 3255
3179 my $soundconf = delete $res->{"res/sound.conf"};
3180
3181 while (my ($name, $info) = each %$res) { 3256 while (my ($name, $info) = each %$res) {
3257 if (defined $info->{type}) {
3182 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3258 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3183 my $data; 3259 my $data;
3184 3260
3185 if ($info->{type} & 1) { 3261 if ($info->{type} & 1) {
3186 # prepend meta info 3262 # prepend meta info
3187 3263
3188 my $meta = $enc->encode ({ 3264 my $meta = $enc->encode ({
3189 name => $name, 3265 name => $name,
3190 %{ $info->{meta} || {} }, 3266 %{ $info->{meta} || {} },
3191 }); 3267 });
3192 3268
3193 $data = pack "(w/a*)*", $meta, $info->{data}; 3269 $data = pack "(w/a*)*", $meta, $info->{data};
3270 } else {
3271 $data = $info->{data};
3272 }
3273
3274 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3275 cf::face::set_type $idx, $info->{type};
3194 } else { 3276 } else {
3195 $data = $info->{data}; 3277 $RESOURCE{$name} = $info;
3196 } 3278 }
3197 3279
3198 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3199 cf::face::set_type $idx, $info->{type};
3200
3201 cf::cede_to_tick; 3280 cf::cede_to_tick;
3202 } 3281 }
3203
3204 if ($soundconf) {
3205 $soundconf = $enc->decode (delete $soundconf->{data});
3206
3207 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3208 my $sound = $soundconf->{compat}[$_]
3209 or next;
3210
3211 my $face = cf::face::find "sound/$sound->[1]";
3212 cf::sound::set $sound->[0] => $face;
3213 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3214 }
3215
3216 while (my ($k, $v) = each %{$soundconf->{event}}) {
3217 my $face = cf::face::find "sound/$v";
3218 cf::sound::set $k => $face;
3219 }
3220 }
3221 } 3282 }
3283
3284 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3222 3285
3223 1 3286 1
3224} 3287}
3288
3289cf::global->attach (on_resource_update => sub {
3290 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3291 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3292
3293 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3294 my $sound = $soundconf->{compat}[$_]
3295 or next;
3296
3297 my $face = cf::face::find "sound/$sound->[1]";
3298 cf::sound::set $sound->[0] => $face;
3299 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3300 }
3301
3302 while (my ($k, $v) = each %{$soundconf->{event}}) {
3303 my $face = cf::face::find "sound/$v";
3304 cf::sound::set $k => $face;
3305 }
3306 }
3307});
3225 3308
3226register_exticmd fx_want => sub { 3309register_exticmd fx_want => sub {
3227 my ($ns, $want) = @_; 3310 my ($ns, $want) = @_;
3228 3311
3229 while (my ($k, $v) = each %$want) { 3312 while (my ($k, $v) = each %$want) {
3230 $ns->fx_want ($k, $v); 3313 $ns->fx_want ($k, $v);
3231 } 3314 }
3232}; 3315};
3316
3317sub load_resource_file($) {
3318 my $status = load_resource_file_ $_[0];
3319 get_slot 0.1, 100;
3320 cf::arch::commit_load;
3321 $status
3322}
3233 3323
3234sub reload_regions { 3324sub reload_regions {
3235 # HACK to clear player env face cache, we need some signal framework 3325 # HACK to clear player env face cache, we need some signal framework
3236 # for this (global event?) 3326 # for this (global event?)
3237 %ext::player_env::MUSIC_FACE_CACHE = (); 3327 %ext::player_env::MUSIC_FACE_CACHE = ();
… …
3251} 3341}
3252 3342
3253sub reload_archetypes { 3343sub reload_archetypes {
3254 load_resource_file "$DATADIR/archetypes" 3344 load_resource_file "$DATADIR/archetypes"
3255 or die "unable to load archetypes\n"; 3345 or die "unable to load archetypes\n";
3256 #d# NEED to laod twice to resolve forward references
3257 # this really needs to be done in an extra post-pass
3258 # (which needs to be synchronous, so solve it differently)
3259 load_resource_file "$DATADIR/archetypes"
3260 or die "unable to load archetypes\n";
3261} 3346}
3262 3347
3263sub reload_treasures { 3348sub reload_treasures {
3264 load_resource_file "$DATADIR/treasures" 3349 load_resource_file "$DATADIR/treasures"
3265 or die "unable to load treasurelists\n"; 3350 or die "unable to load treasurelists\n";
3266} 3351}
3267 3352
3268sub reload_resources { 3353sub reload_resources {
3269 warn "reloading resource files...\n"; 3354 warn "reloading resource files...\n";
3270 3355
3356 reload_facedata;
3357 reload_archetypes;
3271 reload_regions; 3358 reload_regions;
3272 reload_facedata;
3273 #reload_archetypes;#d#
3274 reload_archetypes;
3275 reload_treasures; 3359 reload_treasures;
3276 3360
3277 warn "finished reloading resource files\n"; 3361 warn "finished reloading resource files\n";
3278} 3362}
3279 3363
3280sub init { 3364sub init {
3365 my $guard = freeze_mainloop;
3366
3281 reload_resources; 3367 reload_resources;
3282} 3368}
3283 3369
3284sub reload_config { 3370sub reload_config {
3285 open my $fh, "<:utf8", "$CONFDIR/config" 3371 open my $fh, "<:utf8", "$CONFDIR/config"
3286 or return; 3372 or return;
3287 3373
3288 local $/; 3374 local $/;
3289 *CFG = YAML::Syck::Load <$fh>; 3375 *CFG = YAML::Load <$fh>;
3290 3376
3291 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3377 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3292 3378
3293 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3379 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3294 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3380 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3306 # we must not ever block the main coroutine 3392 # we must not ever block the main coroutine
3307 local $Coro::idle = sub { 3393 local $Coro::idle = sub {
3308 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3394 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3309 (async { 3395 (async {
3310 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3396 $Coro::current->{desc} = "IDLE BUG HANDLER";
3311 Event::one_event; 3397 EV::loop EV::LOOP_ONESHOT;
3312 })->prio (Coro::PRIO_MAX); 3398 })->prio (Coro::PRIO_MAX);
3313 }; 3399 };
3314 3400
3401 {
3402 my $guard = freeze_mainloop;
3315 reload_config; 3403 reload_config;
3316 db_init; 3404 db_init;
3317 load_extensions; 3405 load_extensions;
3318 3406
3319 $TICK_WATCHER->start; 3407 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3408 evthread_start IO::AIO::poll_fileno;
3409 }
3410
3320 Event::loop; 3411 EV::loop;
3321} 3412}
3322 3413
3323############################################################################# 3414#############################################################################
3324# initialisation and cleanup 3415# initialisation and cleanup
3325 3416
3326# install some emergency cleanup handlers 3417# install some emergency cleanup handlers
3327BEGIN { 3418BEGIN {
3419 our %SIGWATCHER = ();
3328 for my $signal (qw(INT HUP TERM)) { 3420 for my $signal (qw(INT HUP TERM)) {
3329 Event->signal ( 3421 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3330 reentrant => 0,
3331 data => WF_AUTOCANCEL,
3332 signal => $signal,
3333 prio => 0,
3334 cb => sub {
3335 cf::cleanup "SIG$signal"; 3422 cf::cleanup "SIG$signal";
3336 },
3337 ); 3423 };
3338 } 3424 }
3339} 3425}
3340 3426
3341sub write_runtime { 3427sub write_runtime_sync {
3342 my $runtime = "$LOCALDIR/runtime"; 3428 my $runtime = "$LOCALDIR/runtime";
3343 3429
3344 # first touch the runtime file to show we are still running: 3430 # first touch the runtime file to show we are still running:
3345 # the fsync below can take a very very long time. 3431 # the fsync below can take a very very long time.
3346 3432
… …
3372 and return; 3458 and return;
3373 3459
3374 warn "runtime file written.\n"; 3460 warn "runtime file written.\n";
3375 3461
3376 1 3462 1
3463}
3464
3465our $uuid_lock;
3466our $uuid_skip;
3467
3468sub write_uuid_sync($) {
3469 $uuid_skip ||= $_[0];
3470
3471 return if $uuid_lock;
3472 local $uuid_lock = 1;
3473
3474 my $uuid = "$LOCALDIR/uuid";
3475
3476 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3477 or return;
3478
3479 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3480 $uuid_skip = 0;
3481
3482 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3483 and return;
3484
3485 # always fsync - this file is important
3486 aio_fsync $fh
3487 and return;
3488
3489 close $fh
3490 or return;
3491
3492 aio_rename "$uuid~", $uuid
3493 and return;
3494
3495 warn "uuid file written ($value).\n";
3496
3497 1
3498
3499}
3500
3501sub write_uuid($$) {
3502 my ($skip, $sync) = @_;
3503
3504 $sync ? write_uuid_sync $skip
3505 : async { write_uuid_sync $skip };
3377} 3506}
3378 3507
3379sub emergency_save() { 3508sub emergency_save() {
3380 my $freeze_guard = cf::freeze_mainloop; 3509 my $freeze_guard = cf::freeze_mainloop;
3381 3510
… …
3403 warn "end emergency map save\n"; 3532 warn "end emergency map save\n";
3404 3533
3405 warn "begin emergency database checkpoint\n"; 3534 warn "begin emergency database checkpoint\n";
3406 BDB::db_env_txn_checkpoint $DB_ENV; 3535 BDB::db_env_txn_checkpoint $DB_ENV;
3407 warn "end emergency database checkpoint\n"; 3536 warn "end emergency database checkpoint\n";
3537
3538 warn "begin write uuid\n";
3539 write_uuid_sync 1;
3540 warn "end write uuid\n";
3408 }; 3541 };
3409 3542
3410 warn "leave emergency perl save\n"; 3543 warn "leave emergency perl save\n";
3411} 3544}
3412 3545
… …
3427 warn "reloading..."; 3560 warn "reloading...";
3428 3561
3429 warn "entering sync_job"; 3562 warn "entering sync_job";
3430 3563
3431 cf::sync_job { 3564 cf::sync_job {
3432 cf::write_runtime; # external watchdog should not bark 3565 cf::write_runtime_sync; # external watchdog should not bark
3433 cf::emergency_save; 3566 cf::emergency_save;
3434 cf::write_runtime; # external watchdog should not bark 3567 cf::write_runtime_sync; # external watchdog should not bark
3435 3568
3436 warn "syncing database to disk"; 3569 warn "syncing database to disk";
3437 BDB::db_env_txn_checkpoint $DB_ENV; 3570 BDB::db_env_txn_checkpoint $DB_ENV;
3438 3571
3439 # if anything goes wrong in here, we should simply crash as we already saved 3572 # if anything goes wrong in here, we should simply crash as we already saved
3440
3441 warn "cancelling all WF_AUTOCANCEL watchers";
3442 for (Event::all_watchers) {
3443 $_->cancel if $_->data & WF_AUTOCANCEL;
3444 }
3445 3573
3446 warn "flushing outstanding aio requests"; 3574 warn "flushing outstanding aio requests";
3447 for (;;) { 3575 for (;;) {
3448 BDB::flush; 3576 BDB::flush;
3449 IO::AIO::flush; 3577 IO::AIO::flush;
… …
3531 warn "leaving sync_job"; 3659 warn "leaving sync_job";
3532 3660
3533 1 3661 1
3534 } or do { 3662 } or do {
3535 warn $@; 3663 warn $@;
3536 warn "error while reloading, exiting."; 3664 cf::cleanup "error while reloading, exiting.";
3537 exit 1;
3538 }; 3665 };
3539 3666
3540 warn "reloaded"; 3667 warn "reloaded";
3541}; 3668};
3542 3669
… …
3544 3671
3545sub reload_perl() { 3672sub reload_perl() {
3546 # doing reload synchronously and two reloads happen back-to-back, 3673 # doing reload synchronously and two reloads happen back-to-back,
3547 # coro crashes during coro_state_free->destroy here. 3674 # coro crashes during coro_state_free->destroy here.
3548 3675
3549 $RELOAD_WATCHER ||= Event->timer ( 3676 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3550 reentrant => 0,
3551 after => 0,
3552 data => WF_AUTOCANCEL,
3553 cb => sub {
3554 do_reload_perl; 3677 do_reload_perl;
3555 undef $RELOAD_WATCHER; 3678 undef $RELOAD_WATCHER;
3556 },
3557 ); 3679 };
3558} 3680}
3559 3681
3560register_command "reload" => sub { 3682register_command "reload" => sub {
3561 my ($who, $arg) = @_; 3683 my ($who, $arg) = @_;
3562 3684
… …
3575 3697
3576our @WAIT_FOR_TICK; 3698our @WAIT_FOR_TICK;
3577our @WAIT_FOR_TICK_BEGIN; 3699our @WAIT_FOR_TICK_BEGIN;
3578 3700
3579sub wait_for_tick { 3701sub wait_for_tick {
3580 return unless $TICK_WATCHER->is_active;
3581 return if $Coro::current == $Coro::main; 3702 return if tick_inhibit || $Coro::current == $Coro::main;
3582 3703
3583 my $signal = new Coro::Signal; 3704 my $signal = new Coro::Signal;
3584 push @WAIT_FOR_TICK, $signal; 3705 push @WAIT_FOR_TICK, $signal;
3585 $signal->wait; 3706 $signal->wait;
3586} 3707}
3587 3708
3588sub wait_for_tick_begin { 3709sub wait_for_tick_begin {
3589 return unless $TICK_WATCHER->is_active;
3590 return if $Coro::current == $Coro::main; 3710 return if tick_inhibit || $Coro::current == $Coro::main;
3591 3711
3592 my $signal = new Coro::Signal; 3712 my $signal = new Coro::Signal;
3593 push @WAIT_FOR_TICK_BEGIN, $signal; 3713 push @WAIT_FOR_TICK_BEGIN, $signal;
3594 $signal->wait; 3714 $signal->wait;
3595} 3715}
3596 3716
3597$TICK_WATCHER = Event->timer ( 3717sub tick {
3598 reentrant => 0,
3599 parked => 1,
3600 prio => 0,
3601 at => $NEXT_TICK || $TICK,
3602 data => WF_AUTOCANCEL,
3603 cb => sub {
3604 if ($Coro::current != $Coro::main) { 3718 if ($Coro::current != $Coro::main) {
3605 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3719 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3606 unless ++$bug_warning > 10; 3720 unless ++$bug_warning > 10;
3607 return; 3721 return;
3608 } 3722 }
3609 3723
3610 $NOW = $tick_start = Event::time;
3611
3612 cf::server_tick; # one server iteration 3724 cf::server_tick; # one server iteration
3613 3725
3614 $RUNTIME += $TICK;
3615 $NEXT_TICK += $TICK;
3616
3617 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3726 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3618 $NEXT_RUNTIME_WRITE = $NOW + 10; 3727 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3619 Coro::async_pool { 3728 Coro::async_pool {
3620 $Coro::current->{desc} = "runtime saver"; 3729 $Coro::current->{desc} = "runtime saver";
3621 write_runtime 3730 write_runtime_sync
3622 or warn "ERROR: unable to write runtime file: $!"; 3731 or warn "ERROR: unable to write runtime file: $!";
3623 };
3624 } 3732 };
3733 }
3625 3734
3626 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3735 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3627 $sig->send; 3736 $sig->send;
3628 } 3737 }
3629 while (my $sig = shift @WAIT_FOR_TICK) { 3738 while (my $sig = shift @WAIT_FOR_TICK) {
3630 $sig->send; 3739 $sig->send;
3631 } 3740 }
3632 3741
3633 $NOW = Event::time; 3742 $LOAD = ($NOW - $TICK_START) / $TICK;
3634
3635 # if we are delayed by four ticks or more, skip them all
3636 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3637
3638 $TICK_WATCHER->at ($NEXT_TICK);
3639 $TICK_WATCHER->start;
3640
3641 $LOAD = ($NOW - $tick_start) / $TICK;
3642 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3743 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3643 3744
3644 _post_tick; 3745 if (0) {
3746 if ($NEXT_TICK) {
3747 my $jitter = $TICK_START - $NEXT_TICK;
3748 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3749 warn "jitter $JITTER\n";#d#
3750 }
3645 }, 3751 }
3646); 3752}
3647 3753
3648{ 3754{
3755 # configure BDB
3756
3649 BDB::min_parallel 8; 3757 BDB::min_parallel 8;
3650 BDB::max_poll_time $TICK * 0.1; 3758 BDB::max_poll_reqs $TICK * 0.1;
3651 $BDB_POLL_WATCHER = Event->io ( 3759 $Coro::BDB::WATCHER->priority (1);
3652 reentrant => 0,
3653 fd => BDB::poll_fileno,
3654 poll => 'r',
3655 prio => 0,
3656 data => WF_AUTOCANCEL,
3657 cb => \&BDB::poll_cb,
3658 );
3659
3660 BDB::set_sync_prepare {
3661 my $status;
3662 my $current = $Coro::current;
3663 (
3664 sub {
3665 $status = $!;
3666 $current->ready; undef $current;
3667 },
3668 sub {
3669 Coro::schedule while defined $current;
3670 $! = $status;
3671 },
3672 )
3673 };
3674 3760
3675 unless ($DB_ENV) { 3761 unless ($DB_ENV) {
3676 $DB_ENV = BDB::db_env_create; 3762 $DB_ENV = BDB::db_env_create;
3677 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3763 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3678 | BDB::LOG_AUTOREMOVE, 1); 3764 | BDB::LOG_AUTOREMOVE, 1);
… …
3693 3779
3694 cf::cleanup "db_env_open(db): $@" if $@; 3780 cf::cleanup "db_env_open(db): $@" if $@;
3695 }; 3781 };
3696 } 3782 }
3697 3783
3698 $BDB_DEADLOCK_WATCHER = Event->timer ( 3784 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3699 after => 3,
3700 interval => 1,
3701 hard => 1,
3702 prio => 0,
3703 data => WF_AUTOCANCEL,
3704 cb => sub {
3705 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { }; 3785 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3706 },
3707 ); 3786 };
3708 $BDB_CHECKPOINT_WATCHER = Event->timer ( 3787 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3709 after => 11,
3710 interval => 60,
3711 hard => 1,
3712 prio => 0,
3713 data => WF_AUTOCANCEL,
3714 cb => sub {
3715 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 3788 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3716 },
3717 ); 3789 };
3718 $BDB_TRICKLE_WATCHER = Event->timer ( 3790 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3719 after => 5,
3720 interval => 10,
3721 hard => 1,
3722 prio => 0,
3723 data => WF_AUTOCANCEL,
3724 cb => sub {
3725 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 3791 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3726 },
3727 ); 3792 };
3728} 3793}
3729 3794
3730{ 3795{
3796 # configure IO::AIO
3797
3731 IO::AIO::min_parallel 8; 3798 IO::AIO::min_parallel 8;
3732
3733 undef $Coro::AIO::WATCHER;
3734 IO::AIO::max_poll_time $TICK * 0.1; 3799 IO::AIO::max_poll_time $TICK * 0.1;
3735 $AIO_POLL_WATCHER = Event->io ( 3800 $Coro::AIO::WATCHER->priority (1);
3736 reentrant => 0,
3737 data => WF_AUTOCANCEL,
3738 fd => IO::AIO::poll_fileno,
3739 poll => 'r',
3740 prio => 0,
3741 cb => \&IO::AIO::poll_cb,
3742 );
3743} 3801}
3744 3802
3745my $_log_backtrace; 3803my $_log_backtrace;
3746 3804
3747sub _log_backtrace { 3805sub _log_backtrace {

Diff Legend

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