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.351 by root, Sun Sep 2 00:57:38 2007 UTC vs.
Revision 1.430 by root, Sun May 4 14:12:37 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 }
372 } 428 }
373}; 429};
374 430
375sub get_slot($;$$) { 431sub get_slot($;$$) {
432 return if tick_inhibit || $Coro::current == $Coro::main;
433
376 my ($time, $pri, $name) = @_; 434 my ($time, $pri, $name) = @_;
377 435
378 $time = $TICK * .6 if $time > $TICK * .6; 436 $time = $TICK * .6 if $time > $TICK * .6;
379 my $sig = new Coro::Signal; 437 my $sig = new Coro::Signal;
380 438
… …
394 452
395BEGIN { *async = \&Coro::async_pool } 453BEGIN { *async = \&Coro::async_pool }
396 454
397=item cf::sync_job { BLOCK } 455=item cf::sync_job { BLOCK }
398 456
399The design of Crossfire TRT requires that the main coroutine ($Coro::main) 457The design of Deliantra requires that the main coroutine ($Coro::main)
400is always able to handle events or runnable, as Crossfire TRT is only 458is 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 459partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
402acceptable. 460acceptable.
403 461
404If it must be done, put the blocking parts into C<sync_job>. This will run 462If it must be done, put the blocking parts into C<sync_job>. This will run
405the given BLOCK in another coroutine while waiting for the result. The 463the given BLOCK in another coroutine while waiting for the result. The
… …
410 468
411sub sync_job(&) { 469sub sync_job(&) {
412 my ($job) = @_; 470 my ($job) = @_;
413 471
414 if ($Coro::current == $Coro::main) { 472 if ($Coro::current == $Coro::main) {
415 my $time = Event::time; 473 my $time = EV::time;
416 474
417 # this is the main coro, too bad, we have to block 475 # this is the main coro, too bad, we have to block
418 # till the operation succeeds, freezing the server :/ 476 # till the operation succeeds, freezing the server :/
419 477
420 # TODO: use suspend/resume instead 478 LOG llevError, Carp::longmess "sync job";#d#
421 # (but this is cancel-safe) 479
422 my $freeze_guard = freeze_mainloop; 480 my $freeze_guard = freeze_mainloop;
423 481
424 my $busy = 1; 482 my $busy = 1;
425 my @res; 483 my @res;
426 484
427 (async { 485 (async {
486 $Coro::current->desc ("sync job coro");
428 @res = eval { $job->() }; 487 @res = eval { $job->() };
429 warn $@ if $@; 488 warn $@ if $@;
430 undef $busy; 489 undef $busy;
431 })->prio (Coro::PRIO_MAX); 490 })->prio (Coro::PRIO_MAX);
432 491
433 while ($busy) { 492 while ($busy) {
434 Coro::cede or Event::one_event; 493 if (Coro::nready) {
494 Coro::cede_notself;
495 } else {
496 EV::loop EV::LOOP_ONESHOT;
435 } 497 }
498 }
436 499
437 $time = Event::time - $time; 500 my $time = EV::time - $time;
438 501
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 502 $TICK_START += $time; # do not account sync jobs to server load
443 503
444 wantarray ? @res : $res[0] 504 wantarray ? @res : $res[0]
445 } else { 505 } else {
446 # we are in another coroutine, how wonderful, everything just works 506 # we are in another coroutine, how wonderful, everything just works
447 507
… …
472=item fork_call { }, $args 532=item fork_call { }, $args
473 533
474Executes the given code block with the given arguments in a seperate 534Executes the given code block with the given arguments in a seperate
475process, returning the results. Everything must be serialisable with 535process, returning the results. Everything must be serialisable with
476Coro::Storable. May, of course, block. Note that the executed sub may 536Coro::Storable. May, of course, block. Note that the executed sub may
477never block itself or use any form of Event handling. 537never block itself or use any form of event handling.
478 538
479=cut 539=cut
480 540
481sub fork_call(&@) { 541sub fork_call(&@) {
482 my ($cb, @args) = @_; 542 my ($cb, @args) = @_;
483 543
484 # we seemingly have to make a local copy of the whole thing, 544 # we seemingly have to make a local copy of the whole thing,
485 # otherwise perl prematurely frees the stuff :/ 545 # otherwise perl prematurely frees the stuff :/
486 # TODO: investigate and fix (liekly this will be rather laborious) 546 # TODO: investigate and fix (likely this will be rather laborious)
487 547
488 my @res = Coro::Util::fork_eval { 548 my @res = Coro::Util::fork_eval {
489 reset_signals; 549 reset_signals;
490 &$cb 550 &$cb
491 }, @args; 551 }, @args;
492 552
493 wantarray ? @res : $res[-1] 553 wantarray ? @res : $res[-1]
494} 554}
495 555
556=item $coin = coin_from_name $name
557
558=cut
559
560our %coin_alias = (
561 "silver" => "silvercoin",
562 "silvercoin" => "silvercoin",
563 "silvercoins" => "silvercoin",
564 "gold" => "goldcoin",
565 "goldcoin" => "goldcoin",
566 "goldcoins" => "goldcoin",
567 "platinum" => "platinacoin",
568 "platinumcoin" => "platinacoin",
569 "platinumcoins" => "platinacoin",
570 "platina" => "platinacoin",
571 "platinacoin" => "platinacoin",
572 "platinacoins" => "platinacoin",
573 "royalty" => "royalty",
574 "royalties" => "royalty",
575);
576
577sub coin_from_name($) {
578 $coin_alias{$_[0]}
579 ? cf::arch::find $coin_alias{$_[0]}
580 : undef
581}
582
496=item $value = cf::db_get $family => $key 583=item $value = cf::db_get $family => $key
497 584
498Returns a single value from the environment database. 585Returns a single value from the environment database.
499 586
500=item cf::db_put $family => $key => $value 587=item cf::db_put $family => $key => $value
501 588
502Stores the given C<$value> in the family. It can currently store binary 589Stores 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). 590data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
504 591
592=item $db = cf::db_table "name"
593
594Create and/or open a new database table. The string must not be "db" and must be unique
595within each server.
596
505=cut 597=cut
598
599sub db_table($) {
600 my ($name) = @_;
601 my $db = BDB::db_create $DB_ENV;
602
603 eval {
604 $db->set_flags (BDB::CHKSUM);
605
606 utf8::encode $name;
607 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
608 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
609 cf::cleanup "db_open(db): $!" if $!;
610 };
611 cf::cleanup "db_open(db): $@" if $@;
612
613 $db
614}
506 615
507our $DB; 616our $DB;
508 617
509sub db_init { 618sub db_init {
510 unless ($DB) {
511 $DB = BDB::db_create $DB_ENV;
512
513 cf::sync_job { 619 cf::sync_job {
514 eval { 620 $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 } 621 };
524} 622}
525 623
526sub db_get($$) { 624sub db_get($$) {
527 my $key = "$_[0]/$_[1]"; 625 my $key = "$_[0]/$_[1]";
528 626
… …
632attach callbacks/event handlers (a collection of which is called an "attachment") 730attach callbacks/event handlers (a collection of which is called an "attachment")
633to it. All such attachable objects support the following methods. 731to it. All such attachable objects support the following methods.
634 732
635In the following description, CLASS can be any of C<global>, C<object> 733In the following description, CLASS can be any of C<global>, C<object>
636C<player>, C<client> or C<map> (i.e. the attachable objects in 734C<player>, C<client> or C<map> (i.e. the attachable objects in
637Crossfire TRT). 735Deliantra).
638 736
639=over 4 737=over 4
640 738
641=item $attachable->attach ($attachment, key => $value...) 739=item $attachable->attach ($attachment, key => $value...)
642 740
… …
924 } 1022 }
925 1023
926 0 1024 0
927} 1025}
928 1026
929=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1027=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
930 1028
931=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1029=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
932 1030
933Generate an object-specific event with the given arguments. 1031Generate an object-specific event with the given arguments.
934 1032
… …
940 1038
941=cut 1039=cut
942 1040
943############################################################################# 1041#############################################################################
944# object support 1042# object support
945#
946 1043
1044sub _object_equal($$);
1045sub _object_equal($$) {
1046 my ($a, $b) = @_;
1047
1048 return 0 unless (ref $a) eq (ref $b);
1049
1050 if ("HASH" eq ref $a) {
1051 my @ka = keys %$a;
1052 my @kb = keys %$b;
1053
1054 return 0 if @ka != @kb;
1055
1056 for (0 .. $#ka) {
1057 return 0 unless $ka[$_] eq $kb[$_];
1058 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1059 }
1060
1061 } elsif ("ARRAY" eq ref $a) {
1062
1063 return 0 if @$a != @$b;
1064
1065 for (0 .. $#$a) {
1066 return 0 unless _object_equal $a->[$_], $b->[$_];
1067 }
1068
1069 } elsif ($a ne $b) {
1070 return 0;
1071 }
1072
1073 1
1074}
1075
1076our $SLOW_MERGES;#d#
947sub _can_merge { 1077sub _can_merge {
948 my ($ob1, $ob2) = @_; 1078 my ($ob1, $ob2) = @_;
949 1079
950 local $Storable::canonical = 1; 1080 ++$SLOW_MERGES;#d#
951 my $fob1 = Storable::freeze $ob1;
952 my $fob2 = Storable::freeze $ob2;
953 1081
954 $fob1 eq $fob2 1082 # we do the slow way here
1083 return _object_equal $ob1, $ob2
955} 1084}
956 1085
957sub reattach { 1086sub reattach {
958 # basically do the same as instantiate, without calling instantiate 1087 # basically do the same as instantiate, without calling instantiate
959 my ($obj) = @_; 1088 my ($obj) = @_;
… …
981cf::attachable->attach ( 1110cf::attachable->attach (
982 prio => -1000000, 1111 prio => -1000000,
983 on_instantiate => sub { 1112 on_instantiate => sub {
984 my ($obj, $data) = @_; 1113 my ($obj, $data) = @_;
985 1114
986 $data = from_json $data; 1115 $data = decode_json $data;
987 1116
988 for (@$data) { 1117 for (@$data) {
989 my ($name, $args) = @$_; 1118 my ($name, $args) = @$_;
990 1119
991 $obj->attach ($name, %{$args || {} }); 1120 $obj->attach ($name, %{$args || {} });
… …
1007sub object_freezer_save { 1136sub object_freezer_save {
1008 my ($filename, $rdata, $objs) = @_; 1137 my ($filename, $rdata, $objs) = @_;
1009 1138
1010 sync_job { 1139 sync_job {
1011 if (length $$rdata) { 1140 if (length $$rdata) {
1141 utf8::decode (my $decname = $filename);
1012 warn sprintf "saving %s (%d,%d)\n", 1142 warn sprintf "saving %s (%d,%d)\n",
1013 $filename, length $$rdata, scalar @$objs; 1143 $decname, length $$rdata, scalar @$objs;
1014 1144
1015 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1145 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1016 chmod SAVE_MODE, $fh; 1146 aio_chmod $fh, SAVE_MODE;
1017 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1147 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1018 aio_fsync $fh if $cf::USE_FSYNC; 1148 aio_fsync $fh if $cf::USE_FSYNC;
1019 close $fh; 1149 aio_close $fh;
1020 1150
1021 if (@$objs) { 1151 if (@$objs) {
1022 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1152 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1023 chmod SAVE_MODE, $fh; 1153 aio_chmod $fh, SAVE_MODE;
1024 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1154 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1025 aio_write $fh, 0, (length $data), $data, 0; 1155 aio_write $fh, 0, (length $data), $data, 0;
1026 aio_fsync $fh if $cf::USE_FSYNC; 1156 aio_fsync $fh if $cf::USE_FSYNC;
1027 close $fh; 1157 aio_close $fh;
1028 aio_rename "$filename.pst~", "$filename.pst"; 1158 aio_rename "$filename.pst~", "$filename.pst";
1029 } 1159 }
1030 } else { 1160 } else {
1031 aio_unlink "$filename.pst"; 1161 aio_unlink "$filename.pst";
1032 } 1162 }
… …
1037 } 1167 }
1038 } else { 1168 } else {
1039 aio_unlink $filename; 1169 aio_unlink $filename;
1040 aio_unlink "$filename.pst"; 1170 aio_unlink "$filename.pst";
1041 } 1171 }
1042 } 1172 };
1043} 1173}
1044 1174
1045sub object_freezer_as_string { 1175sub object_freezer_as_string {
1046 my ($rdata, $objs) = @_; 1176 my ($rdata, $objs) = @_;
1047 1177
… …
1059 or return; 1189 or return;
1060 1190
1061 unless (aio_stat "$filename.pst") { 1191 unless (aio_stat "$filename.pst") {
1062 (aio_load "$filename.pst", $av) >= 0 1192 (aio_load "$filename.pst", $av) >= 0
1063 or return; 1193 or return;
1194
1064 $av = eval { (Storable::thaw $av)->{objs} }; 1195 my $st = eval { Coro::Storable::thaw $av };
1196 $av = $st->{objs};
1065 } 1197 }
1066 1198
1199 utf8::decode (my $decname = $filename);
1067 warn sprintf "loading %s (%d)\n", 1200 warn sprintf "loading %s (%d,%d)\n",
1068 $filename, length $data, scalar @{$av || []}; 1201 $decname, length $data, scalar @{$av || []};
1202
1069 return ($data, $av); 1203 ($data, $av)
1070} 1204}
1071 1205
1072=head2 COMMAND CALLBACKS 1206=head2 COMMAND CALLBACKS
1073 1207
1074=over 4 1208=over 4
… …
1223 my $msg = $@ ? "$v->{path}: $@\n" 1357 my $msg = $@ ? "$v->{path}: $@\n"
1224 : "$v->{base}: extension inactive.\n"; 1358 : "$v->{base}: extension inactive.\n";
1225 1359
1226 if (exists $v->{meta}{mandatory}) { 1360 if (exists $v->{meta}{mandatory}) {
1227 warn $msg; 1361 warn $msg;
1228 warn "mandatory extension failed to load, exiting.\n"; 1362 cf::cleanup "mandatory extension failed to load, exiting.";
1229 exit 1;
1230 } 1363 }
1231 1364
1232 warn $msg; 1365 warn $msg;
1233 } 1366 }
1234 1367
… …
1259use Coro::AIO; 1392use Coro::AIO;
1260 1393
1261=head3 cf::player 1394=head3 cf::player
1262 1395
1263=over 4 1396=over 4
1397
1398=item cf::player::num_playing
1399
1400Returns the official number of playing players, as per the Crossfire metaserver rules.
1401
1402=cut
1403
1404sub num_playing {
1405 scalar grep
1406 $_->ob->map
1407 && !$_->hidden
1408 && !$_->ob->flag (cf::FLAG_WIZ),
1409 cf::player::list
1410}
1264 1411
1265=item cf::player::find $login 1412=item cf::player::find $login
1266 1413
1267Returns the given player object, loading it if necessary (might block). 1414Returns the given player object, loading it if necessary (might block).
1268 1415
… …
1304 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1451 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1305 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1452 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1306 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1453 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1307 aio_unlink +(playerdir $login) . "/$login.pl"; 1454 aio_unlink +(playerdir $login) . "/$login.pl";
1308 1455
1309 my $pl = load_pl path $login 1456 my $f = new_from_file cf::object::thawer path $login
1310 or return; 1457 or return;
1458
1459 my $pl = cf::player::load_pl $f
1460 or return;
1461
1462 local $cf::PLAYER_LOADING{$login} = $pl;
1463 $f->resolve_delayed_derefs;
1311 $cf::PLAYER{$login} = $pl 1464 $cf::PLAYER{$login} = $pl
1312 } 1465 }
1313 } 1466 }
1314} 1467}
1315 1468
… …
1323 1476
1324 return if $pl->{deny_save}; 1477 return if $pl->{deny_save};
1325 1478
1326 aio_mkdir playerdir $pl, 0770; 1479 aio_mkdir playerdir $pl, 0770;
1327 $pl->{last_save} = $cf::RUNTIME; 1480 $pl->{last_save} = $cf::RUNTIME;
1481
1482 cf::get_slot 0.01;
1328 1483
1329 $pl->save_pl ($path); 1484 $pl->save_pl ($path);
1330 cf::cede_to_tick; 1485 cf::cede_to_tick;
1331} 1486}
1332 1487
… …
1413 or return []; 1568 or return [];
1414 1569
1415 my @logins; 1570 my @logins;
1416 1571
1417 for my $login (@$dirs) { 1572 for my $login (@$dirs) {
1573 my $path = path $login;
1574
1575 # a .pst is a dead give-away for a valid player
1576 # if no pst file found, open and chekc for blocked users
1577 if (aio_stat "$path.pst") {
1418 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1578 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1419 aio_read $fh, 0, 512, my $buf, 0 or next; 1579 aio_read $fh, 0, 512, my $buf, 0 or next;
1420 $buf !~ /^password -------------$/m or next; # official not-valid tag 1580 $buf !~ /^password -------------$/m or next; # official not-valid tag
1581 }
1421 1582
1422 utf8::decode $login; 1583 utf8::decode $login;
1423 push @logins, $login; 1584 push @logins, $login;
1424 } 1585 }
1425 1586
… …
1458 1619
1459Expand crossfire pod fragments into protocol xml. 1620Expand crossfire pod fragments into protocol xml.
1460 1621
1461=cut 1622=cut
1462 1623
1624use re 'eval';
1625
1626my $group;
1627my $interior; $interior = qr{
1628 # match a pod interior sequence sans C<< >>
1629 (?:
1630 \ (.*?)\ (?{ $group = $^N })
1631 | < (??{$interior}) >
1632 )
1633}x;
1634
1463sub expand_cfpod { 1635sub expand_cfpod {
1464 ((my $self), (local $_)) = @_; 1636 my ($self, $pod) = @_;
1465 1637
1466 # escape & and < 1638 my $xml;
1467 s/&/&amp;/g;
1468 s/(?<![BIUGH])</&lt;/g;
1469 1639
1470 # this is buggy, it needs to properly take care of nested <'s 1640 while () {
1641 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1642 $group = $1;
1471 1643
1472 1 while 1644 $group =~ s/&/&amp;/g;
1473 # replace B<>, I<>, U<> etc. 1645 $group =~ s/</&lt;/g;
1474 s/B<([^\>]*)>/<b>$1<\/b>/ 1646
1475 || s/I<([^\>]*)>/<i>$1<\/i>/ 1647 $xml .= $group;
1476 || s/U<([^\>]*)>/<u>$1<\/u>/ 1648 } elsif ($pod =~ m%\G
1477 # replace G<male|female> tags 1649 ([BCGHITU])
1478 || s{G<([^>|]*)\|([^>]*)>}{ 1650 <
1479 $self->gender ? $2 : $1 1651 (?:
1480 }ge 1652 ([^<>]*) (?{ $group = $^N })
1481 # replace H<hint text> 1653 | < $interior >
1482 || s{H<([^\>]*)>} 1654 )
1655 >
1656 %gcsx
1483 { 1657 ) {
1658 my ($code, $data) = ($1, $group);
1659
1660 if ($code eq "B") {
1661 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1662 } elsif ($code eq "I") {
1663 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1664 } elsif ($code eq "U") {
1665 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1666 } elsif ($code eq "C") {
1667 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1668 } elsif ($code eq "T") {
1669 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1670 } elsif ($code eq "G") {
1671 my ($male, $female) = split /\|/, $data;
1672 $data = $self->gender ? $female : $male;
1673 $xml .= expand_cfpod ($self, $data);
1674 } elsif ($code eq "H") {
1484 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1675 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1485 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1676 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1486 "") 1677 "")
1487 [$self->{hintmode}] 1678 [$self->{hintmode}];
1679 } else {
1680 $xml .= "error processing '$code($data)' directive";
1488 }ge; 1681 }
1682 } else {
1683 if ($pod =~ /\G(.+)/) {
1684 warn "parse error while expanding $pod (at $1)";
1685 }
1686 last;
1687 }
1688 }
1489 1689
1690 for ($xml) {
1490 # create single paragraphs (very hackish) 1691 # create single paragraphs (very hackish)
1491 s/(?<=\S)\n(?=\w)/ /g; 1692 s/(?<=\S)\n(?=\w)/ /g;
1492 1693
1493 # compress some whitespace 1694 # compress some whitespace
1494 s/\s+\n/\n/g; # ws line-ends 1695 s/\s+\n/\n/g; # ws line-ends
1495 s/\n\n+/\n/g; # double lines 1696 s/\n\n+/\n/g; # double lines
1496 s/^\n+//; # beginning lines 1697 s/^\n+//; # beginning lines
1497 s/\n+$//; # ending lines 1698 s/\n+$//; # ending lines
1699 }
1498 1700
1499 $_ 1701 $xml
1500} 1702}
1703
1704no re 'eval';
1501 1705
1502sub hintmode { 1706sub hintmode {
1503 $_[0]{hintmode} = $_[1] if @_ > 1; 1707 $_[0]{hintmode} = $_[1] if @_ > 1;
1504 $_[0]{hintmode} 1708 $_[0]{hintmode}
1505} 1709}
… …
1577our $MAX_RESET = 3600; 1781our $MAX_RESET = 3600;
1578our $DEFAULT_RESET = 3000; 1782our $DEFAULT_RESET = 3000;
1579 1783
1580sub generate_random_map { 1784sub generate_random_map {
1581 my ($self, $rmp) = @_; 1785 my ($self, $rmp) = @_;
1786
1787 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1788
1582 # mit "rum" bekleckern, nicht 1789 # mit "rum" bekleckern, nicht
1583 $self->_create_random_map ( 1790 $self->_create_random_map (
1584 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1791 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1585 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1792 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1586 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1793 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1708 1915
1709# the temporary/swap location 1916# the temporary/swap location
1710sub save_path { 1917sub save_path {
1711 my ($self) = @_; 1918 my ($self) = @_;
1712 1919
1713 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1920 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1714 "$TMPDIR/$path.map" 1921 "$TMPDIR/$path.map"
1715} 1922}
1716 1923
1717# the unique path, undef == no special unique path 1924# the unique path, undef == no special unique path
1718sub uniq_path { 1925sub uniq_path {
1719 my ($self) = @_; 1926 my ($self) = @_;
1720 1927
1721 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1928 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1722 "$UNIQUEDIR/$path" 1929 "$UNIQUEDIR/$path"
1723} 1930}
1724 1931
1725# and all this just because we cannot iterate over 1932# and all this just because we cannot iterate over
1726# all maps in C++... 1933# all maps in C++...
… …
1749 1956
1750sub load_header_from($) { 1957sub load_header_from($) {
1751 my ($self, $path) = @_; 1958 my ($self, $path) = @_;
1752 1959
1753 utf8::encode $path; 1960 utf8::encode $path;
1754 #aio_open $path, O_RDONLY, 0 1961 my $f = new_from_file cf::object::thawer $path
1755 # or return;
1756
1757 $self->_load_header ($path)
1758 or return; 1962 or return;
1963
1964 $self->_load_header ($f)
1965 or return;
1966
1967 local $MAP_LOADING{$self->{path}} = $self;
1968 $f->resolve_delayed_derefs;
1759 1969
1760 $self->{load_path} = $path; 1970 $self->{load_path} = $path;
1761 1971
1762 1 1972 1
1763} 1973}
… …
1817sub find { 2027sub find {
1818 my ($path, $origin) = @_; 2028 my ($path, $origin) = @_;
1819 2029
1820 $path = normalise $path, $origin && $origin->path; 2030 $path = normalise $path, $origin && $origin->path;
1821 2031
2032 cf::lock_wait "map_data:$path";#d#remove
1822 cf::lock_wait "map_find:$path"; 2033 cf::lock_wait "map_find:$path";
1823 2034
1824 $cf::MAP{$path} || do { 2035 $cf::MAP{$path} || do {
2036 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1825 my $guard = cf::lock_acquire "map_find:$path"; 2037 my $guard2 = cf::lock_acquire "map_find:$path";
2038
1826 my $map = new_from_path cf::map $path 2039 my $map = new_from_path cf::map $path
1827 or return; 2040 or return;
1828 2041
1829 $map->{last_save} = $cf::RUNTIME; 2042 $map->{last_save} = $cf::RUNTIME;
1830 2043
… …
1832 or return; 2045 or return;
1833 2046
1834 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2047 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1835 # doing this can freeze the server in a sync job, obviously 2048 # doing this can freeze the server in a sync job, obviously
1836 #$cf::WAIT_FOR_TICK->wait; 2049 #$cf::WAIT_FOR_TICK->wait;
2050 undef $guard2;
2051 undef $guard1;
1837 $map->reset; 2052 $map->reset;
1838 undef $guard;
1839 return find $path; 2053 return find $path;
1840 } 2054 }
1841 2055
1842 $cf::MAP{$path} = $map 2056 $cf::MAP{$path} = $map
1843 } 2057 }
… …
1852 local $self->{deny_reset} = 1; # loading can take a long time 2066 local $self->{deny_reset} = 1; # loading can take a long time
1853 2067
1854 my $path = $self->{path}; 2068 my $path = $self->{path};
1855 2069
1856 { 2070 {
1857 my $guard1 = cf::lock_acquire "map_data:$path"; 2071 my $guard = cf::lock_acquire "map_data:$path";
1858 my $guard2 = cf::lock_acquire "map_load:$path";
1859 2072
2073 return unless $self->valid;
1860 return if $self->in_memory != cf::MAP_SWAPPED; 2074 return unless $self->in_memory == cf::MAP_SWAPPED;
1861 2075
1862 $self->in_memory (cf::MAP_LOADING); 2076 $self->in_memory (cf::MAP_LOADING);
1863 2077
1864 $self->alloc; 2078 $self->alloc;
1865 2079
1866 $self->pre_load; 2080 $self->pre_load;
1867 cf::cede_to_tick; 2081 cf::cede_to_tick;
1868 2082
2083 my $f = new_from_file cf::object::thawer $self->{load_path};
2084 $f->skip_block;
1869 $self->_load_objects ($self->{load_path}, 1) 2085 $self->_load_objects ($f)
1870 or return; 2086 or return;
1871 2087
1872 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2088 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1873 if delete $self->{load_original}; 2089 if delete $self->{load_original};
1874 2090
1875 if (my $uniq = $self->uniq_path) { 2091 if (my $uniq = $self->uniq_path) {
1876 utf8::encode $uniq; 2092 utf8::encode $uniq;
1877 if (aio_open $uniq, O_RDONLY, 0) { 2093 unless (aio_stat $uniq) {
2094 if (my $f = new_from_file cf::object::thawer $uniq) {
1878 $self->clear_unique_items; 2095 $self->clear_unique_items;
1879 $self->_load_objects ($uniq, 0); 2096 $self->_load_objects ($f);
2097 $f->resolve_delayed_derefs;
2098 }
1880 } 2099 }
1881 } 2100 }
2101
2102 $f->resolve_delayed_derefs;
1882 2103
1883 cf::cede_to_tick; 2104 cf::cede_to_tick;
1884 # now do the right thing for maps 2105 # now do the right thing for maps
1885 $self->link_multipart_objects; 2106 $self->link_multipart_objects;
1886 $self->difficulty ($self->estimate_difficulty) 2107 $self->difficulty ($self->estimate_difficulty)
… …
1898 } 2119 }
1899 2120
1900 $self->{last_save} = $cf::RUNTIME; 2121 $self->{last_save} = $cf::RUNTIME;
1901 $self->last_access ($cf::RUNTIME); 2122 $self->last_access ($cf::RUNTIME);
1902 2123
1903 $self->in_memory (cf::MAP_IN_MEMORY); 2124 $self->in_memory (cf::MAP_ACTIVE);
1904 } 2125 }
1905 2126
1906 $self->post_load; 2127 $self->post_load;
1907} 2128}
1908 2129
… …
1966 my ($path, $origin, $load) = @_; 2187 my ($path, $origin, $load) = @_;
1967 2188
1968 $path = normalise $path, $origin && $origin->{path}; 2189 $path = normalise $path, $origin && $origin->{path};
1969 2190
1970 if (my $map = $cf::MAP{$path}) { 2191 if (my $map = $cf::MAP{$path}) {
1971 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2192 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1972 } 2193 }
1973 2194
1974 $MAP_PREFETCH{$path} |= $load; 2195 $MAP_PREFETCH{$path} |= $load;
1975 2196
1976 $MAP_PREFETCHER ||= cf::async { 2197 $MAP_PREFETCHER ||= cf::async {
2198 $Coro::current->{desc} = "map prefetcher";
2199
1977 while (%MAP_PREFETCH) { 2200 while (%MAP_PREFETCH) {
1978 while (my ($k, $v) = each %MAP_PREFETCH) { 2201 while (my ($k, $v) = each %MAP_PREFETCH) {
1979 if (my $map = find $k) { 2202 if (my $map = find $k) {
1980 $map->load if $v; 2203 $map->load if $v;
1981 } 2204 }
… …
2007 return if $self->{deny_save}; 2230 return if $self->{deny_save};
2008 2231
2009 local $self->{last_access} = $self->last_access;#d# 2232 local $self->{last_access} = $self->last_access;#d#
2010 2233
2011 cf::async { 2234 cf::async {
2235 $Coro::current->{desc} = "map player save";
2012 $_->contr->save for $self->players; 2236 $_->contr->save for $self->players;
2013 }; 2237 };
2238
2239 cf::get_slot 0.02;
2014 2240
2015 if ($uniq) { 2241 if ($uniq) {
2016 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2242 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2017 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2243 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2018 } else { 2244 } else {
… …
2027 $self->save; 2253 $self->save;
2028 2254
2029 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2255 my $lock = cf::lock_acquire "map_data:$self->{path}";
2030 2256
2031 return if $self->players; 2257 return if $self->players;
2032 return if $self->in_memory != cf::MAP_IN_MEMORY; 2258 return if $self->in_memory != cf::MAP_ACTIVE;
2033 return if $self->{deny_save}; 2259 return if $self->{deny_save};
2034 2260
2261 $self->in_memory (cf::MAP_SWAPPED);
2262
2263 $self->deactivate;
2264 $_->clear_links_to ($self) for values %cf::MAP;
2035 $self->clear; 2265 $self->clear;
2036 $self->in_memory (cf::MAP_SWAPPED);
2037} 2266}
2038 2267
2039sub reset_at { 2268sub reset_at {
2040 my ($self) = @_; 2269 my ($self) = @_;
2041 2270
… …
2073 if $uniq; 2302 if $uniq;
2074 } 2303 }
2075 2304
2076 delete $cf::MAP{$self->path}; 2305 delete $cf::MAP{$self->path};
2077 2306
2307 $self->deactivate;
2308 $_->clear_links_to ($self) for values %cf::MAP;
2078 $self->clear; 2309 $self->clear;
2079
2080 $_->clear_links_to ($self) for values %cf::MAP;
2081 2310
2082 $self->unlink_save; 2311 $self->unlink_save;
2083 $self->destroy; 2312 $self->destroy;
2084} 2313}
2085 2314
… …
2152 2381
2153sub unique_maps() { 2382sub unique_maps() {
2154 [ 2383 [
2155 map { 2384 map {
2156 utf8::decode $_; 2385 utf8::decode $_;
2157 /\.map$/ 2386 s/\.map$//; # TODO future compatibility hack
2387 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2388 ? ()
2158 ? normalise $_ 2389 : normalise $_
2159 : ()
2160 } @{ aio_readdir $UNIQUEDIR or [] } 2390 } @{ aio_readdir $UNIQUEDIR or [] }
2161 ] 2391 ]
2162} 2392}
2163 2393
2164package cf;
2165
2166=back 2394=back
2167 2395
2168=head3 cf::object 2396=head3 cf::object
2169 2397
2170=cut 2398=cut
… …
2173 2401
2174=over 4 2402=over 4
2175 2403
2176=item $ob->inv_recursive 2404=item $ob->inv_recursive
2177 2405
2178Returns the inventory of the object _and_ their inventories, recursively. 2406Returns the inventory of the object I<and> their inventories, recursively,
2407but I<not> the object itself.
2179 2408
2180=cut 2409=cut
2181 2410
2182sub inv_recursive_; 2411sub inv_recursive_;
2183sub inv_recursive_ { 2412sub inv_recursive_ {
… …
2186 2415
2187sub inv_recursive { 2416sub inv_recursive {
2188 inv_recursive_ inv $_[0] 2417 inv_recursive_ inv $_[0]
2189} 2418}
2190 2419
2420=item $ref = $ob->ref
2421
2422Creates and returns a persistent reference to an object that can be stored as a string.
2423
2424=item $ob = cf::object::deref ($refstring)
2425
2426returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2427even if the object actually exists. May block.
2428
2429=cut
2430
2431sub deref {
2432 my ($ref) = @_;
2433
2434 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2435 my ($uuid, $name) = ($1, $2);
2436 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2437 or return;
2438 $pl->ob->uuid eq $uuid
2439 or return;
2440
2441 $pl->ob
2442 } else {
2443 warn "$ref: cannot resolve object reference\n";
2444 undef
2445 }
2446}
2447
2191package cf; 2448package cf;
2192 2449
2193=back 2450=back
2194 2451
2195=head3 cf::object::player 2452=head3 cf::object::player
… …
2201Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2458Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
2202can be C<undef>. Does the right thing when the player is currently in a 2459can be C<undef>. Does the right thing when the player is currently in a
2203dialogue with the given NPC character. 2460dialogue with the given NPC character.
2204 2461
2205=cut 2462=cut
2463
2464our $SAY_CHANNEL = {
2465 id => "say",
2466 title => "Map",
2467 reply => "say ",
2468 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2469};
2470
2471our $CHAT_CHANNEL = {
2472 id => "chat",
2473 title => "Chat",
2474 reply => "chat ",
2475 tooltip => "Player chat and shouts, global to the server.",
2476};
2206 2477
2207# rough implementation of a future "reply" method that works 2478# rough implementation of a future "reply" method that works
2208# with dialog boxes. 2479# with dialog boxes.
2209#TODO: the first argument must go, split into a $npc->reply_to ( method 2480#TODO: the first argument must go, split into a $npc->reply_to ( method
2210sub cf::object::player::reply($$$;$) { 2481sub cf::object::player::reply($$$;$) {
… …
2222 my $dialog = $pl->{npc_dialog}; 2493 my $dialog = $pl->{npc_dialog};
2223 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2494 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2224 2495
2225 } else { 2496 } else {
2226 $msg = $npc->name . " says: $msg" if $npc; 2497 $msg = $npc->name . " says: $msg" if $npc;
2227 $self->message ($msg, $flags); 2498 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2228 } 2499 }
2229 } 2500 }
2230} 2501}
2231 2502
2232=item $object->send_msg ($channel, $msg, $color, [extra...]) 2503=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2353 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2624 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2354 2625
2355 $self->enter_link; 2626 $self->enter_link;
2356 2627
2357 (async { 2628 (async {
2629 $Coro::current->{desc} = "player::goto $path $x $y";
2630
2631 # *tag paths override both path and x|y
2632 if ($path =~ /^\*(.*)$/) {
2633 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2634 my $ob = $obs[rand @obs];
2635
2636 # see if we actually can go there
2637 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2638 $ob = $obs[rand @obs];
2639 } else {
2640 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2641 }
2642 # else put us there anyways for now #d#
2643
2644 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2645 } else {
2646 ($path, $x, $y) = (undef, undef, undef);
2647 }
2648 }
2649
2358 my $map = eval { 2650 my $map = eval {
2359 my $map = cf::map::find $path; 2651 my $map = defined $path ? cf::map::find $path : undef;
2360 2652
2361 if ($map) { 2653 if ($map) {
2362 $map = $map->customise_for ($self); 2654 $map = $map->customise_for ($self);
2363 $map = $check->($map) if $check && $map; 2655 $map = $check->($map) if $check && $map;
2364 } else { 2656 } else {
2365 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2657 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2366 } 2658 }
2367 2659
2368 $map 2660 $map
2369 }; 2661 };
2370 2662
… …
2406} 2698}
2407 2699
2408sub prepare_random_map { 2700sub prepare_random_map {
2409 my ($exit) = @_; 2701 my ($exit) = @_;
2410 2702
2411 my $guard = cf::lock_acquire "exit_prepare:$exit";
2412
2413 # all this does is basically replace the /! path by 2703 # all this does is basically replace the /! path by
2414 # a new random map path (?random/...) with a seed 2704 # a new random map path (?random/...) with a seed
2415 # that depends on the exit object 2705 # that depends on the exit object
2416 2706
2417 my $rmp = parse_random_map_params $exit->msg; 2707 my $rmp = parse_random_map_params $exit->msg;
… …
2419 if ($exit->map) { 2709 if ($exit->map) {
2420 $rmp->{region} = $exit->region->name; 2710 $rmp->{region} = $exit->region->name;
2421 $rmp->{origin_map} = $exit->map->path; 2711 $rmp->{origin_map} = $exit->map->path;
2422 $rmp->{origin_x} = $exit->x; 2712 $rmp->{origin_x} = $exit->x;
2423 $rmp->{origin_y} = $exit->y; 2713 $rmp->{origin_y} = $exit->y;
2714
2715 $exit->map->touch;
2424 } 2716 }
2425 2717
2426 $rmp->{random_seed} ||= $exit->random_seed; 2718 $rmp->{random_seed} ||= $exit->random_seed;
2427 2719
2428 my $data = cf::to_json $rmp; 2720 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2429 my $md5 = Digest::MD5::md5_hex $data; 2721 my $md5 = Digest::MD5::md5_hex $data;
2430 my $meta = "$RANDOMDIR/$md5.meta"; 2722 my $meta = "$RANDOMDIR/$md5.meta";
2431 2723
2432 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2724 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2433 aio_write $fh, 0, (length $data), $data, 0; 2725 aio_write $fh, 0, (length $data), $data, 0;
2434 undef $fh; 2726 undef $fh;
2435 aio_rename "$meta~", $meta; 2727 aio_rename "$meta~", $meta;
2436 2728
2729 my $slaying = "?random/$md5";
2730
2731 if ($exit->valid) {
2437 $exit->slaying ("?random/$md5"); 2732 $exit->slaying ("?random/$md5");
2438 $exit->msg (undef); 2733 $exit->msg (undef);
2734 }
2439 } 2735 }
2440} 2736}
2441 2737
2442sub cf::object::player::enter_exit { 2738sub cf::object::player::enter_exit {
2443 my ($self, $exit) = @_; 2739 my ($self, $exit) = @_;
2444 2740
2445 return unless $self->type == cf::PLAYER; 2741 return unless $self->type == cf::PLAYER;
2446 2742
2447 if ($exit->slaying eq "/!") {
2448 #TODO: this should de-fi-ni-te-ly not be a sync-job
2449 # the problem is that $exit might not survive long enough
2450 # so it needs to be done right now, right here
2451 cf::sync_job { prepare_random_map $exit };
2452 }
2453
2454 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2455 my $hp = $exit->stats->hp;
2456 my $sp = $exit->stats->sp;
2457
2458 $self->enter_link; 2743 $self->enter_link;
2459 2744
2460 # if exit is damned, update players death & WoR home-position
2461 $self->contr->savebed ($slaying, $hp, $sp)
2462 if $exit->flag (FLAG_DAMNED);
2463
2464 (async { 2745 (async {
2465 $self->deactivate_recursive; # just to be sure 2746 $Coro::current->{desc} = "enter_exit";
2747
2466 unless (eval { 2748 unless (eval {
2749 $self->deactivate_recursive; # just to be sure
2750
2751 # random map handling
2752 {
2753 my $guard = cf::lock_acquire "exit_prepare:$exit";
2754
2755 prepare_random_map $exit
2756 if $exit->slaying eq "/!";
2757 }
2758
2759 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2760 my $x = $exit->stats->hp;
2761 my $y = $exit->stats->sp;
2762
2467 $self->goto ($slaying, $hp, $sp); 2763 $self->goto ($map, $x, $y);
2468 2764
2765 # if exit is damned, update players death & WoR home-position
2766 $self->contr->savebed ($map, $x, $y)
2767 if $exit->flag (cf::FLAG_DAMNED);
2768
2469 1; 2769 1
2470 }) { 2770 }) {
2471 $self->message ("Something went wrong deep within the crossfire server. " 2771 $self->message ("Something went wrong deep within the crossfire server. "
2472 . "I'll try to bring you back to the map you were before. " 2772 . "I'll try to bring you back to the map you were before. "
2473 . "Please report this to the dungeon master!", 2773 . "Please report this to the dungeon master!",
2474 cf::NDI_UNIQUE | cf::NDI_RED); 2774 cf::NDI_UNIQUE | cf::NDI_RED);
… …
2504the message, with C<log> being the default. If C<$color> is negative, suppress 2804the message, with C<log> being the default. If C<$color> is negative, suppress
2505the message unless the client supports the msg packet. 2805the message unless the client supports the msg packet.
2506 2806
2507=cut 2807=cut
2508 2808
2809# non-persistent channels (usually the info channel)
2509our %CHANNEL = ( 2810our %CHANNEL = (
2510 "c/identify" => { 2811 "c/identify" => {
2511 id => "identify", 2812 id => "infobox",
2512 title => "Identify", 2813 title => "Identify",
2513 reply => undef, 2814 reply => undef,
2514 tooltip => "Items recently identified", 2815 tooltip => "Items recently identified",
2515 }, 2816 },
2817 "c/examine" => {
2818 id => "infobox",
2819 title => "Examine",
2820 reply => undef,
2821 tooltip => "Signs and other items you examined",
2822 },
2823 "c/book" => {
2824 id => "infobox",
2825 title => "Book",
2826 reply => undef,
2827 tooltip => "The contents of a note or book",
2828 },
2829 "c/lookat" => {
2830 id => "infobox",
2831 title => "Look",
2832 reply => undef,
2833 tooltip => "What you saw there",
2834 },
2835 "c/who" => {
2836 id => "infobox",
2837 title => "Players",
2838 reply => undef,
2839 tooltip => "Shows players who are currently online",
2840 },
2841 "c/body" => {
2842 id => "infobox",
2843 title => "Body Parts",
2844 reply => undef,
2845 tooltip => "Shows which body parts you posess and are available",
2846 },
2847 "c/uptime" => {
2848 id => "infobox",
2849 title => "Uptime",
2850 reply => undef,
2851 tooltip => "How long the server has been running since last restart",
2852 },
2853 "c/mapinfo" => {
2854 id => "infobox",
2855 title => "Map Info",
2856 reply => undef,
2857 tooltip => "Information related to the maps",
2858 },
2859 "c/party" => {
2860 id => "party",
2861 title => "Party",
2862 reply => "gsay ",
2863 tooltip => "Messages and chat related to your party",
2864 },
2516); 2865);
2517 2866
2518sub cf::client::send_msg { 2867sub cf::client::send_msg {
2519 my ($self, $channel, $msg, $color, @extra) = @_; 2868 my ($self, $channel, $msg, $color, @extra) = @_;
2520 2869
2521 $msg = $self->pl->expand_cfpod ($msg); 2870 $msg = $self->pl->expand_cfpod ($msg);
2522 2871
2523 $color &= cf::NDI_CLIENT_MASK; # just in case... 2872 $color &= cf::NDI_CLIENT_MASK; # just in case...
2524 2873
2525 # check predefined channels, for the benefit of C 2874 # check predefined channels, for the benefit of C
2526 $channel = $CHANNEL{$channel} if $CHANNEL{$channel}; 2875 if ($CHANNEL{$channel}) {
2876 $channel = $CHANNEL{$channel};
2527 2877
2878 $self->ext_msg (channel_info => $channel)
2879 if $self->can_msg;
2880
2881 $channel = $channel->{id};
2882
2528 if (ref $channel) { 2883 } elsif (ref $channel) {
2529 # send meta info to client, if not yet sent 2884 # send meta info to client, if not yet sent
2530 unless (exists $self->{channel}{$channel->{id}}) { 2885 unless (exists $self->{channel}{$channel->{id}}) {
2531 $self->{channel}{$channel->{id}} = $channel; 2886 $self->{channel}{$channel->{id}} = $channel;
2532 $self->ext_msg (channel_info => $channel); 2887 $self->ext_msg (channel_info => $channel)
2888 if $self->can_msg;
2533 } 2889 }
2534 2890
2535 $channel = $channel->{id}; 2891 $channel = $channel->{id};
2536 } 2892 }
2537 2893
… …
2749=pod 3105=pod
2750 3106
2751The following functions and methods are available within a safe environment: 3107The following functions and methods are available within a safe environment:
2752 3108
2753 cf::object 3109 cf::object
2754 contr pay_amount pay_player map x y force_find force_add 3110 contr pay_amount pay_player map x y force_find force_add destroy
2755 insert remove name archname title slaying race decrease_ob_nr 3111 insert remove name archname title slaying race decrease split
2756 3112
2757 cf::object::player 3113 cf::object::player
2758 player 3114 player
2759 3115
2760 cf::player 3116 cf::player
… …
2766=cut 3122=cut
2767 3123
2768for ( 3124for (
2769 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3125 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2770 insert remove inv name archname title slaying race 3126 insert remove inv name archname title slaying race
2771 decrease_ob_nr)], 3127 decrease split destroy)],
2772 ["cf::object::player" => qw(player)], 3128 ["cf::object::player" => qw(player)],
2773 ["cf::player" => qw(peaceful)], 3129 ["cf::player" => qw(peaceful)],
2774 ["cf::map" => qw(trigger)], 3130 ["cf::map" => qw(trigger)],
2775) { 3131) {
2776 no strict 'refs'; 3132 no strict 'refs';
… …
2881 { 3237 {
2882 my $faces = $facedata->{faceinfo}; 3238 my $faces = $facedata->{faceinfo};
2883 3239
2884 while (my ($face, $info) = each %$faces) { 3240 while (my ($face, $info) = each %$faces) {
2885 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3241 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3242
2886 cf::face::set_visibility $idx, $info->{visibility}; 3243 cf::face::set_visibility $idx, $info->{visibility};
2887 cf::face::set_magicmap $idx, $info->{magicmap}; 3244 cf::face::set_magicmap $idx, $info->{magicmap};
2888 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3245 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2889 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3246 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2890 3247
2891 cf::cede_to_tick; 3248 cf::cede_to_tick;
2892 } 3249 }
2893 3250
2894 while (my ($face, $info) = each %$faces) { 3251 while (my ($face, $info) = each %$faces) {
2895 next unless $info->{smooth}; 3252 next unless $info->{smooth};
3253
2896 my $idx = cf::face::find $face 3254 my $idx = cf::face::find $face
2897 or next; 3255 or next;
3256
2898 if (my $smooth = cf::face::find $info->{smooth}) { 3257 if (my $smooth = cf::face::find $info->{smooth}) {
2899 cf::face::set_smooth $idx, $smooth; 3258 cf::face::set_smooth $idx, $smooth;
2900 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3259 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2901 } else { 3260 } else {
2902 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3261 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
2920 { 3279 {
2921 # TODO: for gcfclient pleasure, we should give resources 3280 # TODO: for gcfclient pleasure, we should give resources
2922 # that gcfclient doesn't grok a >10000 face index. 3281 # that gcfclient doesn't grok a >10000 face index.
2923 my $res = $facedata->{resource}; 3282 my $res = $facedata->{resource};
2924 3283
2925 my $soundconf = delete $res->{"res/sound.conf"};
2926
2927 while (my ($name, $info) = each %$res) { 3284 while (my ($name, $info) = each %$res) {
3285 if (defined $info->{type}) {
2928 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3286 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2929 my $data; 3287 my $data;
2930 3288
2931 if ($info->{type} & 1) { 3289 if ($info->{type} & 1) {
2932 # prepend meta info 3290 # prepend meta info
2933 3291
2934 my $meta = $enc->encode ({ 3292 my $meta = $enc->encode ({
2935 name => $name, 3293 name => $name,
2936 %{ $info->{meta} || {} }, 3294 %{ $info->{meta} || {} },
2937 }); 3295 });
2938 3296
2939 $data = pack "(w/a*)*", $meta, $info->{data}; 3297 $data = pack "(w/a*)*", $meta, $info->{data};
3298 } else {
3299 $data = $info->{data};
3300 }
3301
3302 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3303 cf::face::set_type $idx, $info->{type};
2940 } else { 3304 } else {
2941 $data = $info->{data}; 3305 $RESOURCE{$name} = $info;
2942 } 3306 }
2943 3307
2944 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2945 cf::face::set_type $idx, $info->{type};
2946
2947 cf::cede_to_tick; 3308 cf::cede_to_tick;
2948 } 3309 }
2949
2950 if ($soundconf) {
2951 $soundconf = $enc->decode (delete $soundconf->{data});
2952
2953 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2954 my $sound = $soundconf->{compat}[$_]
2955 or next;
2956
2957 my $face = cf::face::find "sound/$sound->[1]";
2958 cf::sound::set $sound->[0] => $face;
2959 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2960 }
2961
2962 while (my ($k, $v) = each %{$soundconf->{event}}) {
2963 my $face = cf::face::find "sound/$v";
2964 cf::sound::set $k => $face;
2965 }
2966 }
2967 } 3310 }
3311
3312 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
2968 3313
2969 1 3314 1
2970} 3315}
3316
3317cf::global->attach (on_resource_update => sub {
3318 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3319 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3320
3321 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3322 my $sound = $soundconf->{compat}[$_]
3323 or next;
3324
3325 my $face = cf::face::find "sound/$sound->[1]";
3326 cf::sound::set $sound->[0] => $face;
3327 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3328 }
3329
3330 while (my ($k, $v) = each %{$soundconf->{event}}) {
3331 my $face = cf::face::find "sound/$v";
3332 cf::sound::set $k => $face;
3333 }
3334 }
3335});
2971 3336
2972register_exticmd fx_want => sub { 3337register_exticmd fx_want => sub {
2973 my ($ns, $want) = @_; 3338 my ($ns, $want) = @_;
2974 3339
2975 while (my ($k, $v) = each %$want) { 3340 while (my ($k, $v) = each %$want) {
2976 $ns->fx_want ($k, $v); 3341 $ns->fx_want ($k, $v);
2977 } 3342 }
2978}; 3343};
3344
3345sub load_resource_file($) {
3346 my $guard = lock_acquire "load_resource_file";
3347
3348 my $status = load_resource_file_ $_[0];
3349 get_slot 0.1, 100;
3350 cf::arch::commit_load;
3351
3352 $status
3353}
2979 3354
2980sub reload_regions { 3355sub reload_regions {
2981 # HACK to clear player env face cache, we need some signal framework 3356 # HACK to clear player env face cache, we need some signal framework
2982 # for this (global event?) 3357 # for this (global event?)
2983 %ext::player_env::MUSIC_FACE_CACHE = (); 3358 %ext::player_env::MUSIC_FACE_CACHE = ();
… …
2997} 3372}
2998 3373
2999sub reload_archetypes { 3374sub reload_archetypes {
3000 load_resource_file "$DATADIR/archetypes" 3375 load_resource_file "$DATADIR/archetypes"
3001 or die "unable to load archetypes\n"; 3376 or die "unable to load archetypes\n";
3002 #d# NEED to laod twice to resolve forward references
3003 # this really needs to be done in an extra post-pass
3004 # (which needs to be synchronous, so solve it differently)
3005 load_resource_file "$DATADIR/archetypes"
3006 or die "unable to load archetypes\n";
3007} 3377}
3008 3378
3009sub reload_treasures { 3379sub reload_treasures {
3010 load_resource_file "$DATADIR/treasures" 3380 load_resource_file "$DATADIR/treasures"
3011 or die "unable to load treasurelists\n"; 3381 or die "unable to load treasurelists\n";
3012} 3382}
3013 3383
3014sub reload_resources { 3384sub reload_resources {
3015 warn "reloading resource files...\n"; 3385 warn "reloading resource files...\n";
3016 3386
3387 reload_facedata;
3388 reload_archetypes;
3017 reload_regions; 3389 reload_regions;
3018 reload_facedata;
3019 #reload_archetypes;#d#
3020 reload_archetypes;
3021 reload_treasures; 3390 reload_treasures;
3022 3391
3023 warn "finished reloading resource files\n"; 3392 warn "finished reloading resource files\n";
3024} 3393}
3025 3394
3026sub init { 3395sub init {
3396 my $guard = freeze_mainloop;
3397
3027 reload_resources; 3398 reload_resources;
3028} 3399}
3029 3400
3030sub reload_config { 3401sub reload_config {
3031 open my $fh, "<:utf8", "$CONFDIR/config" 3402 open my $fh, "<:utf8", "$CONFDIR/config"
3032 or return; 3403 or return;
3033 3404
3034 local $/; 3405 local $/;
3035 *CFG = YAML::Syck::Load <$fh>; 3406 *CFG = YAML::Load <$fh>;
3036 3407
3037 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3408 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3038 3409
3039 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3410 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3040 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3411 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3051sub main { 3422sub main {
3052 # we must not ever block the main coroutine 3423 # we must not ever block the main coroutine
3053 local $Coro::idle = sub { 3424 local $Coro::idle = sub {
3054 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3425 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3055 (async { 3426 (async {
3056 Event::one_event; 3427 $Coro::current->{desc} = "IDLE BUG HANDLER";
3428 EV::loop EV::LOOP_ONESHOT;
3057 })->prio (Coro::PRIO_MAX); 3429 })->prio (Coro::PRIO_MAX);
3058 }; 3430 };
3059 3431
3432 {
3433 my $guard = freeze_mainloop;
3060 reload_config; 3434 reload_config;
3061 db_init; 3435 db_init;
3062 load_extensions; 3436 load_extensions;
3063 3437
3064 $TICK_WATCHER->start; 3438 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3439 evthread_start IO::AIO::poll_fileno;
3440 }
3441
3065 Event::loop; 3442 EV::loop;
3066} 3443}
3067 3444
3068############################################################################# 3445#############################################################################
3069# initialisation and cleanup 3446# initialisation and cleanup
3070 3447
3071# install some emergency cleanup handlers 3448# install some emergency cleanup handlers
3072BEGIN { 3449BEGIN {
3450 our %SIGWATCHER = ();
3073 for my $signal (qw(INT HUP TERM)) { 3451 for my $signal (qw(INT HUP TERM)) {
3074 Event->signal ( 3452 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3075 reentrant => 0,
3076 data => WF_AUTOCANCEL,
3077 signal => $signal,
3078 prio => 0,
3079 cb => sub {
3080 cf::cleanup "SIG$signal"; 3453 cf::cleanup "SIG$signal";
3081 },
3082 ); 3454 };
3083 } 3455 }
3084} 3456}
3085 3457
3086sub write_runtime { 3458sub write_runtime_sync {
3087 my $runtime = "$LOCALDIR/runtime"; 3459 my $runtime = "$LOCALDIR/runtime";
3088 3460
3089 # first touch the runtime file to show we are still running: 3461 # first touch the runtime file to show we are still running:
3090 # the fsync below can take a very very long time. 3462 # the fsync below can take a very very long time.
3091 3463
… …
3117 and return; 3489 and return;
3118 3490
3119 warn "runtime file written.\n"; 3491 warn "runtime file written.\n";
3120 3492
3121 1 3493 1
3494}
3495
3496our $uuid_lock;
3497our $uuid_skip;
3498
3499sub write_uuid_sync($) {
3500 $uuid_skip ||= $_[0];
3501
3502 return if $uuid_lock;
3503 local $uuid_lock = 1;
3504
3505 my $uuid = "$LOCALDIR/uuid";
3506
3507 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3508 or return;
3509
3510 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3511 $uuid_skip = 0;
3512
3513 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3514 and return;
3515
3516 # always fsync - this file is important
3517 aio_fsync $fh
3518 and return;
3519
3520 close $fh
3521 or return;
3522
3523 aio_rename "$uuid~", $uuid
3524 and return;
3525
3526 warn "uuid file written ($value).\n";
3527
3528 1
3529
3530}
3531
3532sub write_uuid($$) {
3533 my ($skip, $sync) = @_;
3534
3535 $sync ? write_uuid_sync $skip
3536 : async { write_uuid_sync $skip };
3122} 3537}
3123 3538
3124sub emergency_save() { 3539sub emergency_save() {
3125 my $freeze_guard = cf::freeze_mainloop; 3540 my $freeze_guard = cf::freeze_mainloop;
3126 3541
… …
3132 # and maps saved/destroyed asynchronously. 3547 # and maps saved/destroyed asynchronously.
3133 warn "begin emergency player save\n"; 3548 warn "begin emergency player save\n";
3134 for my $login (keys %cf::PLAYER) { 3549 for my $login (keys %cf::PLAYER) {
3135 my $pl = $cf::PLAYER{$login} or next; 3550 my $pl = $cf::PLAYER{$login} or next;
3136 $pl->valid or next; 3551 $pl->valid or next;
3552 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3137 $pl->save; 3553 $pl->save;
3138 } 3554 }
3139 warn "end emergency player save\n"; 3555 warn "end emergency player save\n";
3140 3556
3141 warn "begin emergency map save\n"; 3557 warn "begin emergency map save\n";
… …
3147 warn "end emergency map save\n"; 3563 warn "end emergency map save\n";
3148 3564
3149 warn "begin emergency database checkpoint\n"; 3565 warn "begin emergency database checkpoint\n";
3150 BDB::db_env_txn_checkpoint $DB_ENV; 3566 BDB::db_env_txn_checkpoint $DB_ENV;
3151 warn "end emergency database checkpoint\n"; 3567 warn "end emergency database checkpoint\n";
3568
3569 warn "begin write uuid\n";
3570 write_uuid_sync 1;
3571 warn "end write uuid\n";
3152 }; 3572 };
3153 3573
3154 warn "leave emergency perl save\n"; 3574 warn "leave emergency perl save\n";
3155} 3575}
3156 3576
… …
3171 warn "reloading..."; 3591 warn "reloading...";
3172 3592
3173 warn "entering sync_job"; 3593 warn "entering sync_job";
3174 3594
3175 cf::sync_job { 3595 cf::sync_job {
3176 cf::write_runtime; # external watchdog should not bark 3596 cf::write_runtime_sync; # external watchdog should not bark
3177 cf::emergency_save; 3597 cf::emergency_save;
3178 cf::write_runtime; # external watchdog should not bark 3598 cf::write_runtime_sync; # external watchdog should not bark
3179 3599
3180 warn "syncing database to disk"; 3600 warn "syncing database to disk";
3181 BDB::db_env_txn_checkpoint $DB_ENV; 3601 BDB::db_env_txn_checkpoint $DB_ENV;
3182 3602
3183 # if anything goes wrong in here, we should simply crash as we already saved 3603 # if anything goes wrong in here, we should simply crash as we already saved
3184
3185 warn "cancelling all WF_AUTOCANCEL watchers";
3186 for (Event::all_watchers) {
3187 $_->cancel if $_->data & WF_AUTOCANCEL;
3188 }
3189 3604
3190 warn "flushing outstanding aio requests"; 3605 warn "flushing outstanding aio requests";
3191 for (;;) { 3606 for (;;) {
3192 BDB::flush; 3607 BDB::flush;
3193 IO::AIO::flush; 3608 IO::AIO::flush;
3194 Coro::cede; 3609 Coro::cede_notself;
3195 last unless IO::AIO::nreqs || BDB::nreqs; 3610 last unless IO::AIO::nreqs || BDB::nreqs;
3196 warn "iterate..."; 3611 warn "iterate...";
3197 } 3612 }
3198 3613
3199 ++$RELOAD; 3614 ++$RELOAD;
… …
3275 warn "leaving sync_job"; 3690 warn "leaving sync_job";
3276 3691
3277 1 3692 1
3278 } or do { 3693 } or do {
3279 warn $@; 3694 warn $@;
3280 warn "error while reloading, exiting."; 3695 cf::cleanup "error while reloading, exiting.";
3281 exit 1;
3282 }; 3696 };
3283 3697
3284 warn "reloaded"; 3698 warn "reloaded";
3285}; 3699};
3286 3700
… …
3288 3702
3289sub reload_perl() { 3703sub reload_perl() {
3290 # doing reload synchronously and two reloads happen back-to-back, 3704 # doing reload synchronously and two reloads happen back-to-back,
3291 # coro crashes during coro_state_free->destroy here. 3705 # coro crashes during coro_state_free->destroy here.
3292 3706
3293 $RELOAD_WATCHER ||= Event->timer ( 3707 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3294 reentrant => 0,
3295 after => 0,
3296 data => WF_AUTOCANCEL,
3297 cb => sub {
3298 do_reload_perl; 3708 do_reload_perl;
3299 undef $RELOAD_WATCHER; 3709 undef $RELOAD_WATCHER;
3300 },
3301 ); 3710 };
3302} 3711}
3303 3712
3304register_command "reload" => sub { 3713register_command "reload" => sub {
3305 my ($who, $arg) = @_; 3714 my ($who, $arg) = @_;
3306 3715
3307 if ($who->flag (FLAG_WIZ)) { 3716 if ($who->flag (FLAG_WIZ)) {
3308 $who->message ("reloading server."); 3717 $who->message ("reloading server.");
3718 async {
3719 $Coro::current->{desc} = "perl_reload";
3309 async { reload_perl }; 3720 reload_perl;
3721 };
3310 } 3722 }
3311}; 3723};
3312 3724
3313unshift @INC, $LIBDIR; 3725unshift @INC, $LIBDIR;
3314 3726
… …
3316 3728
3317our @WAIT_FOR_TICK; 3729our @WAIT_FOR_TICK;
3318our @WAIT_FOR_TICK_BEGIN; 3730our @WAIT_FOR_TICK_BEGIN;
3319 3731
3320sub wait_for_tick { 3732sub wait_for_tick {
3321 return unless $TICK_WATCHER->is_active;
3322 return if $Coro::current == $Coro::main; 3733 return if tick_inhibit || $Coro::current == $Coro::main;
3323 3734
3324 my $signal = new Coro::Signal; 3735 my $signal = new Coro::Signal;
3325 push @WAIT_FOR_TICK, $signal; 3736 push @WAIT_FOR_TICK, $signal;
3326 $signal->wait; 3737 $signal->wait;
3327} 3738}
3328 3739
3329sub wait_for_tick_begin { 3740sub wait_for_tick_begin {
3330 return unless $TICK_WATCHER->is_active;
3331 return if $Coro::current == $Coro::main; 3741 return if tick_inhibit || $Coro::current == $Coro::main;
3332 3742
3333 my $signal = new Coro::Signal; 3743 my $signal = new Coro::Signal;
3334 push @WAIT_FOR_TICK_BEGIN, $signal; 3744 push @WAIT_FOR_TICK_BEGIN, $signal;
3335 $signal->wait; 3745 $signal->wait;
3336} 3746}
3337 3747
3338 my $min = 1e6;#d# 3748sub tick {
3339 my $avg = 10;
3340$TICK_WATCHER = Event->timer (
3341 reentrant => 0,
3342 parked => 1,
3343 prio => 0,
3344 at => $NEXT_TICK || $TICK,
3345 data => WF_AUTOCANCEL,
3346 cb => sub {
3347 if ($Coro::current != $Coro::main) { 3749 if ($Coro::current != $Coro::main) {
3348 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3750 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3349 unless ++$bug_warning > 10; 3751 unless ++$bug_warning > 10;
3350 return; 3752 return;
3351 } 3753 }
3352 3754
3353 $NOW = $tick_start = Event::time;
3354
3355 cf::server_tick; # one server iteration 3755 cf::server_tick; # one server iteration
3356 3756
3357 0 && sync_job {#d# 3757 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3358 for(1..10) { 3758 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3359 my $t = Event::time; 3759 Coro::async_pool {
3360 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3760 $Coro::current->{desc} = "runtime saver";
3361 or die; 3761 write_runtime_sync
3362 3762 or warn "ERROR: unable to write runtime file: $!";
3363 $map->width (50);
3364 $map->height (50);
3365 $map->alloc;
3366 $map->_load_objects ("/tmp/x.map", 1);
3367 my $t = Event::time - $t;
3368
3369 #next unless $t < 0.0013;#d#
3370 if ($t < $min) {
3371 $min = $t;
3372 }
3373 $avg = $avg * 0.99 + $t * 0.01;
3374 }
3375 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3376 exit 0;
3377 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3378 }; 3763 };
3764 }
3379 3765
3380 $RUNTIME += $TICK;
3381 $NEXT_TICK += $TICK;
3382
3383 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3384 $NEXT_RUNTIME_WRITE = $NOW + 10;
3385 Coro::async_pool {
3386 write_runtime
3387 or warn "ERROR: unable to write runtime file: $!";
3388 };
3389 }
3390
3391# my $AFTER = Event::time;
3392# warn $AFTER - $NOW;#d#
3393
3394 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3766 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3395 $sig->send; 3767 $sig->send;
3396 } 3768 }
3397 while (my $sig = shift @WAIT_FOR_TICK) { 3769 while (my $sig = shift @WAIT_FOR_TICK) {
3398 $sig->send; 3770 $sig->send;
3399 } 3771 }
3400 3772
3401 $NOW = Event::time; 3773 $LOAD = ($NOW - $TICK_START) / $TICK;
3402
3403 # if we are delayed by four ticks or more, skip them all
3404 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3405
3406 $TICK_WATCHER->at ($NEXT_TICK);
3407 $TICK_WATCHER->start;
3408
3409 $LOAD = ($NOW - $tick_start) / $TICK;
3410 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3774 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3411 3775
3412 _post_tick; 3776 if (0) {
3413 3777 if ($NEXT_TICK) {
3414 3778 my $jitter = $TICK_START - $NEXT_TICK;
3779 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3780 warn "jitter $JITTER\n";#d#
3781 }
3415 }, 3782 }
3416); 3783}
3417 3784
3418{ 3785{
3419 BDB::max_poll_time $TICK * 0.1; 3786 # configure BDB
3420 $BDB_POLL_WATCHER = Event->io ( 3787
3421 reentrant => 0,
3422 fd => BDB::poll_fileno,
3423 poll => 'r',
3424 prio => 0,
3425 data => WF_AUTOCANCEL,
3426 cb => \&BDB::poll_cb,
3427 );
3428 BDB::min_parallel 8; 3788 BDB::min_parallel 8;
3429 3789 BDB::max_poll_reqs $TICK * 0.1;
3430 BDB::set_sync_prepare { 3790 $Coro::BDB::WATCHER->priority (1);
3431 my $status;
3432 my $current = $Coro::current;
3433 (
3434 sub {
3435 $status = $!;
3436 $current->ready; undef $current;
3437 },
3438 sub {
3439 Coro::schedule while defined $current;
3440 $! = $status;
3441 },
3442 )
3443 };
3444 3791
3445 unless ($DB_ENV) { 3792 unless ($DB_ENV) {
3446 $DB_ENV = BDB::db_env_create; 3793 $DB_ENV = BDB::db_env_create;
3794 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3795 | BDB::LOG_AUTOREMOVE, 1);
3796 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3797 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3447 3798
3448 cf::sync_job { 3799 cf::sync_job {
3449 eval { 3800 eval {
3450 BDB::db_env_open 3801 BDB::db_env_open
3451 $DB_ENV, 3802 $DB_ENV,
… …
3453 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3804 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3454 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3805 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3455 0666; 3806 0666;
3456 3807
3457 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3808 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3458
3459 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3460 $DB_ENV->set_lk_detect;
3461 }; 3809 };
3462 3810
3463 cf::cleanup "db_env_open(db): $@" if $@; 3811 cf::cleanup "db_env_open(db): $@" if $@;
3464 }; 3812 };
3465 } 3813 }
3814
3815 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3816 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3817 };
3818 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3819 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3820 };
3821 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3822 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3823 };
3466} 3824}
3467 3825
3468{ 3826{
3827 # configure IO::AIO
3828
3469 IO::AIO::min_parallel 8; 3829 IO::AIO::min_parallel 8;
3470
3471 undef $Coro::AIO::WATCHER;
3472 IO::AIO::max_poll_time $TICK * 0.1; 3830 IO::AIO::max_poll_time $TICK * 0.1;
3473 $AIO_POLL_WATCHER = Event->io ( 3831 $Coro::AIO::WATCHER->priority (1);
3474 reentrant => 0,
3475 data => WF_AUTOCANCEL,
3476 fd => IO::AIO::poll_fileno,
3477 poll => 'r',
3478 prio => 6,
3479 cb => \&IO::AIO::poll_cb,
3480 );
3481} 3832}
3482 3833
3483my $_log_backtrace; 3834my $_log_backtrace;
3484 3835
3485sub _log_backtrace { 3836sub _log_backtrace {
… …
3489 3840
3490 # limit the # of concurrent backtraces 3841 # limit the # of concurrent backtraces
3491 if ($_log_backtrace < 2) { 3842 if ($_log_backtrace < 2) {
3492 ++$_log_backtrace; 3843 ++$_log_backtrace;
3493 async { 3844 async {
3845 $Coro::current->{desc} = "abt $msg";
3846
3494 my @bt = fork_call { 3847 my @bt = fork_call {
3495 @addr = map { sprintf "%x", $_ } @addr; 3848 @addr = map { sprintf "%x", $_ } @addr;
3496 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3849 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3497 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3850 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3498 or die "addr2line: $!"; 3851 or die "addr2line: $!";

Diff Legend

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