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.338 by root, Tue Aug 21 01:07:47 2007 UTC vs.
Revision 1.438 by elmex, Sun Jul 13 20:15:51 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;
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 ();
16use Coro::State; 37use Coro::State;
17use Coro::Handle; 38use Coro::Handle;
18use Coro::Event; 39use Coro::AnyEvent;
19use Coro::Timer; 40use Coro::Timer;
20use Coro::Signal; 41use Coro::Signal;
21use Coro::Semaphore; 42use Coro::Semaphore;
43use Coro::AnyEvent;
22use Coro::AIO; 44use Coro::AIO;
45use Coro::BDB 1.6;
23use Coro::Storable; 46use Coro::Storable;
24use Coro::Util (); 47use Coro::Util ();
25 48
26use JSON::XS 1.4 (); 49use JSON::XS 2.01 ();
27use BDB (); 50use BDB ();
28use Data::Dumper; 51use Data::Dumper;
29use Digest::MD5; 52use Digest::MD5;
30use Fcntl; 53use Fcntl;
31use YAML::Syck (); 54use YAML ();
32use IO::AIO 2.32 (); 55use IO::AIO ();
33use Time::HiRes; 56use Time::HiRes;
34use Compress::LZF; 57use Compress::LZF;
35use Digest::MD5 (); 58use Digest::MD5 ();
59
60AnyEvent::detect;
36 61
37# configure various modules to our taste 62# configure various modules to our taste
38# 63#
39$Storable::canonical = 1; # reduce rsync transfers 64$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 65Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 66Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
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 67
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 68$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49 69
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 70sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 71
… …
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 90our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 91our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 92our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 93our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 94our $BDBDIR = "$LOCALDIR/db";
95our %RESOURCE;
75 96
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 97our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 98our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 99our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 100our $USE_FSYNC = 1; # use fsync to write maps - default off
83 101
102our $BDB_DEADLOCK_WATCHER;
103our $BDB_CHECKPOINT_WATCHER;
84our $BDB_POLL_WATCHER; 104our $BDB_TRICKLE_WATCHER;
85our $DB_ENV; 105our $DB_ENV;
86 106
87our %CFG; 107our %CFG;
88 108
89our $UPTIME; $UPTIME ||= time; 109our $UPTIME; $UPTIME ||= time;
90our $RUNTIME; 110our $RUNTIME;
111our $NOW;
91 112
92our %PLAYER; # all users 113our (%PLAYER, %PLAYER_LOADING); # all users
93our %MAP; # all maps 114our (%MAP, %MAP_LOADING ); # all maps
94our $LINK_MAP; # the special {link} map, which is always available 115our $LINK_MAP; # the special {link} map, which is always available
95 116
96# used to convert map paths into valid unix filenames by replacing / by ∕ 117# used to convert map paths into valid unix filenames by replacing / by ∕
97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 118our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
98 119
99our $LOAD; # a number between 0 (idle) and 1 (too many objects) 120our $LOAD; # a number between 0 (idle) and 1 (too many objects)
100our $LOADAVG; # same thing, but with alpha-smoothing 121our $LOADAVG; # same thing, but with alpha-smoothing
122our $JITTER; # average jitter
101our $tick_start; # for load detecting purposes 123our $TICK_START; # for load detecting purposes
102 124
103binmode STDOUT; 125binmode STDOUT;
104binmode STDERR; 126binmode STDERR;
105 127
106# read virtual server time, if available 128# read virtual server time, if available
… …
159 181
160The raw value load value from the last tick. 182The raw value load value from the last tick.
161 183
162=item %cf::CFG 184=item %cf::CFG
163 185
164Configuration for the server, loaded from C</etc/crossfire/config>, or 186Configuration for the server, loaded from C</etc/deliantra-server/config>, or
165from wherever your confdir points to. 187from wherever your confdir points to.
166 188
167=item cf::wait_for_tick, cf::wait_for_tick_begin 189=item cf::wait_for_tick, cf::wait_for_tick_begin
168 190
169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 191These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
… …
187 $msg .= "\n" 209 $msg .= "\n"
188 unless $msg =~ /\n$/; 210 unless $msg =~ /\n$/;
189 211
190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 212 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191 213
192 utf8::encode $msg;
193 LOG llevError, $msg; 214 LOG llevError, $msg;
194 }; 215 };
195} 216}
217
218$Coro::State::DIEHOOK = sub {
219 return unless $^S eq 0; # "eq", not "=="
220
221 if ($Coro::current == $Coro::main) {#d#
222 warn "DIEHOOK called in main context, Coro bug?\n";#d#
223 return;#d#
224 }#d#
225
226 # kill coroutine otherwise
227 warn Carp::longmess $_[0];
228 Coro::terminate
229};
230
231$SIG{__DIE__} = sub { }; #d#?
196 232
197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 233@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 234@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 235@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 236@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
213)) { 249)) {
214 no strict 'refs'; 250 no strict 'refs';
215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 251 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
216} 252}
217 253
218$Event::DIED = sub { 254$EV::DIED = sub {
219 warn "error in event callback: @_"; 255 warn "error in event callback: @_";
220}; 256};
221 257
222############################################################################# 258#############################################################################
223 259
… …
246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 282 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
247 $d 283 $d
248 } || "[unable to dump $_[0]: '$@']"; 284 } || "[unable to dump $_[0]: '$@']";
249} 285}
250 286
251=item $ref = cf::from_json $json 287=item $ref = cf::decode_json $json
252 288
253Converts a JSON string into the corresponding perl data structure. 289Converts a JSON string into the corresponding perl data structure.
254 290
255=item $json = cf::to_json $ref 291=item $json = cf::encode_json $ref
256 292
257Converts a perl data structure into its JSON representation. 293Converts a perl data structure into its JSON representation.
258 294
259=cut 295=cut
260 296
261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 297our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
262 298
263sub to_json ($) { $json_coder->encode ($_[0]) } 299sub encode_json($) { $json_coder->encode ($_[0]) }
264sub from_json ($) { $json_coder->decode ($_[0]) } 300sub decode_json($) { $json_coder->decode ($_[0]) }
265 301
266=item cf::lock_wait $string 302=item cf::lock_wait $string
267 303
268Wait until the given lock is available. See cf::lock_acquire. 304Wait until the given lock is available. See cf::lock_acquire.
269 305
… …
272Wait until the given lock is available and then acquires it and returns 308Wait until the given lock is available and then acquires it and returns
273a Coro::guard object. If the guard object gets destroyed (goes out of scope, 309a Coro::guard object. If the guard object gets destroyed (goes out of scope,
274for example when the coroutine gets canceled), the lock is automatically 310for example when the coroutine gets canceled), the lock is automatically
275returned. 311returned.
276 312
313Locks are *not* recursive, locking from the same coro twice results in a
314deadlocked coro.
315
277Lock names should begin with a unique identifier (for example, cf::map::find 316Lock names should begin with a unique identifier (for example, cf::map::find
278uses map_find and cf::map::load uses map_load). 317uses map_find and cf::map::load uses map_load).
279 318
280=item $locked = cf::lock_active $string 319=item $locked = cf::lock_active $string
281 320
282Return true if the lock is currently active, i.e. somebody has locked it. 321Return true if the lock is currently active, i.e. somebody has locked it.
283 322
284=cut 323=cut
285 324
286our %LOCK; 325our %LOCK;
326our %LOCKER;#d#
287 327
288sub lock_wait($) { 328sub lock_wait($) {
289 my ($key) = @_; 329 my ($key) = @_;
330
331 if ($LOCKER{$key} == $Coro::current) {#d#
332 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
333 return;#d#
334 }#d#
290 335
291 # wait for lock, if any 336 # wait for lock, if any
292 while ($LOCK{$key}) { 337 while ($LOCK{$key}) {
293 push @{ $LOCK{$key} }, $Coro::current; 338 push @{ $LOCK{$key} }, $Coro::current;
294 Coro::schedule; 339 Coro::schedule;
… …
300 345
301 # wait, to be sure we are not locked 346 # wait, to be sure we are not locked
302 lock_wait $key; 347 lock_wait $key;
303 348
304 $LOCK{$key} = []; 349 $LOCK{$key} = [];
350 $LOCKER{$key} = $Coro::current;#d#
305 351
306 Coro::guard { 352 Coro::guard {
353 delete $LOCKER{$key};#d#
307 # wake up all waiters, to be on the safe side 354 # wake up all waiters, to be on the safe side
308 $_->ready for @{ delete $LOCK{$key} }; 355 $_->ready for @{ delete $LOCK{$key} };
309 } 356 }
310} 357}
311 358
… …
314 361
315 ! ! $LOCK{$key} 362 ! ! $LOCK{$key}
316} 363}
317 364
318sub freeze_mainloop { 365sub freeze_mainloop {
319 return unless $TICK_WATCHER->is_active; 366 tick_inhibit_inc;
320 367
321 my $guard = Coro::guard { 368 Coro::guard \&tick_inhibit_dec;
322 $TICK_WATCHER->start; 369}
323 }; 370
324 $TICK_WATCHER->stop; 371=item cf::periodic $interval, $cb
325 $guard 372
373Like EV::periodic, but randomly selects a starting point so that the actions
374get spread over timer.
375
376=cut
377
378sub periodic($$) {
379 my ($interval, $cb) = @_;
380
381 my $start = rand List::Util::min 180, $interval;
382
383 EV::periodic $start, $interval, 0, $cb
326} 384}
327 385
328=item cf::get_slot $time[, $priority[, $name]] 386=item cf::get_slot $time[, $priority[, $name]]
329 387
330Allocate $time seconds of blocking CPU time at priority C<$priority>: 388Allocate $time seconds of blocking CPU time at priority C<$priority>:
… …
341our @SLOT_QUEUE; 399our @SLOT_QUEUE;
342our $SLOT_QUEUE; 400our $SLOT_QUEUE;
343 401
344$SLOT_QUEUE->cancel if $SLOT_QUEUE; 402$SLOT_QUEUE->cancel if $SLOT_QUEUE;
345$SLOT_QUEUE = Coro::async { 403$SLOT_QUEUE = Coro::async {
404 $Coro::current->desc ("timeslot manager");
405
346 my $signal = new Coro::Signal; 406 my $signal = new Coro::Signal;
347 407
348 while () { 408 while () {
349 next_job: 409 next_job:
350 my $avail = cf::till_tick; 410 my $avail = cf::till_tick;
… …
358 } 418 }
359 } 419 }
360 } 420 }
361 421
362 if (@SLOT_QUEUE) { 422 if (@SLOT_QUEUE) {
363 # we do not use wait_For_tick() as it returns immediately when tick is inactive 423 # we do not use wait_for_tick() as it returns immediately when tick is inactive
364 push @cf::WAIT_FOR_TICK, $signal; 424 push @cf::WAIT_FOR_TICK, $signal;
365 $signal->wait; 425 $signal->wait;
366 } else { 426 } else {
367 Coro::schedule; 427 Coro::schedule;
368 } 428 }
369 } 429 }
370}; 430};
371 431
372sub get_slot($;$$) { 432sub get_slot($;$$) {
433 return if tick_inhibit || $Coro::current == $Coro::main;
434
373 my ($time, $pri, $name) = @_; 435 my ($time, $pri, $name) = @_;
374 436
375 $time = $TICK * .6 if $time > $TICK * .6; 437 $time = $TICK * .6 if $time > $TICK * .6;
376 my $sig = new Coro::Signal; 438 my $sig = new Coro::Signal;
377 439
… …
391 453
392BEGIN { *async = \&Coro::async_pool } 454BEGIN { *async = \&Coro::async_pool }
393 455
394=item cf::sync_job { BLOCK } 456=item cf::sync_job { BLOCK }
395 457
396The design of Crossfire TRT requires that the main coroutine ($Coro::main) 458The design of Deliantra requires that the main coroutine ($Coro::main)
397is always able to handle events or runnable, as Crossfire TRT is only 459is always able to handle events or runnable, as Deliantra is only
398partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 460partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
399acceptable. 461acceptable.
400 462
401If it must be done, put the blocking parts into C<sync_job>. This will run 463If it must be done, put the blocking parts into C<sync_job>. This will run
402the given BLOCK in another coroutine while waiting for the result. The 464the given BLOCK in another coroutine while waiting for the result. The
… …
407 469
408sub sync_job(&) { 470sub sync_job(&) {
409 my ($job) = @_; 471 my ($job) = @_;
410 472
411 if ($Coro::current == $Coro::main) { 473 if ($Coro::current == $Coro::main) {
412 my $time = Event::time; 474 my $time = EV::time;
413 475
414 # this is the main coro, too bad, we have to block 476 # this is the main coro, too bad, we have to block
415 # till the operation succeeds, freezing the server :/ 477 # till the operation succeeds, freezing the server :/
416 478
417 # TODO: use suspend/resume instead 479 LOG llevError, Carp::longmess "sync job";#d#
418 # (but this is cancel-safe) 480
419 my $freeze_guard = freeze_mainloop; 481 my $freeze_guard = freeze_mainloop;
420 482
421 my $busy = 1; 483 my $busy = 1;
422 my @res; 484 my @res;
423 485
424 (async { 486 (async {
487 $Coro::current->desc ("sync job coro");
425 @res = eval { $job->() }; 488 @res = eval { $job->() };
426 warn $@ if $@; 489 warn $@ if $@;
427 undef $busy; 490 undef $busy;
428 })->prio (Coro::PRIO_MAX); 491 })->prio (Coro::PRIO_MAX);
429 492
430 while ($busy) { 493 while ($busy) {
431 Coro::cede or Event::one_event; 494 if (Coro::nready) {
495 Coro::cede_notself;
496 } else {
497 EV::loop EV::LOOP_ONESHOT;
432 } 498 }
499 }
433 500
434 $time = Event::time - $time; 501 my $time = EV::time - $time;
435 502
436 LOG llevError | logBacktrace, Carp::longmess "long sync job"
437 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
438
439 $tick_start += $time; # do not account sync jobs to server load 503 $TICK_START += $time; # do not account sync jobs to server load
440 504
441 wantarray ? @res : $res[0] 505 wantarray ? @res : $res[0]
442 } else { 506 } else {
443 # we are in another coroutine, how wonderful, everything just works 507 # we are in another coroutine, how wonderful, everything just works
444 508
… …
469=item fork_call { }, $args 533=item fork_call { }, $args
470 534
471Executes the given code block with the given arguments in a seperate 535Executes the given code block with the given arguments in a seperate
472process, returning the results. Everything must be serialisable with 536process, returning the results. Everything must be serialisable with
473Coro::Storable. May, of course, block. Note that the executed sub may 537Coro::Storable. May, of course, block. Note that the executed sub may
474never block itself or use any form of Event handling. 538never block itself or use any form of event handling.
475 539
476=cut 540=cut
477 541
478sub fork_call(&@) { 542sub fork_call(&@) {
479 my ($cb, @args) = @_; 543 my ($cb, @args) = @_;
480 544
481 # we seemingly have to make a local copy of the whole thing, 545 # we seemingly have to make a local copy of the whole thing,
482 # otherwise perl prematurely frees the stuff :/ 546 # otherwise perl prematurely frees the stuff :/
483 # TODO: investigate and fix (liekly this will be rather laborious) 547 # TODO: investigate and fix (likely this will be rather laborious)
484 548
485 my @res = Coro::Util::fork_eval { 549 my @res = Coro::Util::fork_eval {
486 reset_signals; 550 reset_signals;
487 &$cb 551 &$cb
488 }, @args; 552 }, @args;
489 553
490 wantarray ? @res : $res[-1] 554 wantarray ? @res : $res[-1]
491} 555}
492 556
557=item $coin = coin_from_name $name
558
559=cut
560
561our %coin_alias = (
562 "silver" => "silvercoin",
563 "silvercoin" => "silvercoin",
564 "silvercoins" => "silvercoin",
565 "gold" => "goldcoin",
566 "goldcoin" => "goldcoin",
567 "goldcoins" => "goldcoin",
568 "platinum" => "platinacoin",
569 "platinumcoin" => "platinacoin",
570 "platinumcoins" => "platinacoin",
571 "platina" => "platinacoin",
572 "platinacoin" => "platinacoin",
573 "platinacoins" => "platinacoin",
574 "royalty" => "royalty",
575 "royalties" => "royalty",
576);
577
578sub coin_from_name($) {
579 $coin_alias{$_[0]}
580 ? cf::arch::find $coin_alias{$_[0]}
581 : undef
582}
583
493=item $value = cf::db_get $family => $key 584=item $value = cf::db_get $family => $key
494 585
495Returns a single value from the environment database. 586Returns a single value from the environment database.
496 587
497=item cf::db_put $family => $key => $value 588=item cf::db_put $family => $key => $value
498 589
499Stores the given C<$value> in the family. It can currently store binary 590Stores the given C<$value> in the family. It can currently store binary
500data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 591data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
501 592
593=item $db = cf::db_table "name"
594
595Create and/or open a new database table. The string must not be "db" and must be unique
596within each server.
597
502=cut 598=cut
599
600sub db_table($) {
601 my ($name) = @_;
602 my $db = BDB::db_create $DB_ENV;
603
604 eval {
605 $db->set_flags (BDB::CHKSUM);
606
607 utf8::encode $name;
608 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
609 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
610 cf::cleanup "db_open(db): $!" if $!;
611 };
612 cf::cleanup "db_open(db): $@" if $@;
613
614 $db
615}
503 616
504our $DB; 617our $DB;
505 618
506sub db_init { 619sub db_init {
507 unless ($DB) {
508 $DB = BDB::db_create $DB_ENV;
509
510 cf::sync_job { 620 cf::sync_job {
511 eval { 621 $DB ||= db_table "db";
512 $DB->set_flags (BDB::CHKSUM);
513
514 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
515 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
516 cf::cleanup "db_open(db): $!" if $!;
517 };
518 cf::cleanup "db_open(db): $@" if $@;
519 };
520 } 622 };
521} 623}
522 624
523sub db_get($$) { 625sub db_get($$) {
524 my $key = "$_[0]/$_[1]"; 626 my $key = "$_[0]/$_[1]";
525 627
… …
575 if (1) { 677 if (1) {
576 $md5 = 678 $md5 =
577 join "\x00", 679 join "\x00",
578 $processversion, 680 $processversion,
579 map { 681 map {
580 Coro::cede; 682 cf::cede_to_tick;
581 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 683 ($src->[$_], Digest::MD5::md5_hex $data[$_])
582 } 0.. $#$src; 684 } 0.. $#$src;
583 685
584 686
585 my $dbmd5 = db_get cache => "$id/md5"; 687 my $dbmd5 = db_get cache => "$id/md5";
… …
629attach callbacks/event handlers (a collection of which is called an "attachment") 731attach callbacks/event handlers (a collection of which is called an "attachment")
630to it. All such attachable objects support the following methods. 732to it. All such attachable objects support the following methods.
631 733
632In the following description, CLASS can be any of C<global>, C<object> 734In the following description, CLASS can be any of C<global>, C<object>
633C<player>, C<client> or C<map> (i.e. the attachable objects in 735C<player>, C<client> or C<map> (i.e. the attachable objects in
634Crossfire TRT). 736Deliantra).
635 737
636=over 4 738=over 4
637 739
638=item $attachable->attach ($attachment, key => $value...) 740=item $attachable->attach ($attachment, key => $value...)
639 741
… …
921 } 1023 }
922 1024
923 0 1025 0
924} 1026}
925 1027
926=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1028=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
927 1029
928=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1030=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
929 1031
930Generate an object-specific event with the given arguments. 1032Generate an object-specific event with the given arguments.
931 1033
… …
937 1039
938=cut 1040=cut
939 1041
940############################################################################# 1042#############################################################################
941# object support 1043# object support
942#
943 1044
1045sub _object_equal($$);
1046sub _object_equal($$) {
1047 my ($a, $b) = @_;
1048
1049 return 0 unless (ref $a) eq (ref $b);
1050
1051 if ("HASH" eq ref $a) {
1052 my @ka = keys %$a;
1053 my @kb = keys %$b;
1054
1055 return 0 if @ka != @kb;
1056
1057 for (0 .. $#ka) {
1058 return 0 unless $ka[$_] eq $kb[$_];
1059 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1060 }
1061
1062 } elsif ("ARRAY" eq ref $a) {
1063
1064 return 0 if @$a != @$b;
1065
1066 for (0 .. $#$a) {
1067 return 0 unless _object_equal $a->[$_], $b->[$_];
1068 }
1069
1070 } elsif ($a ne $b) {
1071 return 0;
1072 }
1073
1074 1
1075}
1076
1077our $SLOW_MERGES;#d#
944sub _can_merge { 1078sub _can_merge {
945 my ($ob1, $ob2) = @_; 1079 my ($ob1, $ob2) = @_;
946 1080
947 local $Storable::canonical = 1; 1081 ++$SLOW_MERGES;#d#
948 my $fob1 = Storable::freeze $ob1;
949 my $fob2 = Storable::freeze $ob2;
950 1082
951 $fob1 eq $fob2 1083 # we do the slow way here
1084 return _object_equal $ob1, $ob2
952} 1085}
953 1086
954sub reattach { 1087sub reattach {
955 # basically do the same as instantiate, without calling instantiate 1088 # basically do the same as instantiate, without calling instantiate
956 my ($obj) = @_; 1089 my ($obj) = @_;
… …
978cf::attachable->attach ( 1111cf::attachable->attach (
979 prio => -1000000, 1112 prio => -1000000,
980 on_instantiate => sub { 1113 on_instantiate => sub {
981 my ($obj, $data) = @_; 1114 my ($obj, $data) = @_;
982 1115
983 $data = from_json $data; 1116 $data = decode_json $data;
984 1117
985 for (@$data) { 1118 for (@$data) {
986 my ($name, $args) = @$_; 1119 my ($name, $args) = @$_;
987 1120
988 $obj->attach ($name, %{$args || {} }); 1121 $obj->attach ($name, %{$args || {} });
… …
1004sub object_freezer_save { 1137sub object_freezer_save {
1005 my ($filename, $rdata, $objs) = @_; 1138 my ($filename, $rdata, $objs) = @_;
1006 1139
1007 sync_job { 1140 sync_job {
1008 if (length $$rdata) { 1141 if (length $$rdata) {
1142 utf8::decode (my $decname = $filename);
1009 warn sprintf "saving %s (%d,%d)\n", 1143 warn sprintf "saving %s (%d,%d)\n",
1010 $filename, length $$rdata, scalar @$objs; 1144 $decname, length $$rdata, scalar @$objs;
1011 1145
1012 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1146 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1013 chmod SAVE_MODE, $fh; 1147 aio_chmod $fh, SAVE_MODE;
1014 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1148 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1015 aio_fsync $fh if $cf::USE_FSYNC; 1149 aio_fsync $fh if $cf::USE_FSYNC;
1016 close $fh; 1150 aio_close $fh;
1017 1151
1018 if (@$objs) { 1152 if (@$objs) {
1019 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1153 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1020 chmod SAVE_MODE, $fh; 1154 aio_chmod $fh, SAVE_MODE;
1021 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1155 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1022 aio_write $fh, 0, (length $data), $data, 0; 1156 aio_write $fh, 0, (length $data), $data, 0;
1023 aio_fsync $fh if $cf::USE_FSYNC; 1157 aio_fsync $fh if $cf::USE_FSYNC;
1024 close $fh; 1158 aio_close $fh;
1025 aio_rename "$filename.pst~", "$filename.pst"; 1159 aio_rename "$filename.pst~", "$filename.pst";
1026 } 1160 }
1027 } else { 1161 } else {
1028 aio_unlink "$filename.pst"; 1162 aio_unlink "$filename.pst";
1029 } 1163 }
… …
1034 } 1168 }
1035 } else { 1169 } else {
1036 aio_unlink $filename; 1170 aio_unlink $filename;
1037 aio_unlink "$filename.pst"; 1171 aio_unlink "$filename.pst";
1038 } 1172 }
1039 } 1173 };
1040} 1174}
1041 1175
1042sub object_freezer_as_string { 1176sub object_freezer_as_string {
1043 my ($rdata, $objs) = @_; 1177 my ($rdata, $objs) = @_;
1044 1178
… …
1056 or return; 1190 or return;
1057 1191
1058 unless (aio_stat "$filename.pst") { 1192 unless (aio_stat "$filename.pst") {
1059 (aio_load "$filename.pst", $av) >= 0 1193 (aio_load "$filename.pst", $av) >= 0
1060 or return; 1194 or return;
1195
1061 $av = eval { (Storable::thaw $av)->{objs} }; 1196 my $st = eval { Coro::Storable::thaw $av };
1197 $av = $st->{objs};
1062 } 1198 }
1063 1199
1200 utf8::decode (my $decname = $filename);
1064 warn sprintf "loading %s (%d)\n", 1201 warn sprintf "loading %s (%d,%d)\n",
1065 $filename, length $data, scalar @{$av || []}; 1202 $decname, length $data, scalar @{$av || []};
1203
1066 return ($data, $av); 1204 ($data, $av)
1067} 1205}
1068 1206
1069=head2 COMMAND CALLBACKS 1207=head2 COMMAND CALLBACKS
1070 1208
1071=over 4 1209=over 4
… …
1220 my $msg = $@ ? "$v->{path}: $@\n" 1358 my $msg = $@ ? "$v->{path}: $@\n"
1221 : "$v->{base}: extension inactive.\n"; 1359 : "$v->{base}: extension inactive.\n";
1222 1360
1223 if (exists $v->{meta}{mandatory}) { 1361 if (exists $v->{meta}{mandatory}) {
1224 warn $msg; 1362 warn $msg;
1225 warn "mandatory extension failed to load, exiting.\n"; 1363 cf::cleanup "mandatory extension failed to load, exiting.";
1226 exit 1;
1227 } 1364 }
1228 1365
1229 warn $msg; 1366 warn $msg;
1230 } 1367 }
1231 1368
… …
1256use Coro::AIO; 1393use Coro::AIO;
1257 1394
1258=head3 cf::player 1395=head3 cf::player
1259 1396
1260=over 4 1397=over 4
1398
1399=item cf::player::num_playing
1400
1401Returns the official number of playing players, as per the Crossfire metaserver rules.
1402
1403=cut
1404
1405sub num_playing {
1406 scalar grep
1407 $_->ob->map
1408 && !$_->hidden
1409 && !$_->ob->flag (cf::FLAG_WIZ),
1410 cf::player::list
1411}
1261 1412
1262=item cf::player::find $login 1413=item cf::player::find $login
1263 1414
1264Returns the given player object, loading it if necessary (might block). 1415Returns the given player object, loading it if necessary (might block).
1265 1416
… …
1301 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1452 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1302 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1453 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1303 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1454 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1304 aio_unlink +(playerdir $login) . "/$login.pl"; 1455 aio_unlink +(playerdir $login) . "/$login.pl";
1305 1456
1306 my $pl = load_pl path $login 1457 my $f = new_from_file cf::object::thawer path $login
1307 or return; 1458 or return;
1459
1460 my $pl = cf::player::load_pl $f
1461 or return;
1462
1463 local $cf::PLAYER_LOADING{$login} = $pl;
1464 $f->resolve_delayed_derefs;
1308 $cf::PLAYER{$login} = $pl 1465 $cf::PLAYER{$login} = $pl
1309 } 1466 }
1310 } 1467 }
1311} 1468}
1312 1469
… …
1321 return if $pl->{deny_save}; 1478 return if $pl->{deny_save};
1322 1479
1323 aio_mkdir playerdir $pl, 0770; 1480 aio_mkdir playerdir $pl, 0770;
1324 $pl->{last_save} = $cf::RUNTIME; 1481 $pl->{last_save} = $cf::RUNTIME;
1325 1482
1483 cf::get_slot 0.01;
1484
1326 $pl->save_pl ($path); 1485 $pl->save_pl ($path);
1327 Coro::cede; 1486 cf::cede_to_tick;
1328} 1487}
1329 1488
1330sub new($) { 1489sub new($) {
1331 my ($login) = @_; 1490 my ($login) = @_;
1332 1491
… …
1365 $pl->{deny_save} = 1; 1524 $pl->{deny_save} = 1;
1366 $pl->password ("*"); # this should lock out the player until we nuked the dir 1525 $pl->password ("*"); # this should lock out the player until we nuked the dir
1367 1526
1368 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1527 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1369 $pl->deactivate; 1528 $pl->deactivate;
1529 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1530 $pl->ob->check_score;
1370 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1531 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1371 $pl->ns->destroy if $pl->ns; 1532 $pl->ns->destroy if $pl->ns;
1372 1533
1373 my $path = playerdir $pl; 1534 my $path = playerdir $pl;
1374 my $temp = "$path~$cf::RUNTIME~deleting~"; 1535 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1410 or return []; 1571 or return [];
1411 1572
1412 my @logins; 1573 my @logins;
1413 1574
1414 for my $login (@$dirs) { 1575 for my $login (@$dirs) {
1576 my $path = path $login;
1577
1578 # a .pst is a dead give-away for a valid player
1579 # if no pst file found, open and chekc for blocked users
1580 if (aio_stat "$path.pst") {
1415 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1581 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1416 aio_read $fh, 0, 512, my $buf, 0 or next; 1582 aio_read $fh, 0, 512, my $buf, 0 or next;
1417 $buf !~ /^password -------------$/m or next; # official not-valid tag 1583 $buf !~ /^password -------------$/m or next; # official not-valid tag
1584 }
1418 1585
1419 utf8::decode $login; 1586 utf8::decode $login;
1420 push @logins, $login; 1587 push @logins, $login;
1421 } 1588 }
1422 1589
… …
1455 1622
1456Expand crossfire pod fragments into protocol xml. 1623Expand crossfire pod fragments into protocol xml.
1457 1624
1458=cut 1625=cut
1459 1626
1627use re 'eval';
1628
1629my $group;
1630my $interior; $interior = qr{
1631 # match a pod interior sequence sans C<< >>
1632 (?:
1633 \ (.*?)\ (?{ $group = $^N })
1634 | < (??{$interior}) >
1635 )
1636}x;
1637
1460sub expand_cfpod { 1638sub expand_cfpod {
1461 ((my $self), (local $_)) = @_; 1639 my ($self, $pod) = @_;
1462 1640
1463 # escape & and < 1641 my $xml;
1464 s/&/&amp;/g;
1465 s/(?<![BIUGH])</&lt;/g;
1466 1642
1467 # this is buggy, it needs to properly take care of nested <'s 1643 while () {
1644 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1645 $group = $1;
1468 1646
1469 1 while 1647 $group =~ s/&/&amp;/g;
1470 # replace B<>, I<>, U<> etc. 1648 $group =~ s/</&lt;/g;
1471 s/B<([^\>]*)>/<b>$1<\/b>/ 1649
1472 || s/I<([^\>]*)>/<i>$1<\/i>/ 1650 $xml .= $group;
1473 || s/U<([^\>]*)>/<u>$1<\/u>/ 1651 } elsif ($pod =~ m%\G
1474 # replace G<male|female> tags 1652 ([BCGHITU])
1475 || s{G<([^>|]*)\|([^>]*)>}{ 1653 <
1476 $self->gender ? $2 : $1 1654 (?:
1477 }ge 1655 ([^<>]*) (?{ $group = $^N })
1478 # replace H<hint text> 1656 | < $interior >
1479 || s{H<([^\>]*)>} 1657 )
1658 >
1659 %gcsx
1480 { 1660 ) {
1661 my ($code, $data) = ($1, $group);
1662
1663 if ($code eq "B") {
1664 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1665 } elsif ($code eq "I") {
1666 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1667 } elsif ($code eq "U") {
1668 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1669 } elsif ($code eq "C") {
1670 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1671 } elsif ($code eq "T") {
1672 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1673 } elsif ($code eq "G") {
1674 my ($male, $female) = split /\|/, $data;
1675 $data = $self->gender ? $female : $male;
1676 $xml .= expand_cfpod ($self, $data);
1677 } elsif ($code eq "H") {
1481 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1678 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1482 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1679 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1483 "") 1680 "")
1484 [$self->{hintmode}] 1681 [$self->{hintmode}];
1682 } else {
1683 $xml .= "error processing '$code($data)' directive";
1485 }ge; 1684 }
1685 } else {
1686 if ($pod =~ /\G(.+)/) {
1687 warn "parse error while expanding $pod (at $1)";
1688 }
1689 last;
1690 }
1691 }
1486 1692
1693 for ($xml) {
1487 # create single paragraphs (very hackish) 1694 # create single paragraphs (very hackish)
1488 s/(?<=\S)\n(?=\w)/ /g; 1695 s/(?<=\S)\n(?=\w)/ /g;
1489 1696
1490 # compress some whitespace 1697 # compress some whitespace
1491 s/\s+\n/\n/g; # ws line-ends 1698 s/\s+\n/\n/g; # ws line-ends
1492 s/\n\n+/\n/g; # double lines 1699 s/\n\n+/\n/g; # double lines
1493 s/^\n+//; # beginning lines 1700 s/^\n+//; # beginning lines
1494 s/\n+$//; # ending lines 1701 s/\n+$//; # ending lines
1702 }
1495 1703
1496 $_ 1704 $xml
1497} 1705}
1706
1707no re 'eval';
1498 1708
1499sub hintmode { 1709sub hintmode {
1500 $_[0]{hintmode} = $_[1] if @_ > 1; 1710 $_[0]{hintmode} = $_[1] if @_ > 1;
1501 $_[0]{hintmode} 1711 $_[0]{hintmode}
1502} 1712}
… …
1574our $MAX_RESET = 3600; 1784our $MAX_RESET = 3600;
1575our $DEFAULT_RESET = 3000; 1785our $DEFAULT_RESET = 3000;
1576 1786
1577sub generate_random_map { 1787sub generate_random_map {
1578 my ($self, $rmp) = @_; 1788 my ($self, $rmp) = @_;
1789
1790 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1791
1579 # mit "rum" bekleckern, nicht 1792 # mit "rum" bekleckern, nicht
1580 $self->_create_random_map ( 1793 $self->_create_random_map (
1581 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1794 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1582 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1795 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1583 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1796 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1705 1918
1706# the temporary/swap location 1919# the temporary/swap location
1707sub save_path { 1920sub save_path {
1708 my ($self) = @_; 1921 my ($self) = @_;
1709 1922
1710 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1923 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1711 "$TMPDIR/$path.map" 1924 "$TMPDIR/$path.map"
1712} 1925}
1713 1926
1714# the unique path, undef == no special unique path 1927# the unique path, undef == no special unique path
1715sub uniq_path { 1928sub uniq_path {
1716 my ($self) = @_; 1929 my ($self) = @_;
1717 1930
1718 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1931 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1719 "$UNIQUEDIR/$path" 1932 "$UNIQUEDIR/$path"
1720} 1933}
1721 1934
1722# and all this just because we cannot iterate over 1935# and all this just because we cannot iterate over
1723# all maps in C++... 1936# all maps in C++...
… …
1746 1959
1747sub load_header_from($) { 1960sub load_header_from($) {
1748 my ($self, $path) = @_; 1961 my ($self, $path) = @_;
1749 1962
1750 utf8::encode $path; 1963 utf8::encode $path;
1751 #aio_open $path, O_RDONLY, 0 1964 my $f = new_from_file cf::object::thawer $path
1752 # or return;
1753
1754 $self->_load_header ($path)
1755 or return; 1965 or return;
1966
1967 $self->_load_header ($f)
1968 or return;
1969
1970 local $MAP_LOADING{$self->{path}} = $self;
1971 $f->resolve_delayed_derefs;
1756 1972
1757 $self->{load_path} = $path; 1973 $self->{load_path} = $path;
1758 1974
1759 1 1975 1
1760} 1976}
… …
1814sub find { 2030sub find {
1815 my ($path, $origin) = @_; 2031 my ($path, $origin) = @_;
1816 2032
1817 $path = normalise $path, $origin && $origin->path; 2033 $path = normalise $path, $origin && $origin->path;
1818 2034
2035 cf::lock_wait "map_data:$path";#d#remove
1819 cf::lock_wait "map_find:$path"; 2036 cf::lock_wait "map_find:$path";
1820 2037
1821 $cf::MAP{$path} || do { 2038 $cf::MAP{$path} || do {
2039 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1822 my $guard = cf::lock_acquire "map_find:$path"; 2040 my $guard2 = cf::lock_acquire "map_find:$path";
2041
1823 my $map = new_from_path cf::map $path 2042 my $map = new_from_path cf::map $path
1824 or return; 2043 or return;
1825 2044
1826 $map->{last_save} = $cf::RUNTIME; 2045 $map->{last_save} = $cf::RUNTIME;
1827 2046
… …
1829 or return; 2048 or return;
1830 2049
1831 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2050 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1832 # doing this can freeze the server in a sync job, obviously 2051 # doing this can freeze the server in a sync job, obviously
1833 #$cf::WAIT_FOR_TICK->wait; 2052 #$cf::WAIT_FOR_TICK->wait;
2053 undef $guard2;
2054 undef $guard1;
1834 $map->reset; 2055 $map->reset;
1835 undef $guard;
1836 return find $path; 2056 return find $path;
1837 } 2057 }
1838 2058
1839 $cf::MAP{$path} = $map 2059 $cf::MAP{$path} = $map
1840 } 2060 }
… …
1849 local $self->{deny_reset} = 1; # loading can take a long time 2069 local $self->{deny_reset} = 1; # loading can take a long time
1850 2070
1851 my $path = $self->{path}; 2071 my $path = $self->{path};
1852 2072
1853 { 2073 {
1854 my $guard = cf::lock_acquire "map_load:$path"; 2074 my $guard = cf::lock_acquire "map_data:$path";
1855 2075
2076 return unless $self->valid;
1856 return if $self->in_memory != cf::MAP_SWAPPED; 2077 return unless $self->in_memory == cf::MAP_SWAPPED;
1857 2078
1858 $self->in_memory (cf::MAP_LOADING); 2079 $self->in_memory (cf::MAP_LOADING);
1859 2080
1860 $self->alloc; 2081 $self->alloc;
1861 2082
1862 $self->pre_load; 2083 $self->pre_load;
1863 Coro::cede; 2084 cf::cede_to_tick;
1864 2085
2086 my $f = new_from_file cf::object::thawer $self->{load_path};
2087 $f->skip_block;
1865 $self->_load_objects ($self->{load_path}, 1) 2088 $self->_load_objects ($f)
1866 or return; 2089 or return;
1867 2090
1868 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2091 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1869 if delete $self->{load_original}; 2092 if delete $self->{load_original};
1870 2093
1871 if (my $uniq = $self->uniq_path) { 2094 if (my $uniq = $self->uniq_path) {
1872 utf8::encode $uniq; 2095 utf8::encode $uniq;
1873 if (aio_open $uniq, O_RDONLY, 0) { 2096 unless (aio_stat $uniq) {
2097 if (my $f = new_from_file cf::object::thawer $uniq) {
1874 $self->clear_unique_items; 2098 $self->clear_unique_items;
1875 $self->_load_objects ($uniq, 0); 2099 $self->_load_objects ($f);
2100 $f->resolve_delayed_derefs;
2101 }
1876 } 2102 }
1877 } 2103 }
1878 2104
1879 Coro::cede; 2105 $f->resolve_delayed_derefs;
2106
2107 cf::cede_to_tick;
1880 # now do the right thing for maps 2108 # now do the right thing for maps
1881 $self->link_multipart_objects; 2109 $self->link_multipart_objects;
1882 $self->difficulty ($self->estimate_difficulty) 2110 $self->difficulty ($self->estimate_difficulty)
1883 unless $self->difficulty; 2111 unless $self->difficulty;
1884 Coro::cede; 2112 cf::cede_to_tick;
1885 2113
1886 unless ($self->{deny_activate}) { 2114 unless ($self->{deny_activate}) {
1887 $self->decay_objects; 2115 $self->decay_objects;
1888 $self->fix_auto_apply; 2116 $self->fix_auto_apply;
1889 $self->update_buttons; 2117 $self->update_buttons;
1890 Coro::cede; 2118 cf::cede_to_tick;
1891 $self->set_darkness_map; 2119 $self->set_darkness_map;
1892 Coro::cede; 2120 cf::cede_to_tick;
1893 $self->activate; 2121 $self->activate;
1894 } 2122 }
1895 2123
1896 $self->{last_save} = $cf::RUNTIME; 2124 $self->{last_save} = $cf::RUNTIME;
1897 $self->last_access ($cf::RUNTIME); 2125 $self->last_access ($cf::RUNTIME);
1898 2126
1899 $self->in_memory (cf::MAP_IN_MEMORY); 2127 $self->in_memory (cf::MAP_ACTIVE);
1900 } 2128 }
1901 2129
1902 $self->post_load; 2130 $self->post_load;
1903} 2131}
1904 2132
… …
1947} 2175}
1948 2176
1949sub do_load_sync { 2177sub do_load_sync {
1950 my ($map) = @_; 2178 my ($map) = @_;
1951 2179
2180 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2181 if $Coro::current == $Coro::main;
2182
1952 cf::sync_job { $map->load }; 2183 cf::sync_job { $map->load };
1953} 2184}
1954 2185
1955our %MAP_PREFETCH; 2186our %MAP_PREFETCH;
1956our $MAP_PREFETCHER = undef; 2187our $MAP_PREFETCHER = undef;
1957 2188
1958sub find_async { 2189sub find_async {
1959 my ($path, $origin) = @_; 2190 my ($path, $origin, $load) = @_;
1960 2191
1961 $path = normalise $path, $origin && $origin->{path}; 2192 $path = normalise $path, $origin && $origin->{path};
1962 2193
1963 if (my $map = $cf::MAP{$path}) { 2194 if (my $map = $cf::MAP{$path}) {
1964 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2195 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1965 } 2196 }
1966 2197
1967 undef $MAP_PREFETCH{$path}; 2198 $MAP_PREFETCH{$path} |= $load;
2199
1968 $MAP_PREFETCHER ||= cf::async { 2200 $MAP_PREFETCHER ||= cf::async {
2201 $Coro::current->{desc} = "map prefetcher";
2202
1969 while (%MAP_PREFETCH) { 2203 while (%MAP_PREFETCH) {
1970 for my $path (keys %MAP_PREFETCH) { 2204 while (my ($k, $v) = each %MAP_PREFETCH) {
1971 if (my $map = find $path) { 2205 if (my $map = find $k) {
1972 $map->load; 2206 $map->load if $v;
1973 } 2207 }
1974 2208
1975 delete $MAP_PREFETCH{$path}; 2209 delete $MAP_PREFETCH{$k};
1976 } 2210 }
1977 } 2211 }
1978 undef $MAP_PREFETCHER; 2212 undef $MAP_PREFETCHER;
1979 }; 2213 };
1980 $MAP_PREFETCHER->prio (6); 2214 $MAP_PREFETCHER->prio (6);
… …
1983} 2217}
1984 2218
1985sub save { 2219sub save {
1986 my ($self) = @_; 2220 my ($self) = @_;
1987 2221
1988 my $lock = cf::lock_acquire "map_data:" . $self->path; 2222 my $lock = cf::lock_acquire "map_data:$self->{path}";
1989 2223
1990 $self->{last_save} = $cf::RUNTIME; 2224 $self->{last_save} = $cf::RUNTIME;
1991 2225
1992 return unless $self->dirty; 2226 return unless $self->dirty;
1993 2227
… …
1999 return if $self->{deny_save}; 2233 return if $self->{deny_save};
2000 2234
2001 local $self->{last_access} = $self->last_access;#d# 2235 local $self->{last_access} = $self->last_access;#d#
2002 2236
2003 cf::async { 2237 cf::async {
2238 $Coro::current->{desc} = "map player save";
2004 $_->contr->save for $self->players; 2239 $_->contr->save for $self->players;
2005 }; 2240 };
2241
2242 cf::get_slot 0.02;
2006 2243
2007 if ($uniq) { 2244 if ($uniq) {
2008 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2245 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2009 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2246 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2010 } else { 2247 } else {
… …
2016 my ($self) = @_; 2253 my ($self) = @_;
2017 2254
2018 # save first because save cedes 2255 # save first because save cedes
2019 $self->save; 2256 $self->save;
2020 2257
2021 my $lock = cf::lock_acquire "map_data:" . $self->path; 2258 my $lock = cf::lock_acquire "map_data:$self->{path}";
2022 2259
2023 return if $self->players; 2260 return if $self->players;
2024 return if $self->in_memory != cf::MAP_IN_MEMORY; 2261 return if $self->in_memory != cf::MAP_ACTIVE;
2025 return if $self->{deny_save}; 2262 return if $self->{deny_save};
2026 2263
2264 $self->in_memory (cf::MAP_SWAPPED);
2265
2266 $self->deactivate;
2267 $_->clear_links_to ($self) for values %cf::MAP;
2027 $self->clear; 2268 $self->clear;
2028 $self->in_memory (cf::MAP_SWAPPED);
2029} 2269}
2030 2270
2031sub reset_at { 2271sub reset_at {
2032 my ($self) = @_; 2272 my ($self) = @_;
2033 2273
… …
2065 if $uniq; 2305 if $uniq;
2066 } 2306 }
2067 2307
2068 delete $cf::MAP{$self->path}; 2308 delete $cf::MAP{$self->path};
2069 2309
2310 $self->deactivate;
2311 $_->clear_links_to ($self) for values %cf::MAP;
2070 $self->clear; 2312 $self->clear;
2071
2072 $_->clear_links_to ($self) for values %cf::MAP;
2073 2313
2074 $self->unlink_save; 2314 $self->unlink_save;
2075 $self->destroy; 2315 $self->destroy;
2076} 2316}
2077 2317
2078my $nuke_counter = "aaaa"; 2318my $nuke_counter = "aaaa";
2079 2319
2080sub nuke { 2320sub nuke {
2081 my ($self) = @_; 2321 my ($self) = @_;
2082 2322
2323 {
2324 my $lock = cf::lock_acquire "map_data:$self->{path}";
2325
2083 delete $cf::MAP{$self->path}; 2326 delete $cf::MAP{$self->path};
2084 2327
2085 $self->unlink_save; 2328 $self->unlink_save;
2086 2329
2087 bless $self, "cf::map"; 2330 bless $self, "cf::map";
2088 delete $self->{deny_reset}; 2331 delete $self->{deny_reset};
2089 $self->{deny_save} = 1; 2332 $self->{deny_save} = 1;
2090 $self->reset_timeout (1); 2333 $self->reset_timeout (1);
2091 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2334 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2092 2335
2093 $cf::MAP{$self->path} = $self; 2336 $cf::MAP{$self->path} = $self;
2337 }
2094 2338
2095 $self->reset; # polite request, might not happen 2339 $self->reset; # polite request, might not happen
2096} 2340}
2097 2341
2098=item $maps = cf::map::tmp_maps 2342=item $maps = cf::map::tmp_maps
… …
2140 2384
2141sub unique_maps() { 2385sub unique_maps() {
2142 [ 2386 [
2143 map { 2387 map {
2144 utf8::decode $_; 2388 utf8::decode $_;
2145 /\.map$/ 2389 s/\.map$//; # TODO future compatibility hack
2390 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2391 ? ()
2146 ? normalise $_ 2392 : normalise $_
2147 : ()
2148 } @{ aio_readdir $UNIQUEDIR or [] } 2393 } @{ aio_readdir $UNIQUEDIR or [] }
2149 ] 2394 ]
2150} 2395}
2151 2396
2152package cf;
2153
2154=back 2397=back
2155 2398
2156=head3 cf::object 2399=head3 cf::object
2157 2400
2158=cut 2401=cut
… …
2161 2404
2162=over 4 2405=over 4
2163 2406
2164=item $ob->inv_recursive 2407=item $ob->inv_recursive
2165 2408
2166Returns the inventory of the object _and_ their inventories, recursively. 2409Returns the inventory of the object I<and> their inventories, recursively,
2410but I<not> the object itself.
2167 2411
2168=cut 2412=cut
2169 2413
2170sub inv_recursive_; 2414sub inv_recursive_;
2171sub inv_recursive_ { 2415sub inv_recursive_ {
… …
2174 2418
2175sub inv_recursive { 2419sub inv_recursive {
2176 inv_recursive_ inv $_[0] 2420 inv_recursive_ inv $_[0]
2177} 2421}
2178 2422
2423=item $ref = $ob->ref
2424
2425Creates and returns a persistent reference to an object that can be stored as a string.
2426
2427=item $ob = cf::object::deref ($refstring)
2428
2429returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2430even if the object actually exists. May block.
2431
2432=cut
2433
2434sub deref {
2435 my ($ref) = @_;
2436
2437 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2438 my ($uuid, $name) = ($1, $2);
2439 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2440 or return;
2441 $pl->ob->uuid eq $uuid
2442 or return;
2443
2444 $pl->ob
2445 } else {
2446 warn "$ref: cannot resolve object reference\n";
2447 undef
2448 }
2449}
2450
2179package cf; 2451package cf;
2180 2452
2181=back 2453=back
2182 2454
2183=head3 cf::object::player 2455=head3 cf::object::player
… …
2189Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2461Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
2190can be C<undef>. Does the right thing when the player is currently in a 2462can be C<undef>. Does the right thing when the player is currently in a
2191dialogue with the given NPC character. 2463dialogue with the given NPC character.
2192 2464
2193=cut 2465=cut
2466
2467our $SAY_CHANNEL = {
2468 id => "say",
2469 title => "Map",
2470 reply => "say ",
2471 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2472};
2473
2474our $CHAT_CHANNEL = {
2475 id => "chat",
2476 title => "Chat",
2477 reply => "chat ",
2478 tooltip => "Player chat and shouts, global to the server.",
2479};
2194 2480
2195# rough implementation of a future "reply" method that works 2481# rough implementation of a future "reply" method that works
2196# with dialog boxes. 2482# with dialog boxes.
2197#TODO: the first argument must go, split into a $npc->reply_to ( method 2483#TODO: the first argument must go, split into a $npc->reply_to ( method
2198sub cf::object::player::reply($$$;$) { 2484sub cf::object::player::reply($$$;$) {
… …
2210 my $dialog = $pl->{npc_dialog}; 2496 my $dialog = $pl->{npc_dialog};
2211 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2497 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2212 2498
2213 } else { 2499 } else {
2214 $msg = $npc->name . " says: $msg" if $npc; 2500 $msg = $npc->name . " says: $msg" if $npc;
2215 $self->message ($msg, $flags); 2501 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2216 } 2502 }
2217 } 2503 }
2218} 2504}
2219 2505
2220=item $object->send_msg ($channel, $msg, $color, [extra...]) 2506=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2328her, loading and preparing them map, calling the provided $check callback 2614her, loading and preparing them map, calling the provided $check callback
2329that has to return the map if sucecssful, and then unfreezes the player on 2615that has to return the map if sucecssful, and then unfreezes the player on
2330the new (success) or old (failed) map position. In either case, $done will 2616the new (success) or old (failed) map position. In either case, $done will
2331be called at the end of this process. 2617be called at the end of this process.
2332 2618
2619Note that $check will be called with a potentially non-loaded map, so if
2620it needs a loaded map it has to call C<< ->load >>.
2621
2333=cut 2622=cut
2334 2623
2335our $GOTOGEN; 2624our $GOTOGEN;
2336 2625
2337sub cf::object::player::goto { 2626sub cf::object::player::goto {
… …
2341 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2630 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2342 2631
2343 $self->enter_link; 2632 $self->enter_link;
2344 2633
2345 (async { 2634 (async {
2635 $Coro::current->{desc} = "player::goto $path $x $y";
2636
2637 # *tag paths override both path and x|y
2638 if ($path =~ /^\*(.*)$/) {
2639 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2640 my $ob = $obs[rand @obs];
2641
2642 # see if we actually can go there
2643 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2644 $ob = $obs[rand @obs];
2645 } else {
2646 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2647 }
2648 # else put us there anyways for now #d#
2649
2650 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2651 } else {
2652 ($path, $x, $y) = (undef, undef, undef);
2653 }
2654 }
2655
2346 my $map = eval { 2656 my $map = eval {
2347 my $map = cf::map::find $path; 2657 my $map = defined $path ? cf::map::find $path : undef;
2348 2658
2349 if ($map) { 2659 if ($map) {
2350 $map = $map->customise_for ($self); 2660 $map = $map->customise_for ($self);
2351 $map = $check->($map) if $check && $map; 2661 $map = $check->($map) if $check && $map;
2352 } else { 2662 } else {
2353 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2663 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2354 } 2664 }
2355 2665
2356 $map 2666 $map
2357 }; 2667 };
2358 2668
… …
2394} 2704}
2395 2705
2396sub prepare_random_map { 2706sub prepare_random_map {
2397 my ($exit) = @_; 2707 my ($exit) = @_;
2398 2708
2399 my $guard = cf::lock_acquire "exit_prepare:$exit";
2400
2401 # all this does is basically replace the /! path by 2709 # all this does is basically replace the /! path by
2402 # a new random map path (?random/...) with a seed 2710 # a new random map path (?random/...) with a seed
2403 # that depends on the exit object 2711 # that depends on the exit object
2404 2712
2405 my $rmp = parse_random_map_params $exit->msg; 2713 my $rmp = parse_random_map_params $exit->msg;
… …
2407 if ($exit->map) { 2715 if ($exit->map) {
2408 $rmp->{region} = $exit->region->name; 2716 $rmp->{region} = $exit->region->name;
2409 $rmp->{origin_map} = $exit->map->path; 2717 $rmp->{origin_map} = $exit->map->path;
2410 $rmp->{origin_x} = $exit->x; 2718 $rmp->{origin_x} = $exit->x;
2411 $rmp->{origin_y} = $exit->y; 2719 $rmp->{origin_y} = $exit->y;
2720
2721 $exit->map->touch;
2412 } 2722 }
2413 2723
2414 $rmp->{random_seed} ||= $exit->random_seed; 2724 $rmp->{random_seed} ||= $exit->random_seed;
2415 2725
2416 my $data = cf::to_json $rmp; 2726 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2417 my $md5 = Digest::MD5::md5_hex $data; 2727 my $md5 = Digest::MD5::md5_hex $data;
2418 my $meta = "$RANDOMDIR/$md5.meta"; 2728 my $meta = "$RANDOMDIR/$md5.meta";
2419 2729
2420 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2730 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2421 aio_write $fh, 0, (length $data), $data, 0; 2731 aio_write $fh, 0, (length $data), $data, 0;
2422 undef $fh; 2732 undef $fh;
2423 aio_rename "$meta~", $meta; 2733 aio_rename "$meta~", $meta;
2424 2734
2735 my $slaying = "?random/$md5";
2736
2737 if ($exit->valid) {
2425 $exit->slaying ("?random/$md5"); 2738 $exit->slaying ("?random/$md5");
2426 $exit->msg (undef); 2739 $exit->msg (undef);
2740 }
2427 } 2741 }
2428} 2742}
2429 2743
2430sub cf::object::player::enter_exit { 2744sub cf::object::player::enter_exit {
2431 my ($self, $exit) = @_; 2745 my ($self, $exit) = @_;
2432 2746
2433 return unless $self->type == cf::PLAYER; 2747 return unless $self->type == cf::PLAYER;
2434 2748
2435 if ($exit->slaying eq "/!") {
2436 #TODO: this should de-fi-ni-te-ly not be a sync-job
2437 # the problem is that $exit might not survive long enough
2438 # so it needs to be done right now, right here
2439 cf::sync_job { prepare_random_map $exit };
2440 }
2441
2442 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2443 my $hp = $exit->stats->hp;
2444 my $sp = $exit->stats->sp;
2445
2446 $self->enter_link; 2749 $self->enter_link;
2447 2750
2448 # if exit is damned, update players death & WoR home-position
2449 $self->contr->savebed ($slaying, $hp, $sp)
2450 if $exit->flag (FLAG_DAMNED);
2451
2452 (async { 2751 (async {
2453 $self->deactivate_recursive; # just to be sure 2752 $Coro::current->{desc} = "enter_exit";
2753
2454 unless (eval { 2754 unless (eval {
2755 $self->deactivate_recursive; # just to be sure
2756
2757 # random map handling
2758 {
2759 my $guard = cf::lock_acquire "exit_prepare:$exit";
2760
2761 prepare_random_map $exit
2762 if $exit->slaying eq "/!";
2763 }
2764
2765 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2766 my $x = $exit->stats->hp;
2767 my $y = $exit->stats->sp;
2768
2455 $self->goto ($slaying, $hp, $sp); 2769 $self->goto ($map, $x, $y);
2456 2770
2771 # if exit is damned, update players death & WoR home-position
2772 $self->contr->savebed ($map, $x, $y)
2773 if $exit->flag (cf::FLAG_DAMNED);
2774
2457 1; 2775 1
2458 }) { 2776 }) {
2459 $self->message ("Something went wrong deep within the crossfire server. " 2777 $self->message ("Something went wrong deep within the crossfire server. "
2460 . "I'll try to bring you back to the map you were before. " 2778 . "I'll try to bring you back to the map you were before. "
2461 . "Please report this to the dungeon master!", 2779 . "Please report this to the dungeon master!",
2462 cf::NDI_UNIQUE | cf::NDI_RED); 2780 cf::NDI_UNIQUE | cf::NDI_RED);
… …
2492the message, with C<log> being the default. If C<$color> is negative, suppress 2810the message, with C<log> being the default. If C<$color> is negative, suppress
2493the message unless the client supports the msg packet. 2811the message unless the client supports the msg packet.
2494 2812
2495=cut 2813=cut
2496 2814
2815# non-persistent channels (usually the info channel)
2816our %CHANNEL = (
2817 "c/identify" => {
2818 id => "infobox",
2819 title => "Identify",
2820 reply => undef,
2821 tooltip => "Items recently identified",
2822 },
2823 "c/examine" => {
2824 id => "infobox",
2825 title => "Examine",
2826 reply => undef,
2827 tooltip => "Signs and other items you examined",
2828 },
2829 "c/book" => {
2830 id => "infobox",
2831 title => "Book",
2832 reply => undef,
2833 tooltip => "The contents of a note or book",
2834 },
2835 "c/lookat" => {
2836 id => "infobox",
2837 title => "Look",
2838 reply => undef,
2839 tooltip => "What you saw there",
2840 },
2841 "c/who" => {
2842 id => "infobox",
2843 title => "Players",
2844 reply => undef,
2845 tooltip => "Shows players who are currently online",
2846 },
2847 "c/body" => {
2848 id => "infobox",
2849 title => "Body Parts",
2850 reply => undef,
2851 tooltip => "Shows which body parts you posess and are available",
2852 },
2853 "c/uptime" => {
2854 id => "infobox",
2855 title => "Uptime",
2856 reply => undef,
2857 tooltip => "How long the server has been running since last restart",
2858 },
2859 "c/mapinfo" => {
2860 id => "infobox",
2861 title => "Map Info",
2862 reply => undef,
2863 tooltip => "Information related to the maps",
2864 },
2865 "c/party" => {
2866 id => "party",
2867 title => "Party",
2868 reply => "gsay ",
2869 tooltip => "Messages and chat related to your party",
2870 },
2871);
2872
2497sub cf::client::send_msg { 2873sub cf::client::send_msg {
2498 my ($self, $channel, $msg, $color, @extra) = @_; 2874 my ($self, $channel, $msg, $color, @extra) = @_;
2499 2875
2500 $msg = $self->pl->expand_cfpod ($msg); 2876 $msg = $self->pl->expand_cfpod ($msg);
2501 2877
2502 $color &= cf::NDI_CLIENT_MASK; # just in case... 2878 $color &= cf::NDI_CLIENT_MASK; # just in case...
2503 2879
2880 # check predefined channels, for the benefit of C
2881 if ($CHANNEL{$channel}) {
2882 $channel = $CHANNEL{$channel};
2883
2884 $self->ext_msg (channel_info => $channel)
2885 if $self->can_msg;
2886
2887 $channel = $channel->{id};
2888
2504 if (ref $channel) { 2889 } elsif (ref $channel) {
2505 # send meta info to client, if not yet sent 2890 # send meta info to client, if not yet sent
2506 unless (exists $self->{channel}{$channel->{id}}) { 2891 unless (exists $self->{channel}{$channel->{id}}) {
2507 $self->{channel}{$channel->{id}} = $channel; 2892 $self->{channel}{$channel->{id}} = $channel;
2508 $self->ext_msg (channel_info => $channel); 2893 $self->ext_msg (channel_info => $channel)
2894 if $self->can_msg;
2509 } 2895 }
2510 2896
2511 $channel = $channel->{id}; 2897 $channel = $channel->{id};
2512 } 2898 }
2513 2899
… …
2554=cut 2940=cut
2555 2941
2556sub cf::client::ext_msg($$@) { 2942sub cf::client::ext_msg($$@) {
2557 my ($self, $type, @msg) = @_; 2943 my ($self, $type, @msg) = @_;
2558 2944
2559 my $extcmd = $self->extcmd;
2560
2561 if ($extcmd == 2) { 2945 if ($self->extcmd == 2) {
2562 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 2946 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2563 } elsif ($extcmd == 1) { # TODO: remove 2947 } elsif ($self->extcmd == 1) { # TODO: remove
2564 push @msg, msgtype => "event_$type"; 2948 push @msg, msgtype => "event_$type";
2565 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 2949 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2566 } 2950 }
2567} 2951}
2568 2952
… …
2575sub cf::client::ext_reply($$@) { 2959sub cf::client::ext_reply($$@) {
2576 my ($self, $id, @msg) = @_; 2960 my ($self, $id, @msg) = @_;
2577 2961
2578 if ($self->extcmd == 2) { 2962 if ($self->extcmd == 2) {
2579 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 2963 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2580 } elsif ($self->ns->extcmd == 1) { 2964 } elsif ($self->extcmd == 1) {
2581 #TODO: version 1, remove 2965 #TODO: version 1, remove
2582 unshift @msg, msgtype => "reply", msgid => $id; 2966 unshift @msg, msgtype => "reply", msgid => $id;
2583 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 2967 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2584 } 2968 }
2585} 2969}
… …
2727=pod 3111=pod
2728 3112
2729The following functions and methods are available within a safe environment: 3113The following functions and methods are available within a safe environment:
2730 3114
2731 cf::object 3115 cf::object
2732 contr pay_amount pay_player map x y force_find force_add 3116 contr pay_amount pay_player map x y force_find force_add destroy
2733 insert remove name archname title slaying race 3117 insert remove name archname title slaying race decrease split
2734 3118
2735 cf::object::player 3119 cf::object::player
2736 player 3120 player
2737 3121
2738 cf::player 3122 cf::player
… …
2743 3127
2744=cut 3128=cut
2745 3129
2746for ( 3130for (
2747 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3131 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2748 insert remove inv name archname title slaying race)], 3132 insert remove inv nrof name archname title slaying race
3133 decrease split destroy change_exp)],
2749 ["cf::object::player" => qw(player)], 3134 ["cf::object::player" => qw(player)],
2750 ["cf::player" => qw(peaceful)], 3135 ["cf::player" => qw(peaceful)],
2751 ["cf::map" => qw(trigger)], 3136 ["cf::map" => qw(trigger)],
2752) { 3137) {
2753 no strict 'refs'; 3138 no strict 'refs';
… …
2829# the server's init and main functions 3214# the server's init and main functions
2830 3215
2831sub load_facedata($) { 3216sub load_facedata($) {
2832 my ($path) = @_; 3217 my ($path) = @_;
2833 3218
3219 # HACK to clear player env face cache, we need some signal framework
3220 # for this (global event?)
3221 %ext::player_env::MUSIC_FACE_CACHE = ();
3222
2834 my $enc = JSON::XS->new->utf8->canonical; 3223 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2835 3224
2836 warn "loading facedata from $path\n"; 3225 warn "loading facedata from $path\n";
2837 3226
2838 my $facedata; 3227 my $facedata;
2839 0 < aio_load $path, $facedata 3228 0 < aio_load $path, $facedata
… …
2854 { 3243 {
2855 my $faces = $facedata->{faceinfo}; 3244 my $faces = $facedata->{faceinfo};
2856 3245
2857 while (my ($face, $info) = each %$faces) { 3246 while (my ($face, $info) = each %$faces) {
2858 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3247 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3248
2859 cf::face::set_visibility $idx, $info->{visibility}; 3249 cf::face::set_visibility $idx, $info->{visibility};
2860 cf::face::set_magicmap $idx, $info->{magicmap}; 3250 cf::face::set_magicmap $idx, $info->{magicmap};
2861 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3251 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2862 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3252 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2863 3253
2864 cf::cede_to_tick; 3254 cf::cede_to_tick;
2865 } 3255 }
2866 3256
2867 while (my ($face, $info) = each %$faces) { 3257 while (my ($face, $info) = each %$faces) {
2868 next unless $info->{smooth}; 3258 next unless $info->{smooth};
3259
2869 my $idx = cf::face::find $face 3260 my $idx = cf::face::find $face
2870 or next; 3261 or next;
3262
2871 if (my $smooth = cf::face::find $info->{smooth}) { 3263 if (my $smooth = cf::face::find $info->{smooth}) {
2872 cf::face::set_smooth $idx, $smooth; 3264 cf::face::set_smooth $idx, $smooth;
2873 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3265 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2874 } else { 3266 } else {
2875 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3267 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
2893 { 3285 {
2894 # TODO: for gcfclient pleasure, we should give resources 3286 # TODO: for gcfclient pleasure, we should give resources
2895 # that gcfclient doesn't grok a >10000 face index. 3287 # that gcfclient doesn't grok a >10000 face index.
2896 my $res = $facedata->{resource}; 3288 my $res = $facedata->{resource};
2897 3289
2898 my $soundconf = delete $res->{"res/sound.conf"};
2899
2900 while (my ($name, $info) = each %$res) { 3290 while (my ($name, $info) = each %$res) {
3291 if (defined $info->{type}) {
2901 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3292 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2902 my $data; 3293 my $data;
2903 3294
2904 if ($info->{type} & 1) { 3295 if ($info->{type} & 1) {
2905 # prepend meta info 3296 # prepend meta info
2906 3297
2907 my $meta = $enc->encode ({ 3298 my $meta = $enc->encode ({
2908 name => $name, 3299 name => $name,
2909 %{ $info->{meta} || {} }, 3300 %{ $info->{meta} || {} },
2910 }); 3301 });
2911 3302
2912 $data = pack "(w/a*)*", $meta, $info->{data}; 3303 $data = pack "(w/a*)*", $meta, $info->{data};
3304 } else {
3305 $data = $info->{data};
3306 }
3307
3308 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3309 cf::face::set_type $idx, $info->{type};
2913 } else { 3310 } else {
2914 $data = $info->{data}; 3311 $RESOURCE{$name} = $info;
2915 } 3312 }
2916 3313
2917 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2918 cf::face::set_type $idx, $info->{type};
2919
2920 cf::cede_to_tick; 3314 cf::cede_to_tick;
2921 } 3315 }
2922
2923 if ($soundconf) {
2924 $soundconf = $enc->decode (delete $soundconf->{data});
2925
2926 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2927 my $sound = $soundconf->{compat}[$_]
2928 or next;
2929
2930 my $face = cf::face::find "sound/$sound->[1]";
2931 cf::sound::set $sound->[0] => $face;
2932 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2933 }
2934
2935 while (my ($k, $v) = each %{$soundconf->{event}}) {
2936 my $face = cf::face::find "sound/$v";
2937 cf::sound::set $k => $face;
2938 }
2939 }
2940 } 3316 }
3317
3318 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
2941 3319
2942 1 3320 1
2943} 3321}
3322
3323cf::global->attach (on_resource_update => sub {
3324 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3325 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3326
3327 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3328 my $sound = $soundconf->{compat}[$_]
3329 or next;
3330
3331 my $face = cf::face::find "sound/$sound->[1]";
3332 cf::sound::set $sound->[0] => $face;
3333 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3334 }
3335
3336 while (my ($k, $v) = each %{$soundconf->{event}}) {
3337 my $face = cf::face::find "sound/$v";
3338 cf::sound::set $k => $face;
3339 }
3340 }
3341});
2944 3342
2945register_exticmd fx_want => sub { 3343register_exticmd fx_want => sub {
2946 my ($ns, $want) = @_; 3344 my ($ns, $want) = @_;
2947 3345
2948 while (my ($k, $v) = each %$want) { 3346 while (my ($k, $v) = each %$want) {
2949 $ns->fx_want ($k, $v); 3347 $ns->fx_want ($k, $v);
2950 } 3348 }
2951}; 3349};
2952 3350
3351sub load_resource_file($) {
3352 my $guard = lock_acquire "load_resource_file";
3353
3354 my $status = load_resource_file_ $_[0];
3355 get_slot 0.1, 100;
3356 cf::arch::commit_load;
3357
3358 $status
3359}
3360
2953sub reload_regions { 3361sub reload_regions {
3362 # HACK to clear player env face cache, we need some signal framework
3363 # for this (global event?)
3364 %ext::player_env::MUSIC_FACE_CACHE = ();
3365
2954 load_resource_file "$MAPDIR/regions" 3366 load_resource_file "$MAPDIR/regions"
2955 or die "unable to load regions file\n"; 3367 or die "unable to load regions file\n";
2956 3368
2957 for (cf::region::list) { 3369 for (cf::region::list) {
2958 $_->{match} = qr/$_->{match}/ 3370 $_->{match} = qr/$_->{match}/
… …
2966} 3378}
2967 3379
2968sub reload_archetypes { 3380sub reload_archetypes {
2969 load_resource_file "$DATADIR/archetypes" 3381 load_resource_file "$DATADIR/archetypes"
2970 or die "unable to load archetypes\n"; 3382 or die "unable to load archetypes\n";
2971 #d# NEED to laod twice to resolve forward references
2972 # this really needs to be done in an extra post-pass
2973 # (which needs to be synchronous, so solve it differently)
2974 load_resource_file "$DATADIR/archetypes"
2975 or die "unable to load archetypes\n";
2976} 3383}
2977 3384
2978sub reload_treasures { 3385sub reload_treasures {
2979 load_resource_file "$DATADIR/treasures" 3386 load_resource_file "$DATADIR/treasures"
2980 or die "unable to load treasurelists\n"; 3387 or die "unable to load treasurelists\n";
2981} 3388}
2982 3389
2983sub reload_resources { 3390sub reload_resources {
2984 warn "reloading resource files...\n"; 3391 warn "reloading resource files...\n";
2985 3392
3393 reload_facedata;
3394 reload_archetypes;
2986 reload_regions; 3395 reload_regions;
2987 reload_facedata;
2988 #reload_archetypes;#d#
2989 reload_archetypes;
2990 reload_treasures; 3396 reload_treasures;
2991 3397
2992 warn "finished reloading resource files\n"; 3398 warn "finished reloading resource files\n";
2993} 3399}
2994 3400
2995sub init { 3401sub init {
3402 my $guard = freeze_mainloop;
3403
3404 evthread_start IO::AIO::poll_fileno;
3405
2996 reload_resources; 3406 reload_resources;
2997} 3407}
2998 3408
2999sub cfg_load { 3409sub reload_config {
3000 open my $fh, "<:utf8", "$CONFDIR/config" 3410 open my $fh, "<:utf8", "$CONFDIR/config"
3001 or return; 3411 or return;
3002 3412
3003 local $/; 3413 local $/;
3004 *CFG = YAML::Syck::Load <$fh>; 3414 *CFG = YAML::Load <$fh>;
3005 3415
3006 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3416 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3007 3417
3008 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3418 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3009 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3419 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3020sub main { 3430sub main {
3021 # we must not ever block the main coroutine 3431 # we must not ever block the main coroutine
3022 local $Coro::idle = sub { 3432 local $Coro::idle = sub {
3023 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3433 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3024 (async { 3434 (async {
3025 Event::one_event; 3435 $Coro::current->{desc} = "IDLE BUG HANDLER";
3436 EV::loop EV::LOOP_ONESHOT;
3026 })->prio (Coro::PRIO_MAX); 3437 })->prio (Coro::PRIO_MAX);
3027 }; 3438 };
3028 3439
3029 cfg_load; 3440 {
3441 my $guard = freeze_mainloop;
3442 reload_config;
3030 db_init; 3443 db_init;
3031 load_extensions; 3444 load_extensions;
3032 3445
3033 $TICK_WATCHER->start; 3446 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3447 }
3448
3034 Event::loop; 3449 EV::loop;
3035} 3450}
3036 3451
3037############################################################################# 3452#############################################################################
3038# initialisation and cleanup 3453# initialisation and cleanup
3039 3454
3040# install some emergency cleanup handlers 3455# install some emergency cleanup handlers
3041BEGIN { 3456BEGIN {
3457 our %SIGWATCHER = ();
3042 for my $signal (qw(INT HUP TERM)) { 3458 for my $signal (qw(INT HUP TERM)) {
3043 Event->signal ( 3459 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3044 reentrant => 0,
3045 data => WF_AUTOCANCEL,
3046 signal => $signal,
3047 prio => 0,
3048 cb => sub {
3049 cf::cleanup "SIG$signal"; 3460 cf::cleanup "SIG$signal";
3050 },
3051 ); 3461 };
3052 } 3462 }
3053} 3463}
3054 3464
3055sub write_runtime { 3465sub write_runtime_sync {
3056 my $runtime = "$LOCALDIR/runtime"; 3466 my $runtime = "$LOCALDIR/runtime";
3057 3467
3058 # first touch the runtime file to show we are still running: 3468 # first touch the runtime file to show we are still running:
3059 # the fsync below can take a very very long time. 3469 # the fsync below can take a very very long time.
3060 3470
… …
3086 and return; 3496 and return;
3087 3497
3088 warn "runtime file written.\n"; 3498 warn "runtime file written.\n";
3089 3499
3090 1 3500 1
3501}
3502
3503our $uuid_lock;
3504our $uuid_skip;
3505
3506sub write_uuid_sync($) {
3507 $uuid_skip ||= $_[0];
3508
3509 return if $uuid_lock;
3510 local $uuid_lock = 1;
3511
3512 my $uuid = "$LOCALDIR/uuid";
3513
3514 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3515 or return;
3516
3517 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3518 $uuid_skip = 0;
3519
3520 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3521 and return;
3522
3523 # always fsync - this file is important
3524 aio_fsync $fh
3525 and return;
3526
3527 close $fh
3528 or return;
3529
3530 aio_rename "$uuid~", $uuid
3531 and return;
3532
3533 warn "uuid file written ($value).\n";
3534
3535 1
3536
3537}
3538
3539sub write_uuid($$) {
3540 my ($skip, $sync) = @_;
3541
3542 $sync ? write_uuid_sync $skip
3543 : async { write_uuid_sync $skip };
3091} 3544}
3092 3545
3093sub emergency_save() { 3546sub emergency_save() {
3094 my $freeze_guard = cf::freeze_mainloop; 3547 my $freeze_guard = cf::freeze_mainloop;
3095 3548
… …
3101 # and maps saved/destroyed asynchronously. 3554 # and maps saved/destroyed asynchronously.
3102 warn "begin emergency player save\n"; 3555 warn "begin emergency player save\n";
3103 for my $login (keys %cf::PLAYER) { 3556 for my $login (keys %cf::PLAYER) {
3104 my $pl = $cf::PLAYER{$login} or next; 3557 my $pl = $cf::PLAYER{$login} or next;
3105 $pl->valid or next; 3558 $pl->valid or next;
3559 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3106 $pl->save; 3560 $pl->save;
3107 } 3561 }
3108 warn "end emergency player save\n"; 3562 warn "end emergency player save\n";
3109 3563
3110 warn "begin emergency map save\n"; 3564 warn "begin emergency map save\n";
… …
3116 warn "end emergency map save\n"; 3570 warn "end emergency map save\n";
3117 3571
3118 warn "begin emergency database checkpoint\n"; 3572 warn "begin emergency database checkpoint\n";
3119 BDB::db_env_txn_checkpoint $DB_ENV; 3573 BDB::db_env_txn_checkpoint $DB_ENV;
3120 warn "end emergency database checkpoint\n"; 3574 warn "end emergency database checkpoint\n";
3575
3576 warn "begin write uuid\n";
3577 write_uuid_sync 1;
3578 warn "end write uuid\n";
3121 }; 3579 };
3122 3580
3123 warn "leave emergency perl save\n"; 3581 warn "leave emergency perl save\n";
3124} 3582}
3125 3583
… …
3140 warn "reloading..."; 3598 warn "reloading...";
3141 3599
3142 warn "entering sync_job"; 3600 warn "entering sync_job";
3143 3601
3144 cf::sync_job { 3602 cf::sync_job {
3145 cf::write_runtime; # external watchdog should not bark 3603 cf::write_runtime_sync; # external watchdog should not bark
3146 cf::emergency_save; 3604 cf::emergency_save;
3147 cf::write_runtime; # external watchdog should not bark 3605 cf::write_runtime_sync; # external watchdog should not bark
3148 3606
3149 warn "syncing database to disk"; 3607 warn "syncing database to disk";
3150 BDB::db_env_txn_checkpoint $DB_ENV; 3608 BDB::db_env_txn_checkpoint $DB_ENV;
3151 3609
3152 # if anything goes wrong in here, we should simply crash as we already saved 3610 # if anything goes wrong in here, we should simply crash as we already saved
3153
3154 warn "cancelling all WF_AUTOCANCEL watchers";
3155 for (Event::all_watchers) {
3156 $_->cancel if $_->data & WF_AUTOCANCEL;
3157 }
3158 3611
3159 warn "flushing outstanding aio requests"; 3612 warn "flushing outstanding aio requests";
3160 for (;;) { 3613 for (;;) {
3161 BDB::flush; 3614 BDB::flush;
3162 IO::AIO::flush; 3615 IO::AIO::flush;
3163 Coro::cede; 3616 Coro::cede_notself;
3164 last unless IO::AIO::nreqs || BDB::nreqs; 3617 last unless IO::AIO::nreqs || BDB::nreqs;
3165 warn "iterate..."; 3618 warn "iterate...";
3166 } 3619 }
3167 3620
3168 ++$RELOAD; 3621 ++$RELOAD;
… …
3227 warn "reloading cf.pm"; 3680 warn "reloading cf.pm";
3228 require cf; 3681 require cf;
3229 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3682 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3230 3683
3231 warn "loading config and database again"; 3684 warn "loading config and database again";
3232 cf::cfg_load; 3685 cf::reload_config;
3233 3686
3234 warn "loading extensions"; 3687 warn "loading extensions";
3235 cf::load_extensions; 3688 cf::load_extensions;
3236 3689
3237 warn "reattaching attachments to objects/players"; 3690 warn "reattaching attachments to objects/players";
… …
3244 warn "leaving sync_job"; 3697 warn "leaving sync_job";
3245 3698
3246 1 3699 1
3247 } or do { 3700 } or do {
3248 warn $@; 3701 warn $@;
3249 warn "error while reloading, exiting."; 3702 cf::cleanup "error while reloading, exiting.";
3250 exit 1;
3251 }; 3703 };
3252 3704
3253 warn "reloaded"; 3705 warn "reloaded";
3254}; 3706};
3255 3707
… …
3257 3709
3258sub reload_perl() { 3710sub reload_perl() {
3259 # doing reload synchronously and two reloads happen back-to-back, 3711 # doing reload synchronously and two reloads happen back-to-back,
3260 # coro crashes during coro_state_free->destroy here. 3712 # coro crashes during coro_state_free->destroy here.
3261 3713
3262 $RELOAD_WATCHER ||= Event->timer ( 3714 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3263 reentrant => 0,
3264 after => 0,
3265 data => WF_AUTOCANCEL,
3266 cb => sub {
3267 do_reload_perl; 3715 do_reload_perl;
3268 undef $RELOAD_WATCHER; 3716 undef $RELOAD_WATCHER;
3269 },
3270 ); 3717 };
3271} 3718}
3272 3719
3273register_command "reload" => sub { 3720register_command "reload" => sub {
3274 my ($who, $arg) = @_; 3721 my ($who, $arg) = @_;
3275 3722
3276 if ($who->flag (FLAG_WIZ)) { 3723 if ($who->flag (FLAG_WIZ)) {
3277 $who->message ("reloading server."); 3724 $who->message ("reloading server.");
3725 async {
3726 $Coro::current->{desc} = "perl_reload";
3278 async { reload_perl }; 3727 reload_perl;
3728 };
3279 } 3729 }
3280}; 3730};
3281 3731
3282unshift @INC, $LIBDIR; 3732unshift @INC, $LIBDIR;
3283 3733
… …
3285 3735
3286our @WAIT_FOR_TICK; 3736our @WAIT_FOR_TICK;
3287our @WAIT_FOR_TICK_BEGIN; 3737our @WAIT_FOR_TICK_BEGIN;
3288 3738
3289sub wait_for_tick { 3739sub wait_for_tick {
3290 return unless $TICK_WATCHER->is_active;
3291 return if $Coro::current == $Coro::main; 3740 return if tick_inhibit || $Coro::current == $Coro::main;
3292 3741
3293 my $signal = new Coro::Signal; 3742 my $signal = new Coro::Signal;
3294 push @WAIT_FOR_TICK, $signal; 3743 push @WAIT_FOR_TICK, $signal;
3295 $signal->wait; 3744 $signal->wait;
3296} 3745}
3297 3746
3298sub wait_for_tick_begin { 3747sub wait_for_tick_begin {
3299 return unless $TICK_WATCHER->is_active;
3300 return if $Coro::current == $Coro::main; 3748 return if tick_inhibit || $Coro::current == $Coro::main;
3301 3749
3302 my $signal = new Coro::Signal; 3750 my $signal = new Coro::Signal;
3303 push @WAIT_FOR_TICK_BEGIN, $signal; 3751 push @WAIT_FOR_TICK_BEGIN, $signal;
3304 $signal->wait; 3752 $signal->wait;
3305} 3753}
3306 3754
3307 my $min = 1e6;#d# 3755sub tick {
3308 my $avg = 10;
3309$TICK_WATCHER = Event->timer (
3310 reentrant => 0,
3311 parked => 1,
3312 prio => 0,
3313 at => $NEXT_TICK || $TICK,
3314 data => WF_AUTOCANCEL,
3315 cb => sub {
3316 if ($Coro::current != $Coro::main) { 3756 if ($Coro::current != $Coro::main) {
3317 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3757 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3318 unless ++$bug_warning > 10; 3758 unless ++$bug_warning > 10;
3319 return; 3759 return;
3320 } 3760 }
3321 3761
3322 $NOW = $tick_start = Event::time;
3323
3324 cf::server_tick; # one server iteration 3762 cf::server_tick; # one server iteration
3325 3763
3326 0 && sync_job {#d# 3764 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3327 for(1..10) { 3765 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3328 my $t = Event::time; 3766 Coro::async_pool {
3329 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3767 $Coro::current->{desc} = "runtime saver";
3330 or die; 3768 write_runtime_sync
3331 3769 or warn "ERROR: unable to write runtime file: $!";
3332 $map->width (50);
3333 $map->height (50);
3334 $map->alloc;
3335 $map->_load_objects ("/tmp/x.map", 1);
3336 my $t = Event::time - $t;
3337
3338 #next unless $t < 0.0013;#d#
3339 if ($t < $min) {
3340 $min = $t;
3341 }
3342 $avg = $avg * 0.99 + $t * 0.01;
3343 }
3344 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3345 exit 0;
3346 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3347 }; 3770 };
3771 }
3348 3772
3349 $RUNTIME += $TICK;
3350 $NEXT_TICK += $TICK;
3351
3352 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3353 $NEXT_RUNTIME_WRITE = $NOW + 10;
3354 Coro::async_pool {
3355 write_runtime
3356 or warn "ERROR: unable to write runtime file: $!";
3357 };
3358 }
3359
3360# my $AFTER = Event::time;
3361# warn $AFTER - $NOW;#d#
3362
3363 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3773 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3364 $sig->send; 3774 $sig->send;
3365 } 3775 }
3366 while (my $sig = shift @WAIT_FOR_TICK) { 3776 while (my $sig = shift @WAIT_FOR_TICK) {
3367 $sig->send; 3777 $sig->send;
3368 } 3778 }
3369 3779
3370 $NOW = Event::time; 3780 $LOAD = ($NOW - $TICK_START) / $TICK;
3371
3372 # if we are delayed by four ticks or more, skip them all
3373 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3374
3375 $TICK_WATCHER->at ($NEXT_TICK);
3376 $TICK_WATCHER->start;
3377
3378 $LOAD = ($NOW - $tick_start) / $TICK;
3379 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3781 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3380 3782
3381 _post_tick; 3783 if (0) {
3382 3784 if ($NEXT_TICK) {
3383 3785 my $jitter = $TICK_START - $NEXT_TICK;
3786 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3787 warn "jitter $JITTER\n";#d#
3788 }
3384 }, 3789 }
3385); 3790}
3386 3791
3387{ 3792{
3388 BDB::max_poll_time $TICK * 0.1; 3793 # configure BDB
3389 $BDB_POLL_WATCHER = Event->io ( 3794
3390 reentrant => 0,
3391 fd => BDB::poll_fileno,
3392 poll => 'r',
3393 prio => 0,
3394 data => WF_AUTOCANCEL,
3395 cb => \&BDB::poll_cb,
3396 );
3397 BDB::min_parallel 8; 3795 BDB::min_parallel 8;
3398 3796 BDB::max_poll_reqs $TICK * 0.1;
3399 BDB::set_sync_prepare { 3797 $AnyEvent::BDB::WATCHER->priority (1);
3400 my $status;
3401 my $current = $Coro::current;
3402 (
3403 sub {
3404 $status = $!;
3405 $current->ready; undef $current;
3406 },
3407 sub {
3408 Coro::schedule while defined $current;
3409 $! = $status;
3410 },
3411 )
3412 };
3413 3798
3414 unless ($DB_ENV) { 3799 unless ($DB_ENV) {
3415 $DB_ENV = BDB::db_env_create; 3800 $DB_ENV = BDB::db_env_create;
3801 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3802 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3803 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3804 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3805 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3416 3806
3417 cf::sync_job { 3807 cf::sync_job {
3418 eval { 3808 eval {
3419 BDB::db_env_open 3809 BDB::db_env_open
3420 $DB_ENV, 3810 $DB_ENV,
… …
3422 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3812 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3423 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3813 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3424 0666; 3814 0666;
3425 3815
3426 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3816 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3427
3428 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3429 $DB_ENV->set_lk_detect;
3430 }; 3817 };
3431 3818
3432 cf::cleanup "db_env_open(db): $@" if $@; 3819 cf::cleanup "db_env_open(db): $@" if $@;
3433 }; 3820 };
3434 } 3821 }
3822
3823 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3824 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3825 };
3826 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3827 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3828 };
3829 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3830 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3831 };
3435} 3832}
3436 3833
3437{ 3834{
3835 # configure IO::AIO
3836
3438 IO::AIO::min_parallel 8; 3837 IO::AIO::min_parallel 8;
3439
3440 undef $Coro::AIO::WATCHER;
3441 IO::AIO::max_poll_time $TICK * 0.1; 3838 IO::AIO::max_poll_time $TICK * 0.1;
3442 $AIO_POLL_WATCHER = Event->io ( 3839 undef $AnyEvent::AIO::WATCHER;
3443 reentrant => 0,
3444 data => WF_AUTOCANCEL,
3445 fd => IO::AIO::poll_fileno,
3446 poll => 'r',
3447 prio => 6,
3448 cb => \&IO::AIO::poll_cb,
3449 );
3450} 3840}
3451 3841
3452my $_log_backtrace; 3842my $_log_backtrace;
3453 3843
3454sub _log_backtrace { 3844sub _log_backtrace {
… …
3458 3848
3459 # limit the # of concurrent backtraces 3849 # limit the # of concurrent backtraces
3460 if ($_log_backtrace < 2) { 3850 if ($_log_backtrace < 2) {
3461 ++$_log_backtrace; 3851 ++$_log_backtrace;
3462 async { 3852 async {
3853 $Coro::current->{desc} = "abt $msg";
3854
3463 my @bt = fork_call { 3855 my @bt = fork_call {
3464 @addr = map { sprintf "%x", $_ } @addr; 3856 @addr = map { sprintf "%x", $_ } @addr;
3465 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3857 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3466 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3858 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3467 or die "addr2line: $!"; 3859 or die "addr2line: $!";

Diff Legend

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