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.349 by root, Fri Aug 31 04:10:43 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
… …
2090 2281
2091 { 2282 {
2092 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2283 my $lock = cf::lock_acquire "map_data:$self->{path}";
2093 2284
2094 delete $cf::MAP{$self->path}; 2285 delete $cf::MAP{$self->path};
2286
2287 $self->unlink_save;
2095 2288
2096 bless $self, "cf::map"; 2289 bless $self, "cf::map";
2097 delete $self->{deny_reset}; 2290 delete $self->{deny_reset};
2098 $self->{deny_save} = 1; 2291 $self->{deny_save} = 1;
2099 $self->reset_timeout (1); 2292 $self->reset_timeout (1);
2100 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2293 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2101
2102 $self->unlink_save;
2103 2294
2104 $cf::MAP{$self->path} = $self; 2295 $cf::MAP{$self->path} = $self;
2105 } 2296 }
2106 2297
2107 $self->reset; # polite request, might not happen 2298 $self->reset; # polite request, might not happen
… …
2186 2377
2187sub inv_recursive { 2378sub inv_recursive {
2188 inv_recursive_ inv $_[0] 2379 inv_recursive_ inv $_[0]
2189} 2380}
2190 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
2191package cf; 2410package cf;
2192 2411
2193=back 2412=back
2194 2413
2195=head3 cf::object::player 2414=head3 cf::object::player
… …
2353 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2572 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2354 2573
2355 $self->enter_link; 2574 $self->enter_link;
2356 2575
2357 (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
2358 my $map = eval { 2598 my $map = eval {
2359 my $map = cf::map::find $path; 2599 my $map = defined $path ? cf::map::find $path : undef;
2360 2600
2361 if ($map) { 2601 if ($map) {
2362 $map = $map->customise_for ($self); 2602 $map = $map->customise_for ($self);
2363 $map = $check->($map) if $check && $map; 2603 $map = $check->($map) if $check && $map;
2364 } else { 2604 } else {
2365 $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);
2366 } 2606 }
2367 2607
2368 $map 2608 $map
2369 }; 2609 };
2370 2610
… …
2423 $rmp->{origin_y} = $exit->y; 2663 $rmp->{origin_y} = $exit->y;
2424 } 2664 }
2425 2665
2426 $rmp->{random_seed} ||= $exit->random_seed; 2666 $rmp->{random_seed} ||= $exit->random_seed;
2427 2667
2428 my $data = cf::to_json $rmp; 2668 my $data = cf::encode_json $rmp;
2429 my $md5 = Digest::MD5::md5_hex $data; 2669 my $md5 = Digest::MD5::md5_hex $data;
2430 my $meta = "$RANDOMDIR/$md5.meta"; 2670 my $meta = "$RANDOMDIR/$md5.meta";
2431 2671
2432 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2672 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2433 aio_write $fh, 0, (length $data), $data, 0; 2673 aio_write $fh, 0, (length $data), $data, 0;
… …
2460 # if exit is damned, update players death & WoR home-position 2700 # if exit is damned, update players death & WoR home-position
2461 $self->contr->savebed ($slaying, $hp, $sp) 2701 $self->contr->savebed ($slaying, $hp, $sp)
2462 if $exit->flag (FLAG_DAMNED); 2702 if $exit->flag (FLAG_DAMNED);
2463 2703
2464 (async { 2704 (async {
2705 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2706
2465 $self->deactivate_recursive; # just to be sure 2707 $self->deactivate_recursive; # just to be sure
2466 unless (eval { 2708 unless (eval {
2467 $self->goto ($slaying, $hp, $sp); 2709 $self->goto ($slaying, $hp, $sp);
2468 2710
2469 1; 2711 1;
… …
2504the 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
2505the message unless the client supports the msg packet. 2747the message unless the client supports the msg packet.
2506 2748
2507=cut 2749=cut
2508 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
2509sub cf::client::send_msg { 2803sub cf::client::send_msg {
2510 my ($self, $channel, $msg, $color, @extra) = @_; 2804 my ($self, $channel, $msg, $color, @extra) = @_;
2511 2805
2512 $msg = $self->pl->expand_cfpod ($msg); 2806 $msg = $self->pl->expand_cfpod ($msg);
2513 2807
2514 $color &= cf::NDI_CLIENT_MASK; # just in case... 2808 $color &= cf::NDI_CLIENT_MASK; # just in case...
2515 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
2516 if (ref $channel) { 2819 } elsif (ref $channel) {
2517 # send meta info to client, if not yet sent 2820 # send meta info to client, if not yet sent
2518 unless (exists $self->{channel}{$channel->{id}}) { 2821 unless (exists $self->{channel}{$channel->{id}}) {
2519 $self->{channel}{$channel->{id}} = $channel; 2822 $self->{channel}{$channel->{id}} = $channel;
2520 $self->ext_msg (channel_info => $channel); 2823 $self->ext_msg (channel_info => $channel)
2824 if $self->can_msg;
2521 } 2825 }
2522 2826
2523 $channel = $channel->{id}; 2827 $channel = $channel->{id};
2524 } 2828 }
2525 2829
… …
2737=pod 3041=pod
2738 3042
2739The following functions and methods are available within a safe environment: 3043The following functions and methods are available within a safe environment:
2740 3044
2741 cf::object 3045 cf::object
2742 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
2743 insert remove name archname title slaying race decrease_ob_nr 3047 insert remove name archname title slaying race decrease_ob_nr
2744 3048
2745 cf::object::player 3049 cf::object::player
2746 player 3050 player
2747 3051
… …
2754=cut 3058=cut
2755 3059
2756for ( 3060for (
2757 ["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
2758 insert remove inv name archname title slaying race 3062 insert remove inv name archname title slaying race
2759 decrease_ob_nr)], 3063 decrease_ob_nr destroy)],
2760 ["cf::object::player" => qw(player)], 3064 ["cf::object::player" => qw(player)],
2761 ["cf::player" => qw(peaceful)], 3065 ["cf::player" => qw(peaceful)],
2762 ["cf::map" => qw(trigger)], 3066 ["cf::map" => qw(trigger)],
2763) { 3067) {
2764 no strict 'refs'; 3068 no strict 'refs';
… …
2869 { 3173 {
2870 my $faces = $facedata->{faceinfo}; 3174 my $faces = $facedata->{faceinfo};
2871 3175
2872 while (my ($face, $info) = each %$faces) { 3176 while (my ($face, $info) = each %$faces) {
2873 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3177 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3178
2874 cf::face::set_visibility $idx, $info->{visibility}; 3179 cf::face::set_visibility $idx, $info->{visibility};
2875 cf::face::set_magicmap $idx, $info->{magicmap}; 3180 cf::face::set_magicmap $idx, $info->{magicmap};
2876 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};
2877 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};
2878 3183
2879 cf::cede_to_tick; 3184 cf::cede_to_tick;
2880 } 3185 }
2881 3186
2882 while (my ($face, $info) = each %$faces) { 3187 while (my ($face, $info) = each %$faces) {
2883 next unless $info->{smooth}; 3188 next unless $info->{smooth};
3189
2884 my $idx = cf::face::find $face 3190 my $idx = cf::face::find $face
2885 or next; 3191 or next;
3192
2886 if (my $smooth = cf::face::find $info->{smooth}) { 3193 if (my $smooth = cf::face::find $info->{smooth}) {
2887 cf::face::set_smooth $idx, $smooth; 3194 cf::face::set_smooth $idx, $smooth;
2888 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3195 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2889 } else { 3196 } else {
2890 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3197 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
2908 { 3215 {
2909 # TODO: for gcfclient pleasure, we should give resources 3216 # TODO: for gcfclient pleasure, we should give resources
2910 # that gcfclient doesn't grok a >10000 face index. 3217 # that gcfclient doesn't grok a >10000 face index.
2911 my $res = $facedata->{resource}; 3218 my $res = $facedata->{resource};
2912 3219
2913 my $soundconf = delete $res->{"res/sound.conf"};
2914
2915 while (my ($name, $info) = each %$res) { 3220 while (my ($name, $info) = each %$res) {
3221 if (defined $info->{type}) {
2916 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3222 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2917 my $data; 3223 my $data;
2918 3224
2919 if ($info->{type} & 1) { 3225 if ($info->{type} & 1) {
2920 # prepend meta info 3226 # prepend meta info
2921 3227
2922 my $meta = $enc->encode ({ 3228 my $meta = $enc->encode ({
2923 name => $name, 3229 name => $name,
2924 %{ $info->{meta} || {} }, 3230 %{ $info->{meta} || {} },
2925 }); 3231 });
2926 3232
2927 $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};
2928 } else { 3240 } else {
2929 $data = $info->{data}; 3241 $RESOURCE{$name} = $info;
2930 } 3242 }
2931 3243
2932 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2933 cf::face::set_type $idx, $info->{type};
2934
2935 cf::cede_to_tick; 3244 cf::cede_to_tick;
2936 } 3245 }
2937
2938 if ($soundconf) {
2939 $soundconf = $enc->decode (delete $soundconf->{data});
2940
2941 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2942 my $sound = $soundconf->{compat}[$_]
2943 or next;
2944
2945 my $face = cf::face::find "sound/$sound->[1]";
2946 cf::sound::set $sound->[0] => $face;
2947 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2948 }
2949
2950 while (my ($k, $v) = each %{$soundconf->{event}}) {
2951 my $face = cf::face::find "sound/$v";
2952 cf::sound::set $k => $face;
2953 }
2954 }
2955 } 3246 }
3247
3248 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
2956 3249
2957 1 3250 1
2958} 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});
2959 3272
2960register_exticmd fx_want => sub { 3273register_exticmd fx_want => sub {
2961 my ($ns, $want) = @_; 3274 my ($ns, $want) = @_;
2962 3275
2963 while (my ($k, $v) = each %$want) { 3276 while (my ($k, $v) = each %$want) {
… …
3018sub reload_config { 3331sub reload_config {
3019 open my $fh, "<:utf8", "$CONFDIR/config" 3332 open my $fh, "<:utf8", "$CONFDIR/config"
3020 or return; 3333 or return;
3021 3334
3022 local $/; 3335 local $/;
3023 *CFG = YAML::Syck::Load <$fh>; 3336 *CFG = YAML::Load <$fh>;
3024 3337
3025 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3338 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3026 3339
3027 $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};
3028 $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};
… …
3039sub main { 3352sub main {
3040 # we must not ever block the main coroutine 3353 # we must not ever block the main coroutine
3041 local $Coro::idle = sub { 3354 local $Coro::idle = sub {
3042 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#
3043 (async { 3356 (async {
3044 Event::one_event; 3357 $Coro::current->{desc} = "IDLE BUG HANDLER";
3358 EV::loop EV::LOOP_ONESHOT;
3045 })->prio (Coro::PRIO_MAX); 3359 })->prio (Coro::PRIO_MAX);
3046 }; 3360 };
3047 3361
3048 reload_config; 3362 reload_config;
3049 db_init; 3363 db_init;
3050 load_extensions; 3364 load_extensions;
3051 3365
3052 $TICK_WATCHER->start; 3366 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3367 evthread_start IO::AIO::poll_fileno;
3053 Event::loop; 3368 EV::loop;
3054} 3369}
3055 3370
3056############################################################################# 3371#############################################################################
3057# initialisation and cleanup 3372# initialisation and cleanup
3058 3373
3059# install some emergency cleanup handlers 3374# install some emergency cleanup handlers
3060BEGIN { 3375BEGIN {
3376 our %SIGWATCHER = ();
3061 for my $signal (qw(INT HUP TERM)) { 3377 for my $signal (qw(INT HUP TERM)) {
3062 Event->signal ( 3378 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3063 reentrant => 0,
3064 data => WF_AUTOCANCEL,
3065 signal => $signal,
3066 prio => 0,
3067 cb => sub {
3068 cf::cleanup "SIG$signal"; 3379 cf::cleanup "SIG$signal";
3069 },
3070 ); 3380 };
3071 } 3381 }
3072} 3382}
3073 3383
3074sub write_runtime { 3384sub write_runtime {
3075 my $runtime = "$LOCALDIR/runtime"; 3385 my $runtime = "$LOCALDIR/runtime";
… …
3120 # and maps saved/destroyed asynchronously. 3430 # and maps saved/destroyed asynchronously.
3121 warn "begin emergency player save\n"; 3431 warn "begin emergency player save\n";
3122 for my $login (keys %cf::PLAYER) { 3432 for my $login (keys %cf::PLAYER) {
3123 my $pl = $cf::PLAYER{$login} or next; 3433 my $pl = $cf::PLAYER{$login} or next;
3124 $pl->valid or next; 3434 $pl->valid or next;
3435 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3125 $pl->save; 3436 $pl->save;
3126 } 3437 }
3127 warn "end emergency player save\n"; 3438 warn "end emergency player save\n";
3128 3439
3129 warn "begin emergency map save\n"; 3440 warn "begin emergency map save\n";
… …
3168 warn "syncing database to disk"; 3479 warn "syncing database to disk";
3169 BDB::db_env_txn_checkpoint $DB_ENV; 3480 BDB::db_env_txn_checkpoint $DB_ENV;
3170 3481
3171 # 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
3172 3483
3173 warn "cancelling all WF_AUTOCANCEL watchers";
3174 for (Event::all_watchers) {
3175 $_->cancel if $_->data & WF_AUTOCANCEL;
3176 }
3177
3178 warn "flushing outstanding aio requests"; 3484 warn "flushing outstanding aio requests";
3179 for (;;) { 3485 for (;;) {
3180 BDB::flush; 3486 BDB::flush;
3181 IO::AIO::flush; 3487 IO::AIO::flush;
3182 Coro::cede; 3488 Coro::cede_notself;
3183 last unless IO::AIO::nreqs || BDB::nreqs; 3489 last unless IO::AIO::nreqs || BDB::nreqs;
3184 warn "iterate..."; 3490 warn "iterate...";
3185 } 3491 }
3186 3492
3187 ++$RELOAD; 3493 ++$RELOAD;
… …
3263 warn "leaving sync_job"; 3569 warn "leaving sync_job";
3264 3570
3265 1 3571 1
3266 } or do { 3572 } or do {
3267 warn $@; 3573 warn $@;
3268 warn "error while reloading, exiting."; 3574 cf::cleanup "error while reloading, exiting.";
3269 exit 1;
3270 }; 3575 };
3271 3576
3272 warn "reloaded"; 3577 warn "reloaded";
3273}; 3578};
3274 3579
… …
3276 3581
3277sub reload_perl() { 3582sub reload_perl() {
3278 # doing reload synchronously and two reloads happen back-to-back, 3583 # doing reload synchronously and two reloads happen back-to-back,
3279 # coro crashes during coro_state_free->destroy here. 3584 # coro crashes during coro_state_free->destroy here.
3280 3585
3281 $RELOAD_WATCHER ||= Event->timer ( 3586 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3282 reentrant => 0,
3283 after => 0,
3284 data => WF_AUTOCANCEL,
3285 cb => sub {
3286 do_reload_perl; 3587 do_reload_perl;
3287 undef $RELOAD_WATCHER; 3588 undef $RELOAD_WATCHER;
3288 },
3289 ); 3589 };
3290} 3590}
3291 3591
3292register_command "reload" => sub { 3592register_command "reload" => sub {
3293 my ($who, $arg) = @_; 3593 my ($who, $arg) = @_;
3294 3594
3295 if ($who->flag (FLAG_WIZ)) { 3595 if ($who->flag (FLAG_WIZ)) {
3296 $who->message ("reloading server."); 3596 $who->message ("reloading server.");
3597 async {
3598 $Coro::current->{desc} = "perl_reload";
3297 async { reload_perl }; 3599 reload_perl;
3600 };
3298 } 3601 }
3299}; 3602};
3300 3603
3301unshift @INC, $LIBDIR; 3604unshift @INC, $LIBDIR;
3302 3605
… …
3304 3607
3305our @WAIT_FOR_TICK; 3608our @WAIT_FOR_TICK;
3306our @WAIT_FOR_TICK_BEGIN; 3609our @WAIT_FOR_TICK_BEGIN;
3307 3610
3308sub wait_for_tick { 3611sub wait_for_tick {
3309 return unless $TICK_WATCHER->is_active; 3612 return if tick_inhibit;
3310 return if $Coro::current == $Coro::main; 3613 return if $Coro::current == $Coro::main;
3311 3614
3312 my $signal = new Coro::Signal; 3615 my $signal = new Coro::Signal;
3313 push @WAIT_FOR_TICK, $signal; 3616 push @WAIT_FOR_TICK, $signal;
3314 $signal->wait; 3617 $signal->wait;
3315} 3618}
3316 3619
3317sub wait_for_tick_begin { 3620sub wait_for_tick_begin {
3318 return unless $TICK_WATCHER->is_active; 3621 return if tick_inhibit;
3319 return if $Coro::current == $Coro::main; 3622 return if $Coro::current == $Coro::main;
3320 3623
3321 my $signal = new Coro::Signal; 3624 my $signal = new Coro::Signal;
3322 push @WAIT_FOR_TICK_BEGIN, $signal; 3625 push @WAIT_FOR_TICK_BEGIN, $signal;
3323 $signal->wait; 3626 $signal->wait;
3324} 3627}
3325 3628
3326 my $min = 1e6;#d# 3629sub tick {
3327 my $avg = 10;
3328$TICK_WATCHER = Event->timer (
3329 reentrant => 0,
3330 parked => 1,
3331 prio => 0,
3332 at => $NEXT_TICK || $TICK,
3333 data => WF_AUTOCANCEL,
3334 cb => sub {
3335 if ($Coro::current != $Coro::main) { 3630 if ($Coro::current != $Coro::main) {
3336 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"
3337 unless ++$bug_warning > 10; 3632 unless ++$bug_warning > 10;
3338 return; 3633 return;
3339 } 3634 }
3340 3635
3341 $NOW = $tick_start = Event::time;
3342
3343 cf::server_tick; # one server iteration 3636 cf::server_tick; # one server iteration
3344 3637
3345 0 && sync_job {#d# 3638 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3346 for(1..10) { 3639 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3347 my $t = Event::time; 3640 Coro::async_pool {
3348 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3641 $Coro::current->{desc} = "runtime saver";
3349 or die; 3642 write_runtime
3350 3643 or warn "ERROR: unable to write runtime file: $!";
3351 $map->width (50);
3352 $map->height (50);
3353 $map->alloc;
3354 $map->_load_objects ("/tmp/x.map", 1);
3355 my $t = Event::time - $t;
3356
3357 #next unless $t < 0.0013;#d#
3358 if ($t < $min) {
3359 $min = $t;
3360 }
3361 $avg = $avg * 0.99 + $t * 0.01;
3362 }
3363 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3364 exit 0;
3365 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3366 }; 3644 };
3645 }
3367 3646
3368 $RUNTIME += $TICK;
3369 $NEXT_TICK += $TICK;
3370
3371 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3372 $NEXT_RUNTIME_WRITE = $NOW + 10;
3373 Coro::async_pool {
3374 write_runtime
3375 or warn "ERROR: unable to write runtime file: $!";
3376 };
3377 }
3378
3379# my $AFTER = Event::time;
3380# warn $AFTER - $NOW;#d#
3381
3382 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3647 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3383 $sig->send; 3648 $sig->send;
3384 } 3649 }
3385 while (my $sig = shift @WAIT_FOR_TICK) { 3650 while (my $sig = shift @WAIT_FOR_TICK) {
3386 $sig->send; 3651 $sig->send;
3387 } 3652 }
3388 3653
3389 $NOW = Event::time; 3654 $LOAD = ($NOW - $TICK_START) / $TICK;
3390
3391 # if we are delayed by four ticks or more, skip them all
3392 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3393
3394 $TICK_WATCHER->at ($NEXT_TICK);
3395 $TICK_WATCHER->start;
3396
3397 $LOAD = ($NOW - $tick_start) / $TICK;
3398 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3655 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3399 3656
3400 _post_tick; 3657 if (0) {
3401 3658 if ($NEXT_TICK) {
3402 3659 my $jitter = $TICK_START - $NEXT_TICK;
3660 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3661 warn "jitter $JITTER\n";#d#
3662 }
3403 }, 3663 }
3404); 3664}
3405 3665
3406{ 3666{
3407 BDB::max_poll_time $TICK * 0.1; 3667 # configure BDB
3408 $BDB_POLL_WATCHER = Event->io ( 3668
3409 reentrant => 0,
3410 fd => BDB::poll_fileno,
3411 poll => 'r',
3412 prio => 0,
3413 data => WF_AUTOCANCEL,
3414 cb => \&BDB::poll_cb,
3415 );
3416 BDB::min_parallel 8; 3669 BDB::min_parallel 8;
3417 3670 BDB::max_poll_reqs $TICK * 0.1;
3418 BDB::set_sync_prepare { 3671 $Coro::BDB::WATCHER->priority (1);
3419 my $status;
3420 my $current = $Coro::current;
3421 (
3422 sub {
3423 $status = $!;
3424 $current->ready; undef $current;
3425 },
3426 sub {
3427 Coro::schedule while defined $current;
3428 $! = $status;
3429 },
3430 )
3431 };
3432 3672
3433 unless ($DB_ENV) { 3673 unless ($DB_ENV) {
3434 $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);
3435 3679
3436 cf::sync_job { 3680 cf::sync_job {
3437 eval { 3681 eval {
3438 BDB::db_env_open 3682 BDB::db_env_open
3439 $DB_ENV, 3683 $DB_ENV,
… …
3441 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
3442 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3686 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3443 0666; 3687 0666;
3444 3688
3445 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3689 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3446
3447 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3448 $DB_ENV->set_lk_detect;
3449 }; 3690 };
3450 3691
3451 cf::cleanup "db_env_open(db): $@" if $@; 3692 cf::cleanup "db_env_open(db): $@" if $@;
3452 }; 3693 };
3453 } 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 };
3454} 3705}
3455 3706
3456{ 3707{
3708 # configure IO::AIO
3709
3457 IO::AIO::min_parallel 8; 3710 IO::AIO::min_parallel 8;
3458
3459 undef $Coro::AIO::WATCHER;
3460 IO::AIO::max_poll_time $TICK * 0.1; 3711 IO::AIO::max_poll_time $TICK * 0.1;
3461 $AIO_POLL_WATCHER = Event->io ( 3712 $Coro::AIO::WATCHER->priority (1);
3462 reentrant => 0,
3463 data => WF_AUTOCANCEL,
3464 fd => IO::AIO::poll_fileno,
3465 poll => 'r',
3466 prio => 6,
3467 cb => \&IO::AIO::poll_cb,
3468 );
3469} 3713}
3470 3714
3471my $_log_backtrace; 3715my $_log_backtrace;
3472 3716
3473sub _log_backtrace { 3717sub _log_backtrace {
… …
3477 3721
3478 # limit the # of concurrent backtraces 3722 # limit the # of concurrent backtraces
3479 if ($_log_backtrace < 2) { 3723 if ($_log_backtrace < 2) {
3480 ++$_log_backtrace; 3724 ++$_log_backtrace;
3481 async { 3725 async {
3726 $Coro::current->{desc} = "abt $msg";
3727
3482 my @bt = fork_call { 3728 my @bt = fork_call {
3483 @addr = map { sprintf "%x", $_ } @addr; 3729 @addr = map { sprintf "%x", $_ } @addr;
3484 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3730 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3485 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 |"
3486 or die "addr2line: $!"; 3732 or die "addr2line: $!";

Diff Legend

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