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.348 by root, Thu Aug 30 08:34:40 2007 UTC vs.
Revision 1.414 by root, Thu Apr 10 09:10:45 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 Storable; 30use EV 3.2;
10use Event;
11use Opcode; 31use Opcode;
12use Safe; 32use Safe;
13use Safe::Hole; 33use Safe::Hole;
34use Storable ();
14 35
15use Coro 3.64 (); 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.32 (); 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;
101our $BDB_DEADLOCK_WATCHER;
102our $BDB_CHECKPOINT_WATCHER;
103our $BDB_TRICKLE_WATCHER;
85our $DB_ENV; 104our $DB_ENV;
86 105
87our %CFG; 106our %CFG;
88 107
89our $UPTIME; $UPTIME ||= time; 108our $UPTIME; $UPTIME ||= time;
90our $RUNTIME; 109our $RUNTIME;
110our $NOW;
91 111
92our %PLAYER; # all users 112our (%PLAYER, %PLAYER_LOADING); # all users
93our %MAP; # all maps 113our (%MAP, %MAP_LOADING ); # all maps
94our $LINK_MAP; # the special {link} map, which is always available 114our $LINK_MAP; # the special {link} map, which is always available
95 115
96# 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 ∕
97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 117our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
98 118
99our $LOAD; # a number between 0 (idle) and 1 (too many objects) 119our $LOAD; # a number between 0 (idle) and 1 (too many objects)
100our $LOADAVG; # same thing, but with alpha-smoothing 120our $LOADAVG; # same thing, but with alpha-smoothing
121our $JITTER; # average jitter
101our $tick_start; # for load detecting purposes 122our $TICK_START; # for load detecting purposes
102 123
103binmode STDOUT; 124binmode STDOUT;
104binmode STDERR; 125binmode STDERR;
105 126
106# read virtual server time, if available 127# read virtual server time, if available
… …
159 180
160The raw value load value from the last tick. 181The raw value load value from the last tick.
161 182
162=item %cf::CFG 183=item %cf::CFG
163 184
164Configuration for the server, loaded from C</etc/crossfire/config>, or 185Configuration for the server, loaded from C</etc/deliantra-server/config>, or
165from wherever your confdir points to. 186from wherever your confdir points to.
166 187
167=item cf::wait_for_tick, cf::wait_for_tick_begin 188=item cf::wait_for_tick, cf::wait_for_tick_begin
168 189
169These 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
… …
187 $msg .= "\n" 208 $msg .= "\n"
188 unless $msg =~ /\n$/; 209 unless $msg =~ /\n$/;
189 210
190 $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;
191 212
192 utf8::encode $msg;
193 LOG llevError, $msg; 213 LOG llevError, $msg;
194 }; 214 };
195} 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#?
196 231
197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 232@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 233@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 234@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 235@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
213)) { 248)) {
214 no strict 'refs'; 249 no strict 'refs';
215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 250 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
216} 251}
217 252
218$Event::DIED = sub { 253$EV::DIED = sub {
219 warn "error in event callback: @_"; 254 warn "error in event callback: @_";
220}; 255};
221 256
222############################################################################# 257#############################################################################
223 258
… …
246 $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;
247 $d 282 $d
248 } || "[unable to dump $_[0]: '$@']"; 283 } || "[unable to dump $_[0]: '$@']";
249} 284}
250 285
251=item $ref = cf::from_json $json 286=item $ref = cf::decode_json $json
252 287
253Converts a JSON string into the corresponding perl data structure. 288Converts a JSON string into the corresponding perl data structure.
254 289
255=item $json = cf::to_json $ref 290=item $json = cf::encode_json $ref
256 291
257Converts a perl data structure into its JSON representation. 292Converts a perl data structure into its JSON representation.
258 293
259=cut 294=cut
260 295
261our $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
262 297
263sub to_json ($) { $json_coder->encode ($_[0]) } 298sub encode_json($) { $json_coder->encode ($_[0]) }
264sub from_json ($) { $json_coder->decode ($_[0]) } 299sub decode_json($) { $json_coder->decode ($_[0]) }
265 300
266=item cf::lock_wait $string 301=item cf::lock_wait $string
267 302
268Wait until the given lock is available. See cf::lock_acquire. 303Wait until the given lock is available. See cf::lock_acquire.
269 304
… …
285Return true if the lock is currently active, i.e. somebody has locked it. 320Return true if the lock is currently active, i.e. somebody has locked it.
286 321
287=cut 322=cut
288 323
289our %LOCK; 324our %LOCK;
325our %LOCKER;#d#
290 326
291sub lock_wait($) { 327sub lock_wait($) {
292 my ($key) = @_; 328 my ($key) = @_;
329
330 if ($LOCKER{$key} == $Coro::current) {#d#
331 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
332 return;#d#
333 }#d#
293 334
294 # wait for lock, if any 335 # wait for lock, if any
295 while ($LOCK{$key}) { 336 while ($LOCK{$key}) {
296 push @{ $LOCK{$key} }, $Coro::current; 337 push @{ $LOCK{$key} }, $Coro::current;
297 Coro::schedule; 338 Coro::schedule;
… …
303 344
304 # wait, to be sure we are not locked 345 # wait, to be sure we are not locked
305 lock_wait $key; 346 lock_wait $key;
306 347
307 $LOCK{$key} = []; 348 $LOCK{$key} = [];
349 $LOCKER{$key} = $Coro::current;#d#
308 350
309 Coro::guard { 351 Coro::guard {
352 delete $LOCKER{$key};#d#
310 # wake up all waiters, to be on the safe side 353 # wake up all waiters, to be on the safe side
311 $_->ready for @{ delete $LOCK{$key} }; 354 $_->ready for @{ delete $LOCK{$key} };
312 } 355 }
313} 356}
314 357
… …
317 360
318 ! ! $LOCK{$key} 361 ! ! $LOCK{$key}
319} 362}
320 363
321sub freeze_mainloop { 364sub freeze_mainloop {
322 return unless $TICK_WATCHER->is_active; 365 tick_inhibit_inc;
323 366
324 my $guard = Coro::guard { 367 Coro::guard \&tick_inhibit_dec;
325 $TICK_WATCHER->start; 368}
326 }; 369
327 $TICK_WATCHER->stop; 370=item cf::periodic $interval, $cb
328 $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
329} 383}
330 384
331=item cf::get_slot $time[, $priority[, $name]] 385=item cf::get_slot $time[, $priority[, $name]]
332 386
333Allocate $time seconds of blocking CPU time at priority C<$priority>: 387Allocate $time seconds of blocking CPU time at priority C<$priority>:
… …
344our @SLOT_QUEUE; 398our @SLOT_QUEUE;
345our $SLOT_QUEUE; 399our $SLOT_QUEUE;
346 400
347$SLOT_QUEUE->cancel if $SLOT_QUEUE; 401$SLOT_QUEUE->cancel if $SLOT_QUEUE;
348$SLOT_QUEUE = Coro::async { 402$SLOT_QUEUE = Coro::async {
403 $Coro::current->desc ("timeslot manager");
404
349 my $signal = new Coro::Signal; 405 my $signal = new Coro::Signal;
350 406
351 while () { 407 while () {
352 next_job: 408 next_job:
353 my $avail = cf::till_tick; 409 my $avail = cf::till_tick;
… …
361 } 417 }
362 } 418 }
363 } 419 }
364 420
365 if (@SLOT_QUEUE) { 421 if (@SLOT_QUEUE) {
366 # we do not use wait_For_tick() as it returns immediately when tick is inactive 422 # we do not use wait_for_tick() as it returns immediately when tick is inactive
367 push @cf::WAIT_FOR_TICK, $signal; 423 push @cf::WAIT_FOR_TICK, $signal;
368 $signal->wait; 424 $signal->wait;
369 } else { 425 } else {
370 Coro::schedule; 426 Coro::schedule;
371 } 427 }
… …
394 450
395BEGIN { *async = \&Coro::async_pool } 451BEGIN { *async = \&Coro::async_pool }
396 452
397=item cf::sync_job { BLOCK } 453=item cf::sync_job { BLOCK }
398 454
399The design of Crossfire TRT requires that the main coroutine ($Coro::main) 455The design of Deliantra requires that the main coroutine ($Coro::main)
400is always able to handle events or runnable, as Crossfire TRT is only 456is always able to handle events or runnable, as Deliantra is only
401partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 457partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
402acceptable. 458acceptable.
403 459
404If it must be done, put the blocking parts into C<sync_job>. This will run 460If it must be done, put the blocking parts into C<sync_job>. This will run
405the given BLOCK in another coroutine while waiting for the result. The 461the given BLOCK in another coroutine while waiting for the result. The
… …
410 466
411sub sync_job(&) { 467sub sync_job(&) {
412 my ($job) = @_; 468 my ($job) = @_;
413 469
414 if ($Coro::current == $Coro::main) { 470 if ($Coro::current == $Coro::main) {
415 my $time = Event::time; 471 my $time = EV::time;
416 472
417 # this is the main coro, too bad, we have to block 473 # this is the main coro, too bad, we have to block
418 # till the operation succeeds, freezing the server :/ 474 # till the operation succeeds, freezing the server :/
419 475
420 # TODO: use suspend/resume instead 476 LOG llevError, Carp::longmess "sync job";#d#
421 # (but this is cancel-safe) 477
422 my $freeze_guard = freeze_mainloop; 478 my $freeze_guard = freeze_mainloop;
423 479
424 my $busy = 1; 480 my $busy = 1;
425 my @res; 481 my @res;
426 482
427 (async { 483 (async {
484 $Coro::current->desc ("sync job coro");
428 @res = eval { $job->() }; 485 @res = eval { $job->() };
429 warn $@ if $@; 486 warn $@ if $@;
430 undef $busy; 487 undef $busy;
431 })->prio (Coro::PRIO_MAX); 488 })->prio (Coro::PRIO_MAX);
432 489
433 while ($busy) { 490 while ($busy) {
434 Coro::cede or Event::one_event; 491 if (Coro::nready) {
492 Coro::cede_notself;
493 } else {
494 EV::loop EV::LOOP_ONESHOT;
435 } 495 }
496 }
436 497
437 $time = Event::time - $time; 498 my $time = EV::time - $time;
438 499
439 LOG llevError | logBacktrace, Carp::longmess "long sync job"
440 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
441
442 $tick_start += $time; # do not account sync jobs to server load 500 $TICK_START += $time; # do not account sync jobs to server load
443 501
444 wantarray ? @res : $res[0] 502 wantarray ? @res : $res[0]
445 } else { 503 } else {
446 # we are in another coroutine, how wonderful, everything just works 504 # we are in another coroutine, how wonderful, everything just works
447 505
… …
472=item fork_call { }, $args 530=item fork_call { }, $args
473 531
474Executes the given code block with the given arguments in a seperate 532Executes the given code block with the given arguments in a seperate
475process, returning the results. Everything must be serialisable with 533process, returning the results. Everything must be serialisable with
476Coro::Storable. May, of course, block. Note that the executed sub may 534Coro::Storable. May, of course, block. Note that the executed sub may
477never block itself or use any form of Event handling. 535never block itself or use any form of event handling.
478 536
479=cut 537=cut
480 538
481sub fork_call(&@) { 539sub fork_call(&@) {
482 my ($cb, @args) = @_; 540 my ($cb, @args) = @_;
483 541
484 # we seemingly have to make a local copy of the whole thing, 542 # we seemingly have to make a local copy of the whole thing,
485 # otherwise perl prematurely frees the stuff :/ 543 # otherwise perl prematurely frees the stuff :/
486 # TODO: investigate and fix (liekly this will be rather laborious) 544 # TODO: investigate and fix (likely this will be rather laborious)
487 545
488 my @res = Coro::Util::fork_eval { 546 my @res = Coro::Util::fork_eval {
489 reset_signals; 547 reset_signals;
490 &$cb 548 &$cb
491 }, @args; 549 }, @args;
… …
500=item cf::db_put $family => $key => $value 558=item cf::db_put $family => $key => $value
501 559
502Stores the given C<$value> in the family. It can currently store binary 560Stores the given C<$value> in the family. It can currently store binary
503data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 561data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
504 562
563=item $db = cf::db_table "name"
564
565Create and/or open a new database table. The string must not be "db" and must be unique
566within each server.
567
505=cut 568=cut
569
570sub db_table($) {
571 my ($name) = @_;
572 my $db = BDB::db_create $DB_ENV;
573
574 eval {
575 $db->set_flags (BDB::CHKSUM);
576
577 utf8::encode $name;
578 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
579 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
580 cf::cleanup "db_open(db): $!" if $!;
581 };
582 cf::cleanup "db_open(db): $@" if $@;
583
584 $db
585}
506 586
507our $DB; 587our $DB;
508 588
509sub db_init { 589sub db_init {
510 unless ($DB) {
511 $DB = BDB::db_create $DB_ENV;
512
513 cf::sync_job { 590 cf::sync_job {
514 eval { 591 $DB ||= db_table "db";
515 $DB->set_flags (BDB::CHKSUM);
516
517 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
518 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
519 cf::cleanup "db_open(db): $!" if $!;
520 };
521 cf::cleanup "db_open(db): $@" if $@;
522 };
523 } 592 };
524} 593}
525 594
526sub db_get($$) { 595sub db_get($$) {
527 my $key = "$_[0]/$_[1]"; 596 my $key = "$_[0]/$_[1]";
528 597
… …
632attach callbacks/event handlers (a collection of which is called an "attachment") 701attach callbacks/event handlers (a collection of which is called an "attachment")
633to it. All such attachable objects support the following methods. 702to it. All such attachable objects support the following methods.
634 703
635In the following description, CLASS can be any of C<global>, C<object> 704In the following description, CLASS can be any of C<global>, C<object>
636C<player>, C<client> or C<map> (i.e. the attachable objects in 705C<player>, C<client> or C<map> (i.e. the attachable objects in
637Crossfire TRT). 706Deliantra).
638 707
639=over 4 708=over 4
640 709
641=item $attachable->attach ($attachment, key => $value...) 710=item $attachable->attach ($attachment, key => $value...)
642 711
… …
924 } 993 }
925 994
926 0 995 0
927} 996}
928 997
929=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 998=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
930 999
931=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1000=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
932 1001
933Generate an object-specific event with the given arguments. 1002Generate an object-specific event with the given arguments.
934 1003
… …
940 1009
941=cut 1010=cut
942 1011
943############################################################################# 1012#############################################################################
944# object support 1013# object support
945#
946 1014
1015sub _object_equal($$);
1016sub _object_equal($$) {
1017 my ($a, $b) = @_;
1018
1019 return 0 unless (ref $a) eq (ref $b);
1020
1021 if ("HASH" eq ref $a) {
1022 my @ka = keys %$a;
1023 my @kb = keys %$b;
1024
1025 return 0 if @ka != @kb;
1026
1027 for (0 .. $#ka) {
1028 return 0 unless $ka[$_] eq $kb[$_];
1029 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1030 }
1031
1032 } elsif ("ARRAY" eq ref $a) {
1033
1034 return 0 if @$a != @$b;
1035
1036 for (0 .. $#$a) {
1037 return 0 unless _object_equal $a->[$_], $b->[$_];
1038 }
1039
1040 } elsif ($a ne $b) {
1041 return 0;
1042 }
1043
1044 1
1045}
1046
1047our $SLOW_MERGES;#d#
947sub _can_merge { 1048sub _can_merge {
948 my ($ob1, $ob2) = @_; 1049 my ($ob1, $ob2) = @_;
949 1050
950 local $Storable::canonical = 1; 1051 ++$SLOW_MERGES;#d#
951 my $fob1 = Storable::freeze $ob1;
952 my $fob2 = Storable::freeze $ob2;
953 1052
954 $fob1 eq $fob2 1053 # we do the slow way here
1054 return _object_equal $ob1, $ob2
955} 1055}
956 1056
957sub reattach { 1057sub reattach {
958 # basically do the same as instantiate, without calling instantiate 1058 # basically do the same as instantiate, without calling instantiate
959 my ($obj) = @_; 1059 my ($obj) = @_;
… …
981cf::attachable->attach ( 1081cf::attachable->attach (
982 prio => -1000000, 1082 prio => -1000000,
983 on_instantiate => sub { 1083 on_instantiate => sub {
984 my ($obj, $data) = @_; 1084 my ($obj, $data) = @_;
985 1085
986 $data = from_json $data; 1086 $data = decode_json $data;
987 1087
988 for (@$data) { 1088 for (@$data) {
989 my ($name, $args) = @$_; 1089 my ($name, $args) = @$_;
990 1090
991 $obj->attach ($name, %{$args || {} }); 1091 $obj->attach ($name, %{$args || {} });
… …
1007sub object_freezer_save { 1107sub object_freezer_save {
1008 my ($filename, $rdata, $objs) = @_; 1108 my ($filename, $rdata, $objs) = @_;
1009 1109
1010 sync_job { 1110 sync_job {
1011 if (length $$rdata) { 1111 if (length $$rdata) {
1112 utf8::decode (my $decname = $filename);
1012 warn sprintf "saving %s (%d,%d)\n", 1113 warn sprintf "saving %s (%d,%d)\n",
1013 $filename, length $$rdata, scalar @$objs; 1114 $decname, length $$rdata, scalar @$objs;
1014 1115
1015 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1116 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1016 chmod SAVE_MODE, $fh; 1117 chmod SAVE_MODE, $fh;
1017 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1118 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1018 aio_fsync $fh if $cf::USE_FSYNC; 1119 aio_fsync $fh if $cf::USE_FSYNC;
1019 close $fh; 1120 close $fh;
1020 1121
1021 if (@$objs) { 1122 if (@$objs) {
1022 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1123 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1023 chmod SAVE_MODE, $fh; 1124 chmod SAVE_MODE, $fh;
1024 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1125 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1025 aio_write $fh, 0, (length $data), $data, 0; 1126 aio_write $fh, 0, (length $data), $data, 0;
1026 aio_fsync $fh if $cf::USE_FSYNC; 1127 aio_fsync $fh if $cf::USE_FSYNC;
1027 close $fh; 1128 close $fh;
1028 aio_rename "$filename.pst~", "$filename.pst"; 1129 aio_rename "$filename.pst~", "$filename.pst";
1029 } 1130 }
… …
1037 } 1138 }
1038 } else { 1139 } else {
1039 aio_unlink $filename; 1140 aio_unlink $filename;
1040 aio_unlink "$filename.pst"; 1141 aio_unlink "$filename.pst";
1041 } 1142 }
1042 } 1143 };
1043} 1144}
1044 1145
1045sub object_freezer_as_string { 1146sub object_freezer_as_string {
1046 my ($rdata, $objs) = @_; 1147 my ($rdata, $objs) = @_;
1047 1148
… …
1059 or return; 1160 or return;
1060 1161
1061 unless (aio_stat "$filename.pst") { 1162 unless (aio_stat "$filename.pst") {
1062 (aio_load "$filename.pst", $av) >= 0 1163 (aio_load "$filename.pst", $av) >= 0
1063 or return; 1164 or return;
1165
1064 $av = eval { (Storable::thaw $av)->{objs} }; 1166 my $st = eval { Coro::Storable::thaw $av };
1167 $av = $st->{objs};
1065 } 1168 }
1066 1169
1170 utf8::decode (my $decname = $filename);
1067 warn sprintf "loading %s (%d)\n", 1171 warn sprintf "loading %s (%d,%d)\n",
1068 $filename, length $data, scalar @{$av || []}; 1172 $decname, length $data, scalar @{$av || []};
1173
1069 return ($data, $av); 1174 ($data, $av)
1070} 1175}
1071 1176
1072=head2 COMMAND CALLBACKS 1177=head2 COMMAND CALLBACKS
1073 1178
1074=over 4 1179=over 4
… …
1223 my $msg = $@ ? "$v->{path}: $@\n" 1328 my $msg = $@ ? "$v->{path}: $@\n"
1224 : "$v->{base}: extension inactive.\n"; 1329 : "$v->{base}: extension inactive.\n";
1225 1330
1226 if (exists $v->{meta}{mandatory}) { 1331 if (exists $v->{meta}{mandatory}) {
1227 warn $msg; 1332 warn $msg;
1228 warn "mandatory extension failed to load, exiting.\n"; 1333 cf::cleanup "mandatory extension failed to load, exiting.";
1229 exit 1;
1230 } 1334 }
1231 1335
1232 warn $msg; 1336 warn $msg;
1233 } 1337 }
1234 1338
… …
1259use Coro::AIO; 1363use Coro::AIO;
1260 1364
1261=head3 cf::player 1365=head3 cf::player
1262 1366
1263=over 4 1367=over 4
1368
1369=item cf::player::num_playing
1370
1371Returns the official number of playing players, as per the Crossfire metaserver rules.
1372
1373=cut
1374
1375sub num_playing {
1376 scalar grep
1377 $_->ob->map
1378 && !$_->hidden
1379 && !$_->ob->flag (cf::FLAG_WIZ),
1380 cf::player::list
1381}
1264 1382
1265=item cf::player::find $login 1383=item cf::player::find $login
1266 1384
1267Returns the given player object, loading it if necessary (might block). 1385Returns the given player object, loading it if necessary (might block).
1268 1386
… …
1304 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1422 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1305 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1423 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1306 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1424 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1307 aio_unlink +(playerdir $login) . "/$login.pl"; 1425 aio_unlink +(playerdir $login) . "/$login.pl";
1308 1426
1309 my $pl = load_pl path $login 1427 my $f = new_from_file cf::object::thawer path $login
1310 or return; 1428 or return;
1429
1430 my $pl = cf::player::load_pl $f
1431 or return;
1432 local $cf::PLAYER_LOADING{$login} = $pl;
1433 $f->resolve_delayed_derefs;
1311 $cf::PLAYER{$login} = $pl 1434 $cf::PLAYER{$login} = $pl
1312 } 1435 }
1313 } 1436 }
1314} 1437}
1315 1438
… …
1413 or return []; 1536 or return [];
1414 1537
1415 my @logins; 1538 my @logins;
1416 1539
1417 for my $login (@$dirs) { 1540 for my $login (@$dirs) {
1541 my $path = path $login;
1542
1543 # a .pst is a dead give-away for a valid player
1544 unless (-e "$path.pst") {
1418 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1545 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1419 aio_read $fh, 0, 512, my $buf, 0 or next; 1546 aio_read $fh, 0, 512, my $buf, 0 or next;
1420 $buf !~ /^password -------------$/m or next; # official not-valid tag 1547 $buf !~ /^password -------------$/m or next; # official not-valid tag
1548 }
1421 1549
1422 utf8::decode $login; 1550 utf8::decode $login;
1423 push @logins, $login; 1551 push @logins, $login;
1424 } 1552 }
1425 1553
… …
1458 1586
1459Expand crossfire pod fragments into protocol xml. 1587Expand crossfire pod fragments into protocol xml.
1460 1588
1461=cut 1589=cut
1462 1590
1591use re 'eval';
1592
1593my $group;
1594my $interior; $interior = qr{
1595 # match a pod interior sequence sans C<< >>
1596 (?:
1597 \ (.*?)\ (?{ $group = $^N })
1598 | < (??{$interior}) >
1599 )
1600}x;
1601
1463sub expand_cfpod { 1602sub expand_cfpod {
1464 ((my $self), (local $_)) = @_; 1603 my ($self, $pod) = @_;
1465 1604
1466 # escape & and < 1605 my $xml;
1467 s/&/&amp;/g;
1468 s/(?<![BIUGH])</&lt;/g;
1469 1606
1470 # this is buggy, it needs to properly take care of nested <'s 1607 while () {
1608 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1609 $group = $1;
1471 1610
1472 1 while 1611 $group =~ s/&/&amp;/g;
1473 # replace B<>, I<>, U<> etc. 1612 $group =~ s/</&lt;/g;
1474 s/B<([^\>]*)>/<b>$1<\/b>/ 1613
1475 || s/I<([^\>]*)>/<i>$1<\/i>/ 1614 $xml .= $group;
1476 || s/U<([^\>]*)>/<u>$1<\/u>/ 1615 } elsif ($pod =~ m%\G
1477 # replace G<male|female> tags 1616 ([BCGHITU])
1478 || s{G<([^>|]*)\|([^>]*)>}{ 1617 <
1479 $self->gender ? $2 : $1 1618 (?:
1480 }ge 1619 ([^<>]*) (?{ $group = $^N })
1481 # replace H<hint text> 1620 | < $interior >
1482 || s{H<([^\>]*)>} 1621 )
1622 >
1623 %gcsx
1483 { 1624 ) {
1625 my ($code, $data) = ($1, $group);
1626
1627 if ($code eq "B") {
1628 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1629 } elsif ($code eq "I") {
1630 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1631 } elsif ($code eq "U") {
1632 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1633 } elsif ($code eq "C") {
1634 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1635 } elsif ($code eq "T") {
1636 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1637 } elsif ($code eq "G") {
1638 my ($male, $female) = split /\|/, $data;
1639 $data = $self->gender ? $female : $male;
1640 $xml .= expand_cfpod ($self, $data);
1641 } elsif ($code eq "H") {
1484 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1642 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1485 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1643 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1486 "") 1644 "")
1487 [$self->{hintmode}] 1645 [$self->{hintmode}];
1646 } else {
1647 $xml .= "error processing '$code($data)' directive";
1488 }ge; 1648 }
1649 } else {
1650 if ($pod =~ /\G(.+)/) {
1651 warn "parse error while expanding $pod (at $1)";
1652 }
1653 last;
1654 }
1655 }
1489 1656
1657 for ($xml) {
1490 # create single paragraphs (very hackish) 1658 # create single paragraphs (very hackish)
1491 s/(?<=\S)\n(?=\w)/ /g; 1659 s/(?<=\S)\n(?=\w)/ /g;
1492 1660
1493 # compress some whitespace 1661 # compress some whitespace
1494 s/\s+\n/\n/g; # ws line-ends 1662 s/\s+\n/\n/g; # ws line-ends
1495 s/\n\n+/\n/g; # double lines 1663 s/\n\n+/\n/g; # double lines
1496 s/^\n+//; # beginning lines 1664 s/^\n+//; # beginning lines
1497 s/\n+$//; # ending lines 1665 s/\n+$//; # ending lines
1666 }
1498 1667
1499 $_ 1668 $xml
1500} 1669}
1670
1671no re 'eval';
1501 1672
1502sub hintmode { 1673sub hintmode {
1503 $_[0]{hintmode} = $_[1] if @_ > 1; 1674 $_[0]{hintmode} = $_[1] if @_ > 1;
1504 $_[0]{hintmode} 1675 $_[0]{hintmode}
1505} 1676}
… …
1749 1920
1750sub load_header_from($) { 1921sub load_header_from($) {
1751 my ($self, $path) = @_; 1922 my ($self, $path) = @_;
1752 1923
1753 utf8::encode $path; 1924 utf8::encode $path;
1754 #aio_open $path, O_RDONLY, 0 1925 my $f = new_from_file cf::object::thawer $path
1755 # or return;
1756
1757 $self->_load_header ($path)
1758 or return; 1926 or return;
1927
1928 $self->_load_header ($f)
1929 or return;
1930
1931 local $MAP_LOADING{$self->{path}} = $self;
1932 $f->resolve_delayed_derefs;
1759 1933
1760 $self->{load_path} = $path; 1934 $self->{load_path} = $path;
1761 1935
1762 1 1936 1
1763} 1937}
… …
1817sub find { 1991sub find {
1818 my ($path, $origin) = @_; 1992 my ($path, $origin) = @_;
1819 1993
1820 $path = normalise $path, $origin && $origin->path; 1994 $path = normalise $path, $origin && $origin->path;
1821 1995
1996 cf::lock_wait "map_data:$path";#d#remove
1822 cf::lock_wait "map_find:$path"; 1997 cf::lock_wait "map_find:$path";
1823 1998
1824 $cf::MAP{$path} || do { 1999 $cf::MAP{$path} || do {
1825 my $guard = cf::lock_acquire "map_find:$path"; 2000 my $guard1 = cf::lock_acquire "map_find:$path";
2001 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
2002
1826 my $map = new_from_path cf::map $path 2003 my $map = new_from_path cf::map $path
1827 or return; 2004 or return;
1828 2005
1829 $map->{last_save} = $cf::RUNTIME; 2006 $map->{last_save} = $cf::RUNTIME;
1830 2007
… …
1832 or return; 2009 or return;
1833 2010
1834 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2011 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1835 # doing this can freeze the server in a sync job, obviously 2012 # doing this can freeze the server in a sync job, obviously
1836 #$cf::WAIT_FOR_TICK->wait; 2013 #$cf::WAIT_FOR_TICK->wait;
2014 undef $guard1;
2015 undef $guard2;
1837 $map->reset; 2016 $map->reset;
1838 undef $guard;
1839 return find $path; 2017 return find $path;
1840 } 2018 }
1841 2019
1842 $cf::MAP{$path} = $map 2020 $cf::MAP{$path} = $map
1843 } 2021 }
… …
1852 local $self->{deny_reset} = 1; # loading can take a long time 2030 local $self->{deny_reset} = 1; # loading can take a long time
1853 2031
1854 my $path = $self->{path}; 2032 my $path = $self->{path};
1855 2033
1856 { 2034 {
1857 my $guard1 = cf::lock_acquire "map_data:$path"; 2035 my $guard = cf::lock_acquire "map_data:$path";
1858 my $guard2 = cf::lock_acquire "map_load:$path";
1859 2036
2037 return unless $self->valid;
1860 return if $self->in_memory != cf::MAP_SWAPPED; 2038 return unless $self->in_memory == cf::MAP_SWAPPED;
1861 2039
1862 $self->in_memory (cf::MAP_LOADING); 2040 $self->in_memory (cf::MAP_LOADING);
1863 2041
1864 $self->alloc; 2042 $self->alloc;
1865 2043
1866 $self->pre_load; 2044 $self->pre_load;
1867 cf::cede_to_tick; 2045 cf::cede_to_tick;
1868 2046
2047 my $f = new_from_file cf::object::thawer $self->{load_path};
2048 $f->skip_block;
1869 $self->_load_objects ($self->{load_path}, 1) 2049 $self->_load_objects ($f)
1870 or return; 2050 or return;
1871 2051
1872 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2052 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1873 if delete $self->{load_original}; 2053 if delete $self->{load_original};
1874 2054
1875 if (my $uniq = $self->uniq_path) { 2055 if (my $uniq = $self->uniq_path) {
1876 utf8::encode $uniq; 2056 utf8::encode $uniq;
1877 if (aio_open $uniq, O_RDONLY, 0) { 2057 unless (aio_stat $uniq) {
2058 if (my $f = new_from_file cf::object::thawer $uniq) {
1878 $self->clear_unique_items; 2059 $self->clear_unique_items;
1879 $self->_load_objects ($uniq, 0); 2060 $self->_load_objects ($f);
2061 $f->resolve_delayed_derefs;
2062 }
1880 } 2063 }
1881 } 2064 }
2065
2066 $f->resolve_delayed_derefs;
1882 2067
1883 cf::cede_to_tick; 2068 cf::cede_to_tick;
1884 # now do the right thing for maps 2069 # now do the right thing for maps
1885 $self->link_multipart_objects; 2070 $self->link_multipart_objects;
1886 $self->difficulty ($self->estimate_difficulty) 2071 $self->difficulty ($self->estimate_difficulty)
… …
1972 } 2157 }
1973 2158
1974 $MAP_PREFETCH{$path} |= $load; 2159 $MAP_PREFETCH{$path} |= $load;
1975 2160
1976 $MAP_PREFETCHER ||= cf::async { 2161 $MAP_PREFETCHER ||= cf::async {
2162 $Coro::current->{desc} = "map prefetcher";
2163
1977 while (%MAP_PREFETCH) { 2164 while (%MAP_PREFETCH) {
1978 while (my ($k, $v) = each %MAP_PREFETCH) { 2165 while (my ($k, $v) = each %MAP_PREFETCH) {
1979 if (my $map = find $k) { 2166 if (my $map = find $k) {
1980 $map->load if $v; 2167 $map->load if $v;
1981 } 2168 }
… …
2007 return if $self->{deny_save}; 2194 return if $self->{deny_save};
2008 2195
2009 local $self->{last_access} = $self->last_access;#d# 2196 local $self->{last_access} = $self->last_access;#d#
2010 2197
2011 cf::async { 2198 cf::async {
2199 $Coro::current->{desc} = "map player save";
2012 $_->contr->save for $self->players; 2200 $_->contr->save for $self->players;
2013 }; 2201 };
2014 2202
2015 if ($uniq) { 2203 if ($uniq) {
2016 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2204 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
2030 2218
2031 return if $self->players; 2219 return if $self->players;
2032 return if $self->in_memory != cf::MAP_IN_MEMORY; 2220 return if $self->in_memory != cf::MAP_IN_MEMORY;
2033 return if $self->{deny_save}; 2221 return if $self->{deny_save};
2034 2222
2223 $self->in_memory (cf::MAP_SWAPPED);
2224
2225 $self->deactivate;
2226 $_->clear_links_to ($self) for values %cf::MAP;
2035 $self->clear; 2227 $self->clear;
2036 $self->in_memory (cf::MAP_SWAPPED);
2037} 2228}
2038 2229
2039sub reset_at { 2230sub reset_at {
2040 my ($self) = @_; 2231 my ($self) = @_;
2041 2232
… …
2073 if $uniq; 2264 if $uniq;
2074 } 2265 }
2075 2266
2076 delete $cf::MAP{$self->path}; 2267 delete $cf::MAP{$self->path};
2077 2268
2269 $self->deactivate;
2270 $_->clear_links_to ($self) for values %cf::MAP;
2078 $self->clear; 2271 $self->clear;
2079
2080 $_->clear_links_to ($self) for values %cf::MAP;
2081 2272
2082 $self->unlink_save; 2273 $self->unlink_save;
2083 $self->destroy; 2274 $self->destroy;
2084} 2275}
2085 2276
2086my $nuke_counter = "aaaa"; 2277my $nuke_counter = "aaaa";
2087 2278
2088sub nuke { 2279sub nuke {
2089 my ($self) = @_; 2280 my ($self) = @_;
2090 2281
2282 {
2283 my $lock = cf::lock_acquire "map_data:$self->{path}";
2284
2091 delete $cf::MAP{$self->path}; 2285 delete $cf::MAP{$self->path};
2092 2286
2093 $self->unlink_save; 2287 $self->unlink_save;
2094 2288
2095 bless $self, "cf::map"; 2289 bless $self, "cf::map";
2096 delete $self->{deny_reset}; 2290 delete $self->{deny_reset};
2097 $self->{deny_save} = 1; 2291 $self->{deny_save} = 1;
2098 $self->reset_timeout (1); 2292 $self->reset_timeout (1);
2099 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2293 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2100 2294
2101 $cf::MAP{$self->path} = $self; 2295 $cf::MAP{$self->path} = $self;
2296 }
2102 2297
2103 $self->reset; # polite request, might not happen 2298 $self->reset; # polite request, might not happen
2104} 2299}
2105 2300
2106=item $maps = cf::map::tmp_maps 2301=item $maps = cf::map::tmp_maps
… …
2182 2377
2183sub inv_recursive { 2378sub inv_recursive {
2184 inv_recursive_ inv $_[0] 2379 inv_recursive_ inv $_[0]
2185} 2380}
2186 2381
2382=item $ref = $ob->ref
2383
2384creates and returns a persistent reference to an objetc that can be stored as a string.
2385
2386=item $ob = cf::object::deref ($refstring)
2387
2388returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2389even if the object actually exists. May block.
2390
2391=cut
2392
2393sub deref {
2394 my ($ref) = @_;
2395
2396 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2397 my ($uuid, $name) = ($1, $2);
2398 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2399 or return;
2400 $pl->ob->uuid eq $uuid
2401 or return;
2402
2403 $pl->ob
2404 } else {
2405 warn "$ref: cannot resolve object reference\n";
2406 undef
2407 }
2408}
2409
2187package cf; 2410package cf;
2188 2411
2189=back 2412=back
2190 2413
2191=head3 cf::object::player 2414=head3 cf::object::player
… …
2349 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2572 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2350 2573
2351 $self->enter_link; 2574 $self->enter_link;
2352 2575
2353 (async { 2576 (async {
2577 $Coro::current->{desc} = "player::goto $path $x $y";
2578
2579 # *tag paths override both path and x|y
2580 if ($path =~ /^\*(.*)$/) {
2581 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2582 my $ob = $obs[rand @obs];
2583
2584 # see if we actually can go there
2585 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2586 $ob = $obs[rand @obs];
2587 } else {
2588 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2589 }
2590 # else put us there anyways for now #d#
2591
2592 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2593 } else {
2594 ($path, $x, $y) = (undef, undef, undef);
2595 }
2596 }
2597
2354 my $map = eval { 2598 my $map = eval {
2355 my $map = cf::map::find $path; 2599 my $map = defined $path ? cf::map::find $path : undef;
2356 2600
2357 if ($map) { 2601 if ($map) {
2358 $map = $map->customise_for ($self); 2602 $map = $map->customise_for ($self);
2359 $map = $check->($map) if $check && $map; 2603 $map = $check->($map) if $check && $map;
2360 } else { 2604 } else {
2361 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2605 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2362 } 2606 }
2363 2607
2364 $map 2608 $map
2365 }; 2609 };
2366 2610
… …
2419 $rmp->{origin_y} = $exit->y; 2663 $rmp->{origin_y} = $exit->y;
2420 } 2664 }
2421 2665
2422 $rmp->{random_seed} ||= $exit->random_seed; 2666 $rmp->{random_seed} ||= $exit->random_seed;
2423 2667
2424 my $data = cf::to_json $rmp; 2668 my $data = cf::encode_json $rmp;
2425 my $md5 = Digest::MD5::md5_hex $data; 2669 my $md5 = Digest::MD5::md5_hex $data;
2426 my $meta = "$RANDOMDIR/$md5.meta"; 2670 my $meta = "$RANDOMDIR/$md5.meta";
2427 2671
2428 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2672 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2429 aio_write $fh, 0, (length $data), $data, 0; 2673 aio_write $fh, 0, (length $data), $data, 0;
… …
2456 # if exit is damned, update players death & WoR home-position 2700 # if exit is damned, update players death & WoR home-position
2457 $self->contr->savebed ($slaying, $hp, $sp) 2701 $self->contr->savebed ($slaying, $hp, $sp)
2458 if $exit->flag (FLAG_DAMNED); 2702 if $exit->flag (FLAG_DAMNED);
2459 2703
2460 (async { 2704 (async {
2705 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2706
2461 $self->deactivate_recursive; # just to be sure 2707 $self->deactivate_recursive; # just to be sure
2462 unless (eval { 2708 unless (eval {
2463 $self->goto ($slaying, $hp, $sp); 2709 $self->goto ($slaying, $hp, $sp);
2464 2710
2465 1; 2711 1;
… …
2500the message, with C<log> being the default. If C<$color> is negative, suppress 2746the message, with C<log> being the default. If C<$color> is negative, suppress
2501the message unless the client supports the msg packet. 2747the message unless the client supports the msg packet.
2502 2748
2503=cut 2749=cut
2504 2750
2751# non-persistent channels (usually the info channel)
2752our %CHANNEL = (
2753 "c/identify" => {
2754 id => "infobox",
2755 title => "Identify",
2756 reply => undef,
2757 tooltip => "Items recently identified",
2758 },
2759 "c/examine" => {
2760 id => "infobox",
2761 title => "Examine",
2762 reply => undef,
2763 tooltip => "Signs and other items you examined",
2764 },
2765 "c/book" => {
2766 id => "infobox",
2767 title => "Book",
2768 reply => undef,
2769 tooltip => "The contents of a note or book",
2770 },
2771 "c/lookat" => {
2772 id => "infobox",
2773 title => "Look",
2774 reply => undef,
2775 tooltip => "What you saw there",
2776 },
2777 "c/who" => {
2778 id => "infobox",
2779 title => "Players",
2780 reply => undef,
2781 tooltip => "Shows players who are currently online",
2782 },
2783 "c/body" => {
2784 id => "infobox",
2785 title => "Body Parts",
2786 reply => undef,
2787 tooltip => "Shows which body parts you posess and are available",
2788 },
2789 "c/uptime" => {
2790 id => "infobox",
2791 title => "Uptime",
2792 reply => undef,
2793 tooltip => "How long the server has been running since last restart",
2794 },
2795 "c/mapinfo" => {
2796 id => "infobox",
2797 title => "Map Info",
2798 reply => undef,
2799 tooltip => "Information related to the maps",
2800 },
2801);
2802
2505sub cf::client::send_msg { 2803sub cf::client::send_msg {
2506 my ($self, $channel, $msg, $color, @extra) = @_; 2804 my ($self, $channel, $msg, $color, @extra) = @_;
2507 2805
2508 $msg = $self->pl->expand_cfpod ($msg); 2806 $msg = $self->pl->expand_cfpod ($msg);
2509 2807
2510 $color &= cf::NDI_CLIENT_MASK; # just in case... 2808 $color &= cf::NDI_CLIENT_MASK; # just in case...
2511 2809
2810 # check predefined channels, for the benefit of C
2811 if ($CHANNEL{$channel}) {
2812 $channel = $CHANNEL{$channel};
2813
2814 $self->ext_msg (channel_info => $channel)
2815 if $self->can_msg;
2816
2817 $channel = $channel->{id};
2818
2512 if (ref $channel) { 2819 } elsif (ref $channel) {
2513 # send meta info to client, if not yet sent 2820 # send meta info to client, if not yet sent
2514 unless (exists $self->{channel}{$channel->{id}}) { 2821 unless (exists $self->{channel}{$channel->{id}}) {
2515 $self->{channel}{$channel->{id}} = $channel; 2822 $self->{channel}{$channel->{id}} = $channel;
2516 $self->ext_msg (channel_info => $channel); 2823 $self->ext_msg (channel_info => $channel)
2824 if $self->can_msg;
2517 } 2825 }
2518 2826
2519 $channel = $channel->{id}; 2827 $channel = $channel->{id};
2520 } 2828 }
2521 2829
… …
2733=pod 3041=pod
2734 3042
2735The following functions and methods are available within a safe environment: 3043The following functions and methods are available within a safe environment:
2736 3044
2737 cf::object 3045 cf::object
2738 contr pay_amount pay_player map x y force_find force_add 3046 contr pay_amount pay_player map x y force_find force_add destroy
2739 insert remove name archname title slaying race decrease_ob_nr 3047 insert remove name archname title slaying race decrease_ob_nr
2740 3048
2741 cf::object::player 3049 cf::object::player
2742 player 3050 player
2743 3051
… …
2750=cut 3058=cut
2751 3059
2752for ( 3060for (
2753 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3061 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2754 insert remove inv name archname title slaying race 3062 insert remove inv name archname title slaying race
2755 decrease_ob_nr)], 3063 decrease_ob_nr destroy)],
2756 ["cf::object::player" => qw(player)], 3064 ["cf::object::player" => qw(player)],
2757 ["cf::player" => qw(peaceful)], 3065 ["cf::player" => qw(peaceful)],
2758 ["cf::map" => qw(trigger)], 3066 ["cf::map" => qw(trigger)],
2759) { 3067) {
2760 no strict 'refs'; 3068 no strict 'refs';
… …
2865 { 3173 {
2866 my $faces = $facedata->{faceinfo}; 3174 my $faces = $facedata->{faceinfo};
2867 3175
2868 while (my ($face, $info) = each %$faces) { 3176 while (my ($face, $info) = each %$faces) {
2869 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3177 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3178
2870 cf::face::set_visibility $idx, $info->{visibility}; 3179 cf::face::set_visibility $idx, $info->{visibility};
2871 cf::face::set_magicmap $idx, $info->{magicmap}; 3180 cf::face::set_magicmap $idx, $info->{magicmap};
2872 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3181 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2873 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3182 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2874 3183
2875 cf::cede_to_tick; 3184 cf::cede_to_tick;
2876 } 3185 }
2877 3186
2878 while (my ($face, $info) = each %$faces) { 3187 while (my ($face, $info) = each %$faces) {
2879 next unless $info->{smooth}; 3188 next unless $info->{smooth};
3189
2880 my $idx = cf::face::find $face 3190 my $idx = cf::face::find $face
2881 or next; 3191 or next;
3192
2882 if (my $smooth = cf::face::find $info->{smooth}) { 3193 if (my $smooth = cf::face::find $info->{smooth}) {
2883 cf::face::set_smooth $idx, $smooth; 3194 cf::face::set_smooth $idx, $smooth;
2884 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3195 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2885 } else { 3196 } else {
2886 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3197 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
2904 { 3215 {
2905 # TODO: for gcfclient pleasure, we should give resources 3216 # TODO: for gcfclient pleasure, we should give resources
2906 # that gcfclient doesn't grok a >10000 face index. 3217 # that gcfclient doesn't grok a >10000 face index.
2907 my $res = $facedata->{resource}; 3218 my $res = $facedata->{resource};
2908 3219
2909 my $soundconf = delete $res->{"res/sound.conf"};
2910
2911 while (my ($name, $info) = each %$res) { 3220 while (my ($name, $info) = each %$res) {
3221 if (defined $info->{type}) {
2912 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3222 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2913 my $data; 3223 my $data;
2914 3224
2915 if ($info->{type} & 1) { 3225 if ($info->{type} & 1) {
2916 # prepend meta info 3226 # prepend meta info
2917 3227
2918 my $meta = $enc->encode ({ 3228 my $meta = $enc->encode ({
2919 name => $name, 3229 name => $name,
2920 %{ $info->{meta} || {} }, 3230 %{ $info->{meta} || {} },
2921 }); 3231 });
2922 3232
2923 $data = pack "(w/a*)*", $meta, $info->{data}; 3233 $data = pack "(w/a*)*", $meta, $info->{data};
3234 } else {
3235 $data = $info->{data};
3236 }
3237
3238 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3239 cf::face::set_type $idx, $info->{type};
2924 } else { 3240 } else {
2925 $data = $info->{data}; 3241 $RESOURCE{$name} = $info;
2926 } 3242 }
2927 3243
2928 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2929 cf::face::set_type $idx, $info->{type};
2930
2931 cf::cede_to_tick; 3244 cf::cede_to_tick;
2932 } 3245 }
2933
2934 if ($soundconf) {
2935 $soundconf = $enc->decode (delete $soundconf->{data});
2936
2937 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2938 my $sound = $soundconf->{compat}[$_]
2939 or next;
2940
2941 my $face = cf::face::find "sound/$sound->[1]";
2942 cf::sound::set $sound->[0] => $face;
2943 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2944 }
2945
2946 while (my ($k, $v) = each %{$soundconf->{event}}) {
2947 my $face = cf::face::find "sound/$v";
2948 cf::sound::set $k => $face;
2949 }
2950 }
2951 } 3246 }
3247
3248 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
2952 3249
2953 1 3250 1
2954} 3251}
3252
3253cf::global->attach (on_resource_update => sub {
3254 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3255 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3256
3257 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3258 my $sound = $soundconf->{compat}[$_]
3259 or next;
3260
3261 my $face = cf::face::find "sound/$sound->[1]";
3262 cf::sound::set $sound->[0] => $face;
3263 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3264 }
3265
3266 while (my ($k, $v) = each %{$soundconf->{event}}) {
3267 my $face = cf::face::find "sound/$v";
3268 cf::sound::set $k => $face;
3269 }
3270 }
3271});
2955 3272
2956register_exticmd fx_want => sub { 3273register_exticmd fx_want => sub {
2957 my ($ns, $want) = @_; 3274 my ($ns, $want) = @_;
2958 3275
2959 while (my ($k, $v) = each %$want) { 3276 while (my ($k, $v) = each %$want) {
… …
3014sub reload_config { 3331sub reload_config {
3015 open my $fh, "<:utf8", "$CONFDIR/config" 3332 open my $fh, "<:utf8", "$CONFDIR/config"
3016 or return; 3333 or return;
3017 3334
3018 local $/; 3335 local $/;
3019 *CFG = YAML::Syck::Load <$fh>; 3336 *CFG = YAML::Load <$fh>;
3020 3337
3021 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3338 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3022 3339
3023 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3340 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3024 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3341 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3035sub main { 3352sub main {
3036 # we must not ever block the main coroutine 3353 # we must not ever block the main coroutine
3037 local $Coro::idle = sub { 3354 local $Coro::idle = sub {
3038 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3355 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3039 (async { 3356 (async {
3040 Event::one_event; 3357 $Coro::current->{desc} = "IDLE BUG HANDLER";
3358 EV::loop EV::LOOP_ONESHOT;
3041 })->prio (Coro::PRIO_MAX); 3359 })->prio (Coro::PRIO_MAX);
3042 }; 3360 };
3043 3361
3044 reload_config; 3362 reload_config;
3045 db_init; 3363 db_init;
3046 load_extensions; 3364 load_extensions;
3047 3365
3048 $TICK_WATCHER->start; 3366 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3367 evthread_start IO::AIO::poll_fileno;
3049 Event::loop; 3368 EV::loop;
3050} 3369}
3051 3370
3052############################################################################# 3371#############################################################################
3053# initialisation and cleanup 3372# initialisation and cleanup
3054 3373
3055# install some emergency cleanup handlers 3374# install some emergency cleanup handlers
3056BEGIN { 3375BEGIN {
3376 our %SIGWATCHER = ();
3057 for my $signal (qw(INT HUP TERM)) { 3377 for my $signal (qw(INT HUP TERM)) {
3058 Event->signal ( 3378 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3059 reentrant => 0,
3060 data => WF_AUTOCANCEL,
3061 signal => $signal,
3062 prio => 0,
3063 cb => sub {
3064 cf::cleanup "SIG$signal"; 3379 cf::cleanup "SIG$signal";
3065 },
3066 ); 3380 };
3067 } 3381 }
3068} 3382}
3069 3383
3070sub write_runtime { 3384sub write_runtime {
3071 my $runtime = "$LOCALDIR/runtime"; 3385 my $runtime = "$LOCALDIR/runtime";
… …
3116 # and maps saved/destroyed asynchronously. 3430 # and maps saved/destroyed asynchronously.
3117 warn "begin emergency player save\n"; 3431 warn "begin emergency player save\n";
3118 for my $login (keys %cf::PLAYER) { 3432 for my $login (keys %cf::PLAYER) {
3119 my $pl = $cf::PLAYER{$login} or next; 3433 my $pl = $cf::PLAYER{$login} or next;
3120 $pl->valid or next; 3434 $pl->valid or next;
3435 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3121 $pl->save; 3436 $pl->save;
3122 } 3437 }
3123 warn "end emergency player save\n"; 3438 warn "end emergency player save\n";
3124 3439
3125 warn "begin emergency map save\n"; 3440 warn "begin emergency map save\n";
… …
3164 warn "syncing database to disk"; 3479 warn "syncing database to disk";
3165 BDB::db_env_txn_checkpoint $DB_ENV; 3480 BDB::db_env_txn_checkpoint $DB_ENV;
3166 3481
3167 # if anything goes wrong in here, we should simply crash as we already saved 3482 # if anything goes wrong in here, we should simply crash as we already saved
3168 3483
3169 warn "cancelling all WF_AUTOCANCEL watchers";
3170 for (Event::all_watchers) {
3171 $_->cancel if $_->data & WF_AUTOCANCEL;
3172 }
3173
3174 warn "flushing outstanding aio requests"; 3484 warn "flushing outstanding aio requests";
3175 for (;;) { 3485 for (;;) {
3176 BDB::flush; 3486 BDB::flush;
3177 IO::AIO::flush; 3487 IO::AIO::flush;
3178 Coro::cede; 3488 Coro::cede_notself;
3179 last unless IO::AIO::nreqs || BDB::nreqs; 3489 last unless IO::AIO::nreqs || BDB::nreqs;
3180 warn "iterate..."; 3490 warn "iterate...";
3181 } 3491 }
3182 3492
3183 ++$RELOAD; 3493 ++$RELOAD;
… …
3259 warn "leaving sync_job"; 3569 warn "leaving sync_job";
3260 3570
3261 1 3571 1
3262 } or do { 3572 } or do {
3263 warn $@; 3573 warn $@;
3264 warn "error while reloading, exiting."; 3574 cf::cleanup "error while reloading, exiting.";
3265 exit 1;
3266 }; 3575 };
3267 3576
3268 warn "reloaded"; 3577 warn "reloaded";
3269}; 3578};
3270 3579
… …
3272 3581
3273sub reload_perl() { 3582sub reload_perl() {
3274 # doing reload synchronously and two reloads happen back-to-back, 3583 # doing reload synchronously and two reloads happen back-to-back,
3275 # coro crashes during coro_state_free->destroy here. 3584 # coro crashes during coro_state_free->destroy here.
3276 3585
3277 $RELOAD_WATCHER ||= Event->timer ( 3586 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3278 reentrant => 0,
3279 after => 0,
3280 data => WF_AUTOCANCEL,
3281 cb => sub {
3282 do_reload_perl; 3587 do_reload_perl;
3283 undef $RELOAD_WATCHER; 3588 undef $RELOAD_WATCHER;
3284 },
3285 ); 3589 };
3286} 3590}
3287 3591
3288register_command "reload" => sub { 3592register_command "reload" => sub {
3289 my ($who, $arg) = @_; 3593 my ($who, $arg) = @_;
3290 3594
3291 if ($who->flag (FLAG_WIZ)) { 3595 if ($who->flag (FLAG_WIZ)) {
3292 $who->message ("reloading server."); 3596 $who->message ("reloading server.");
3597 async {
3598 $Coro::current->{desc} = "perl_reload";
3293 async { reload_perl }; 3599 reload_perl;
3600 };
3294 } 3601 }
3295}; 3602};
3296 3603
3297unshift @INC, $LIBDIR; 3604unshift @INC, $LIBDIR;
3298 3605
… …
3300 3607
3301our @WAIT_FOR_TICK; 3608our @WAIT_FOR_TICK;
3302our @WAIT_FOR_TICK_BEGIN; 3609our @WAIT_FOR_TICK_BEGIN;
3303 3610
3304sub wait_for_tick { 3611sub wait_for_tick {
3305 return unless $TICK_WATCHER->is_active; 3612 return if tick_inhibit;
3306 return if $Coro::current == $Coro::main; 3613 return if $Coro::current == $Coro::main;
3307 3614
3308 my $signal = new Coro::Signal; 3615 my $signal = new Coro::Signal;
3309 push @WAIT_FOR_TICK, $signal; 3616 push @WAIT_FOR_TICK, $signal;
3310 $signal->wait; 3617 $signal->wait;
3311} 3618}
3312 3619
3313sub wait_for_tick_begin { 3620sub wait_for_tick_begin {
3314 return unless $TICK_WATCHER->is_active; 3621 return if tick_inhibit;
3315 return if $Coro::current == $Coro::main; 3622 return if $Coro::current == $Coro::main;
3316 3623
3317 my $signal = new Coro::Signal; 3624 my $signal = new Coro::Signal;
3318 push @WAIT_FOR_TICK_BEGIN, $signal; 3625 push @WAIT_FOR_TICK_BEGIN, $signal;
3319 $signal->wait; 3626 $signal->wait;
3320} 3627}
3321 3628
3322 my $min = 1e6;#d# 3629sub tick {
3323 my $avg = 10;
3324$TICK_WATCHER = Event->timer (
3325 reentrant => 0,
3326 parked => 1,
3327 prio => 0,
3328 at => $NEXT_TICK || $TICK,
3329 data => WF_AUTOCANCEL,
3330 cb => sub {
3331 if ($Coro::current != $Coro::main) { 3630 if ($Coro::current != $Coro::main) {
3332 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3631 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3333 unless ++$bug_warning > 10; 3632 unless ++$bug_warning > 10;
3334 return; 3633 return;
3335 } 3634 }
3336 3635
3337 $NOW = $tick_start = Event::time;
3338
3339 cf::server_tick; # one server iteration 3636 cf::server_tick; # one server iteration
3340 3637
3341 0 && sync_job {#d# 3638 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3342 for(1..10) { 3639 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3343 my $t = Event::time; 3640 Coro::async_pool {
3344 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3641 $Coro::current->{desc} = "runtime saver";
3345 or die; 3642 write_runtime
3346 3643 or warn "ERROR: unable to write runtime file: $!";
3347 $map->width (50);
3348 $map->height (50);
3349 $map->alloc;
3350 $map->_load_objects ("/tmp/x.map", 1);
3351 my $t = Event::time - $t;
3352
3353 #next unless $t < 0.0013;#d#
3354 if ($t < $min) {
3355 $min = $t;
3356 }
3357 $avg = $avg * 0.99 + $t * 0.01;
3358 }
3359 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3360 exit 0;
3361 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3362 }; 3644 };
3645 }
3363 3646
3364 $RUNTIME += $TICK;
3365 $NEXT_TICK += $TICK;
3366
3367 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3368 $NEXT_RUNTIME_WRITE = $NOW + 10;
3369 Coro::async_pool {
3370 write_runtime
3371 or warn "ERROR: unable to write runtime file: $!";
3372 };
3373 }
3374
3375# my $AFTER = Event::time;
3376# warn $AFTER - $NOW;#d#
3377
3378 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3647 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3379 $sig->send; 3648 $sig->send;
3380 } 3649 }
3381 while (my $sig = shift @WAIT_FOR_TICK) { 3650 while (my $sig = shift @WAIT_FOR_TICK) {
3382 $sig->send; 3651 $sig->send;
3383 } 3652 }
3384 3653
3385 $NOW = Event::time; 3654 $LOAD = ($NOW - $TICK_START) / $TICK;
3386
3387 # if we are delayed by four ticks or more, skip them all
3388 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3389
3390 $TICK_WATCHER->at ($NEXT_TICK);
3391 $TICK_WATCHER->start;
3392
3393 $LOAD = ($NOW - $tick_start) / $TICK;
3394 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3655 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3395 3656
3396 _post_tick; 3657 if (0) {
3397 3658 if ($NEXT_TICK) {
3398 3659 my $jitter = $TICK_START - $NEXT_TICK;
3660 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3661 warn "jitter $JITTER\n";#d#
3662 }
3399 }, 3663 }
3400); 3664}
3401 3665
3402{ 3666{
3403 BDB::max_poll_time $TICK * 0.1; 3667 # configure BDB
3404 $BDB_POLL_WATCHER = Event->io ( 3668
3405 reentrant => 0,
3406 fd => BDB::poll_fileno,
3407 poll => 'r',
3408 prio => 0,
3409 data => WF_AUTOCANCEL,
3410 cb => \&BDB::poll_cb,
3411 );
3412 BDB::min_parallel 8; 3669 BDB::min_parallel 8;
3413 3670 BDB::max_poll_reqs $TICK * 0.1;
3414 BDB::set_sync_prepare { 3671 $Coro::BDB::WATCHER->priority (1);
3415 my $status;
3416 my $current = $Coro::current;
3417 (
3418 sub {
3419 $status = $!;
3420 $current->ready; undef $current;
3421 },
3422 sub {
3423 Coro::schedule while defined $current;
3424 $! = $status;
3425 },
3426 )
3427 };
3428 3672
3429 unless ($DB_ENV) { 3673 unless ($DB_ENV) {
3430 $DB_ENV = BDB::db_env_create; 3674 $DB_ENV = BDB::db_env_create;
3675 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3676 | BDB::LOG_AUTOREMOVE, 1);
3677 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3678 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3431 3679
3432 cf::sync_job { 3680 cf::sync_job {
3433 eval { 3681 eval {
3434 BDB::db_env_open 3682 BDB::db_env_open
3435 $DB_ENV, 3683 $DB_ENV,
… …
3437 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3685 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3438 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3686 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3439 0666; 3687 0666;
3440 3688
3441 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3689 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3442
3443 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3444 $DB_ENV->set_lk_detect;
3445 }; 3690 };
3446 3691
3447 cf::cleanup "db_env_open(db): $@" if $@; 3692 cf::cleanup "db_env_open(db): $@" if $@;
3448 }; 3693 };
3449 } 3694 }
3695
3696 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3697 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3698 };
3699 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3700 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3701 };
3702 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3703 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3704 };
3450} 3705}
3451 3706
3452{ 3707{
3708 # configure IO::AIO
3709
3453 IO::AIO::min_parallel 8; 3710 IO::AIO::min_parallel 8;
3454
3455 undef $Coro::AIO::WATCHER;
3456 IO::AIO::max_poll_time $TICK * 0.1; 3711 IO::AIO::max_poll_time $TICK * 0.1;
3457 $AIO_POLL_WATCHER = Event->io ( 3712 $Coro::AIO::WATCHER->priority (1);
3458 reentrant => 0,
3459 data => WF_AUTOCANCEL,
3460 fd => IO::AIO::poll_fileno,
3461 poll => 'r',
3462 prio => 6,
3463 cb => \&IO::AIO::poll_cb,
3464 );
3465} 3713}
3466 3714
3467my $_log_backtrace; 3715my $_log_backtrace;
3468 3716
3469sub _log_backtrace { 3717sub _log_backtrace {
… …
3473 3721
3474 # limit the # of concurrent backtraces 3722 # limit the # of concurrent backtraces
3475 if ($_log_backtrace < 2) { 3723 if ($_log_backtrace < 2) {
3476 ++$_log_backtrace; 3724 ++$_log_backtrace;
3477 async { 3725 async {
3726 $Coro::current->{desc} = "abt $msg";
3727
3478 my @bt = fork_call { 3728 my @bt = fork_call {
3479 @addr = map { sprintf "%x", $_ } @addr; 3729 @addr = map { sprintf "%x", $_ } @addr;
3480 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3730 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3481 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3731 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3482 or die "addr2line: $!"; 3732 or die "addr2line: $!";

Diff Legend

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