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.357 by root, Tue Sep 4 08:42:58 2007 UTC vs.
Revision 1.436 by root, Sun Jun 15 20:32: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;
23use Coro::Storable; 46use Coro::Storable;
24use Coro::Util (); 47use Coro::Util ();
25 48
26use JSON::XS (); 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, %PLAYER_LOADING); # all users 113our (%PLAYER, %PLAYER_LOADING); # all users
93our (%MAP, %MAP_LOADING ); # 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
… …
285Return 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.
286 322
287=cut 323=cut
288 324
289our %LOCK; 325our %LOCK;
326our %LOCKER;#d#
290 327
291sub lock_wait($) { 328sub lock_wait($) {
292 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#
293 335
294 # wait for lock, if any 336 # wait for lock, if any
295 while ($LOCK{$key}) { 337 while ($LOCK{$key}) {
296 push @{ $LOCK{$key} }, $Coro::current; 338 push @{ $LOCK{$key} }, $Coro::current;
297 Coro::schedule; 339 Coro::schedule;
… …
303 345
304 # wait, to be sure we are not locked 346 # wait, to be sure we are not locked
305 lock_wait $key; 347 lock_wait $key;
306 348
307 $LOCK{$key} = []; 349 $LOCK{$key} = [];
350 $LOCKER{$key} = $Coro::current;#d#
308 351
309 Coro::guard { 352 Coro::guard {
353 delete $LOCKER{$key};#d#
310 # wake up all waiters, to be on the safe side 354 # wake up all waiters, to be on the safe side
311 $_->ready for @{ delete $LOCK{$key} }; 355 $_->ready for @{ delete $LOCK{$key} };
312 } 356 }
313} 357}
314 358
… …
317 361
318 ! ! $LOCK{$key} 362 ! ! $LOCK{$key}
319} 363}
320 364
321sub freeze_mainloop { 365sub freeze_mainloop {
322 return unless $TICK_WATCHER->is_active; 366 tick_inhibit_inc;
323 367
324 my $guard = Coro::guard { 368 Coro::guard \&tick_inhibit_dec;
325 $TICK_WATCHER->start; 369}
326 }; 370
327 $TICK_WATCHER->stop; 371=item cf::periodic $interval, $cb
328 $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
329} 384}
330 385
331=item cf::get_slot $time[, $priority[, $name]] 386=item cf::get_slot $time[, $priority[, $name]]
332 387
333Allocate $time seconds of blocking CPU time at priority C<$priority>: 388Allocate $time seconds of blocking CPU time at priority C<$priority>:
… …
344our @SLOT_QUEUE; 399our @SLOT_QUEUE;
345our $SLOT_QUEUE; 400our $SLOT_QUEUE;
346 401
347$SLOT_QUEUE->cancel if $SLOT_QUEUE; 402$SLOT_QUEUE->cancel if $SLOT_QUEUE;
348$SLOT_QUEUE = Coro::async { 403$SLOT_QUEUE = Coro::async {
404 $Coro::current->desc ("timeslot manager");
405
349 my $signal = new Coro::Signal; 406 my $signal = new Coro::Signal;
350 407
351 while () { 408 while () {
352 next_job: 409 next_job:
353 my $avail = cf::till_tick; 410 my $avail = cf::till_tick;
… …
361 } 418 }
362 } 419 }
363 } 420 }
364 421
365 if (@SLOT_QUEUE) { 422 if (@SLOT_QUEUE) {
366 # 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
367 push @cf::WAIT_FOR_TICK, $signal; 424 push @cf::WAIT_FOR_TICK, $signal;
368 $signal->wait; 425 $signal->wait;
369 } else { 426 } else {
370 Coro::schedule; 427 Coro::schedule;
371 } 428 }
372 } 429 }
373}; 430};
374 431
375sub get_slot($;$$) { 432sub get_slot($;$$) {
433 return if tick_inhibit || $Coro::current == $Coro::main;
434
376 my ($time, $pri, $name) = @_; 435 my ($time, $pri, $name) = @_;
377 436
378 $time = $TICK * .6 if $time > $TICK * .6; 437 $time = $TICK * .6 if $time > $TICK * .6;
379 my $sig = new Coro::Signal; 438 my $sig = new Coro::Signal;
380 439
… …
394 453
395BEGIN { *async = \&Coro::async_pool } 454BEGIN { *async = \&Coro::async_pool }
396 455
397=item cf::sync_job { BLOCK } 456=item cf::sync_job { BLOCK }
398 457
399The design of Crossfire TRT requires that the main coroutine ($Coro::main) 458The design of Deliantra requires that the main coroutine ($Coro::main)
400is always able to handle events or runnable, as Crossfire TRT is only 459is 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 460partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
402acceptable. 461acceptable.
403 462
404If 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
405the given BLOCK in another coroutine while waiting for the result. The 464the given BLOCK in another coroutine while waiting for the result. The
… …
410 469
411sub sync_job(&) { 470sub sync_job(&) {
412 my ($job) = @_; 471 my ($job) = @_;
413 472
414 if ($Coro::current == $Coro::main) { 473 if ($Coro::current == $Coro::main) {
415 my $time = Event::time; 474 my $time = EV::time;
416 475
417 # this is the main coro, too bad, we have to block 476 # this is the main coro, too bad, we have to block
418 # till the operation succeeds, freezing the server :/ 477 # till the operation succeeds, freezing the server :/
419 478
420 # TODO: use suspend/resume instead 479 LOG llevError, Carp::longmess "sync job";#d#
421 # (but this is cancel-safe) 480
422 my $freeze_guard = freeze_mainloop; 481 my $freeze_guard = freeze_mainloop;
423 482
424 my $busy = 1; 483 my $busy = 1;
425 my @res; 484 my @res;
426 485
427 (async { 486 (async {
487 $Coro::current->desc ("sync job coro");
428 @res = eval { $job->() }; 488 @res = eval { $job->() };
429 warn $@ if $@; 489 warn $@ if $@;
430 undef $busy; 490 undef $busy;
431 })->prio (Coro::PRIO_MAX); 491 })->prio (Coro::PRIO_MAX);
432 492
433 while ($busy) { 493 while ($busy) {
434 Coro::cede or Event::one_event; 494 if (Coro::nready) {
495 Coro::cede_notself;
496 } else {
497 EV::loop EV::LOOP_ONESHOT;
435 } 498 }
499 }
436 500
437 $time = Event::time - $time; 501 my $time = EV::time - $time;
438 502
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 503 $TICK_START += $time; # do not account sync jobs to server load
443 504
444 wantarray ? @res : $res[0] 505 wantarray ? @res : $res[0]
445 } else { 506 } else {
446 # we are in another coroutine, how wonderful, everything just works 507 # we are in another coroutine, how wonderful, everything just works
447 508
… …
472=item fork_call { }, $args 533=item fork_call { }, $args
473 534
474Executes the given code block with the given arguments in a seperate 535Executes the given code block with the given arguments in a seperate
475process, returning the results. Everything must be serialisable with 536process, returning the results. Everything must be serialisable with
476Coro::Storable. May, of course, block. Note that the executed sub may 537Coro::Storable. May, of course, block. Note that the executed sub may
477never block itself or use any form of Event handling. 538never block itself or use any form of event handling.
478 539
479=cut 540=cut
480 541
481sub fork_call(&@) { 542sub fork_call(&@) {
482 my ($cb, @args) = @_; 543 my ($cb, @args) = @_;
… …
491 }, @args; 552 }, @args;
492 553
493 wantarray ? @res : $res[-1] 554 wantarray ? @res : $res[-1]
494} 555}
495 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
496=item $value = cf::db_get $family => $key 584=item $value = cf::db_get $family => $key
497 585
498Returns a single value from the environment database. 586Returns a single value from the environment database.
499 587
500=item cf::db_put $family => $key => $value 588=item cf::db_put $family => $key => $value
501 589
502Stores 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
503data 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).
504 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
505=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}
506 616
507our $DB; 617our $DB;
508 618
509sub db_init { 619sub db_init {
510 unless ($DB) {
511 $DB = BDB::db_create $DB_ENV;
512
513 cf::sync_job { 620 cf::sync_job {
514 eval { 621 $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 } 622 };
524} 623}
525 624
526sub db_get($$) { 625sub db_get($$) {
527 my $key = "$_[0]/$_[1]"; 626 my $key = "$_[0]/$_[1]";
528 627
… …
632attach callbacks/event handlers (a collection of which is called an "attachment") 731attach callbacks/event handlers (a collection of which is called an "attachment")
633to it. All such attachable objects support the following methods. 732to it. All such attachable objects support the following methods.
634 733
635In 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>
636C<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
637Crossfire TRT). 736Deliantra).
638 737
639=over 4 738=over 4
640 739
641=item $attachable->attach ($attachment, key => $value...) 740=item $attachable->attach ($attachment, key => $value...)
642 741
… …
924 } 1023 }
925 1024
926 0 1025 0
927} 1026}
928 1027
929=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1028=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
930 1029
931=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1030=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
932 1031
933Generate an object-specific event with the given arguments. 1032Generate an object-specific event with the given arguments.
934 1033
… …
940 1039
941=cut 1040=cut
942 1041
943############################################################################# 1042#############################################################################
944# object support 1043# object support
945#
946 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#
947sub _can_merge { 1078sub _can_merge {
948 my ($ob1, $ob2) = @_; 1079 my ($ob1, $ob2) = @_;
949 1080
950 local $Storable::canonical = 1; 1081 ++$SLOW_MERGES;#d#
951 my $fob1 = Storable::freeze $ob1;
952 my $fob2 = Storable::freeze $ob2;
953 1082
954 $fob1 eq $fob2 1083 # we do the slow way here
1084 return _object_equal $ob1, $ob2
955} 1085}
956 1086
957sub reattach { 1087sub reattach {
958 # basically do the same as instantiate, without calling instantiate 1088 # basically do the same as instantiate, without calling instantiate
959 my ($obj) = @_; 1089 my ($obj) = @_;
… …
981cf::attachable->attach ( 1111cf::attachable->attach (
982 prio => -1000000, 1112 prio => -1000000,
983 on_instantiate => sub { 1113 on_instantiate => sub {
984 my ($obj, $data) = @_; 1114 my ($obj, $data) = @_;
985 1115
986 $data = from_json $data; 1116 $data = decode_json $data;
987 1117
988 for (@$data) { 1118 for (@$data) {
989 my ($name, $args) = @$_; 1119 my ($name, $args) = @$_;
990 1120
991 $obj->attach ($name, %{$args || {} }); 1121 $obj->attach ($name, %{$args || {} });
… …
1005); 1135);
1006 1136
1007sub object_freezer_save { 1137sub object_freezer_save {
1008 my ($filename, $rdata, $objs) = @_; 1138 my ($filename, $rdata, $objs) = @_;
1009 1139
1010 my $guard = cf::lock_acquire "io";
1011
1012 sync_job { 1140 sync_job {
1013 if (length $$rdata) { 1141 if (length $$rdata) {
1142 utf8::decode (my $decname = $filename);
1014 warn sprintf "saving %s (%d,%d)\n", 1143 warn sprintf "saving %s (%d,%d)\n",
1015 $filename, length $$rdata, scalar @$objs; 1144 $decname, length $$rdata, scalar @$objs;
1016 1145
1017 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1146 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1018 chmod SAVE_MODE, $fh; 1147 aio_chmod $fh, SAVE_MODE;
1019 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1148 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1020 aio_fsync $fh if $cf::USE_FSYNC; 1149 aio_fsync $fh if $cf::USE_FSYNC;
1021 close $fh; 1150 aio_close $fh;
1022 1151
1023 if (@$objs) { 1152 if (@$objs) {
1024 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) {
1025 chmod SAVE_MODE, $fh; 1154 aio_chmod $fh, SAVE_MODE;
1026 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1155 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1027 aio_write $fh, 0, (length $data), $data, 0; 1156 aio_write $fh, 0, (length $data), $data, 0;
1028 aio_fsync $fh if $cf::USE_FSYNC; 1157 aio_fsync $fh if $cf::USE_FSYNC;
1029 close $fh; 1158 aio_close $fh;
1030 aio_rename "$filename.pst~", "$filename.pst"; 1159 aio_rename "$filename.pst~", "$filename.pst";
1031 } 1160 }
1032 } else { 1161 } else {
1033 aio_unlink "$filename.pst"; 1162 aio_unlink "$filename.pst";
1034 } 1163 }
… …
1040 } else { 1169 } else {
1041 aio_unlink $filename; 1170 aio_unlink $filename;
1042 aio_unlink "$filename.pst"; 1171 aio_unlink "$filename.pst";
1043 } 1172 }
1044 }; 1173 };
1045
1046 undef $guard;
1047} 1174}
1048 1175
1049sub object_freezer_as_string { 1176sub object_freezer_as_string {
1050 my ($rdata, $objs) = @_; 1177 my ($rdata, $objs) = @_;
1051 1178
… …
1056 1183
1057sub object_thawer_load { 1184sub object_thawer_load {
1058 my ($filename) = @_; 1185 my ($filename) = @_;
1059 1186
1060 my ($data, $av); 1187 my ($data, $av);
1061
1062 my $guard = cf::lock_acquire "io";
1063 1188
1064 (aio_load $filename, $data) >= 0 1189 (aio_load $filename, $data) >= 0
1065 or return; 1190 or return;
1066 1191
1067 unless (aio_stat "$filename.pst") { 1192 unless (aio_stat "$filename.pst") {
1068 (aio_load "$filename.pst", $av) >= 0 1193 (aio_load "$filename.pst", $av) >= 0
1069 or return; 1194 or return;
1070 1195
1071 undef $guard;
1072 $av = eval { (Storable::thaw $av)->{objs} }; 1196 my $st = eval { Coro::Storable::thaw $av };
1197 $av = $st->{objs};
1073 } 1198 }
1074 1199
1200 utf8::decode (my $decname = $filename);
1075 warn sprintf "loading %s (%d)\n", 1201 warn sprintf "loading %s (%d,%d)\n",
1076 $filename, length $data, scalar @{$av || []}; 1202 $decname, length $data, scalar @{$av || []};
1077 1203
1078 ($data, $av) 1204 ($data, $av)
1079} 1205}
1080 1206
1081=head2 COMMAND CALLBACKS 1207=head2 COMMAND CALLBACKS
… …
1232 my $msg = $@ ? "$v->{path}: $@\n" 1358 my $msg = $@ ? "$v->{path}: $@\n"
1233 : "$v->{base}: extension inactive.\n"; 1359 : "$v->{base}: extension inactive.\n";
1234 1360
1235 if (exists $v->{meta}{mandatory}) { 1361 if (exists $v->{meta}{mandatory}) {
1236 warn $msg; 1362 warn $msg;
1237 warn "mandatory extension failed to load, exiting.\n"; 1363 cf::cleanup "mandatory extension failed to load, exiting.";
1238 exit 1;
1239 } 1364 }
1240 1365
1241 warn $msg; 1366 warn $msg;
1242 } 1367 }
1243 1368
… …
1268use Coro::AIO; 1393use Coro::AIO;
1269 1394
1270=head3 cf::player 1395=head3 cf::player
1271 1396
1272=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}
1273 1412
1274=item cf::player::find $login 1413=item cf::player::find $login
1275 1414
1276Returns the given player object, loading it if necessary (might block). 1415Returns the given player object, loading it if necessary (might block).
1277 1416
… …
1316 aio_unlink +(playerdir $login) . "/$login.pl"; 1455 aio_unlink +(playerdir $login) . "/$login.pl";
1317 1456
1318 my $f = new_from_file cf::object::thawer path $login 1457 my $f = new_from_file cf::object::thawer path $login
1319 or return; 1458 or return;
1320 1459
1321 $f->next;
1322 my $pl = cf::player::load_pl $f 1460 my $pl = cf::player::load_pl $f
1323 or return; 1461 or return;
1462
1324 local $cf::PLAYER_LOADING{$login} = $pl; 1463 local $cf::PLAYER_LOADING{$login} = $pl;
1325 $f->resolve_delayed_derefs; 1464 $f->resolve_delayed_derefs;
1326 $cf::PLAYER{$login} = $pl 1465 $cf::PLAYER{$login} = $pl
1327 } 1466 }
1328 } 1467 }
… …
1338 1477
1339 return if $pl->{deny_save}; 1478 return if $pl->{deny_save};
1340 1479
1341 aio_mkdir playerdir $pl, 0770; 1480 aio_mkdir playerdir $pl, 0770;
1342 $pl->{last_save} = $cf::RUNTIME; 1481 $pl->{last_save} = $cf::RUNTIME;
1482
1483 cf::get_slot 0.01;
1343 1484
1344 $pl->save_pl ($path); 1485 $pl->save_pl ($path);
1345 cf::cede_to_tick; 1486 cf::cede_to_tick;
1346} 1487}
1347 1488
… …
1383 $pl->{deny_save} = 1; 1524 $pl->{deny_save} = 1;
1384 $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
1385 1526
1386 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1527 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1387 $pl->deactivate; 1528 $pl->deactivate;
1529 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1530 $pl->ob->check_score;
1388 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1531 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1389 $pl->ns->destroy if $pl->ns; 1532 $pl->ns->destroy if $pl->ns;
1390 1533
1391 my $path = playerdir $pl; 1534 my $path = playerdir $pl;
1392 my $temp = "$path~$cf::RUNTIME~deleting~"; 1535 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1431 1574
1432 for my $login (@$dirs) { 1575 for my $login (@$dirs) {
1433 my $path = path $login; 1576 my $path = path $login;
1434 1577
1435 # a .pst is a dead give-away for a valid player 1578 # a .pst is a dead give-away for a valid player
1436 unless (-e "$path.pst") { 1579 # if no pst file found, open and chekc for blocked users
1580 if (aio_stat "$path.pst") {
1437 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1581 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1438 aio_read $fh, 0, 512, my $buf, 0 or next; 1582 aio_read $fh, 0, 512, my $buf, 0 or next;
1439 $buf !~ /^password -------------$/m or next; # official not-valid tag 1583 $buf !~ /^password -------------$/m or next; # official not-valid tag
1440 } 1584 }
1441 1585
… …
1478 1622
1479Expand crossfire pod fragments into protocol xml. 1623Expand crossfire pod fragments into protocol xml.
1480 1624
1481=cut 1625=cut
1482 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
1483sub expand_cfpod { 1638sub expand_cfpod {
1484 ((my $self), (local $_)) = @_; 1639 my ($self, $pod) = @_;
1485 1640
1486 # escape & and < 1641 my $xml;
1487 s/&/&amp;/g;
1488 s/(?<![BIUGHT])</&lt;/g;
1489 1642
1490 # this is buggy, it needs to properly take care of nested <'s 1643 while () {
1644 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1645 $group = $1;
1491 1646
1492 1 while 1647 $group =~ s/&/&amp;/g;
1493 # replace B<>, I<>, U<> etc. 1648 $group =~ s/</&lt;/g;
1494 s/B<([^\>]*)>/<b>$1<\/b>/ 1649
1495 || s/I<([^\>]*)>/<i>$1<\/i>/ 1650 $xml .= $group;
1496 || s/U<([^\>]*)>/<u>$1<\/u>/ 1651 } elsif ($pod =~ m%\G
1497 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/ 1652 ([BCGHITU])
1498 # replace G<male|female> tags 1653 <
1499 || s{G<([^>|]*)\|([^>]*)>}{ 1654 (?:
1500 $self->gender ? $2 : $1 1655 ([^<>]*) (?{ $group = $^N })
1501 }ge 1656 | < $interior >
1502 # replace H<hint text> 1657 )
1503 || s{H<([^\>]*)>} 1658 >
1659 %gcsx
1504 { 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") {
1505 ("<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>",
1506 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1679 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1507 "") 1680 "")
1508 [$self->{hintmode}] 1681 [$self->{hintmode}];
1682 } else {
1683 $xml .= "error processing '$code($data)' directive";
1509 }ge; 1684 }
1685 } else {
1686 if ($pod =~ /\G(.+)/) {
1687 warn "parse error while expanding $pod (at $1)";
1688 }
1689 last;
1690 }
1691 }
1510 1692
1693 for ($xml) {
1511 # create single paragraphs (very hackish) 1694 # create single paragraphs (very hackish)
1512 s/(?<=\S)\n(?=\w)/ /g; 1695 s/(?<=\S)\n(?=\w)/ /g;
1513 1696
1514 # compress some whitespace 1697 # compress some whitespace
1515 s/\s+\n/\n/g; # ws line-ends 1698 s/\s+\n/\n/g; # ws line-ends
1516 s/\n\n+/\n/g; # double lines 1699 s/\n\n+/\n/g; # double lines
1517 s/^\n+//; # beginning lines 1700 s/^\n+//; # beginning lines
1518 s/\n+$//; # ending lines 1701 s/\n+$//; # ending lines
1702 }
1519 1703
1520 $_ 1704 $xml
1521} 1705}
1706
1707no re 'eval';
1522 1708
1523sub hintmode { 1709sub hintmode {
1524 $_[0]{hintmode} = $_[1] if @_ > 1; 1710 $_[0]{hintmode} = $_[1] if @_ > 1;
1525 $_[0]{hintmode} 1711 $_[0]{hintmode}
1526} 1712}
… …
1598our $MAX_RESET = 3600; 1784our $MAX_RESET = 3600;
1599our $DEFAULT_RESET = 3000; 1785our $DEFAULT_RESET = 3000;
1600 1786
1601sub generate_random_map { 1787sub generate_random_map {
1602 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
1603 # mit "rum" bekleckern, nicht 1792 # mit "rum" bekleckern, nicht
1604 $self->_create_random_map ( 1793 $self->_create_random_map (
1605 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1794 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1606 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1795 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1607 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1796 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1729 1918
1730# the temporary/swap location 1919# the temporary/swap location
1731sub save_path { 1920sub save_path {
1732 my ($self) = @_; 1921 my ($self) = @_;
1733 1922
1734 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1923 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1735 "$TMPDIR/$path.map" 1924 "$TMPDIR/$path.map"
1736} 1925}
1737 1926
1738# the unique path, undef == no special unique path 1927# the unique path, undef == no special unique path
1739sub uniq_path { 1928sub uniq_path {
1740 my ($self) = @_; 1929 my ($self) = @_;
1741 1930
1742 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1931 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1743 "$UNIQUEDIR/$path" 1932 "$UNIQUEDIR/$path"
1744} 1933}
1745 1934
1746# and all this just because we cannot iterate over 1935# and all this just because we cannot iterate over
1747# all maps in C++... 1936# all maps in C++...
… …
1841sub find { 2030sub find {
1842 my ($path, $origin) = @_; 2031 my ($path, $origin) = @_;
1843 2032
1844 $path = normalise $path, $origin && $origin->path; 2033 $path = normalise $path, $origin && $origin->path;
1845 2034
2035 cf::lock_wait "map_data:$path";#d#remove
1846 cf::lock_wait "map_find:$path"; 2036 cf::lock_wait "map_find:$path";
1847 2037
1848 $cf::MAP{$path} || do { 2038 $cf::MAP{$path} || do {
2039 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1849 my $guard = cf::lock_acquire "map_find:$path"; 2040 my $guard2 = cf::lock_acquire "map_find:$path";
2041
1850 my $map = new_from_path cf::map $path 2042 my $map = new_from_path cf::map $path
1851 or return; 2043 or return;
1852 2044
1853 $map->{last_save} = $cf::RUNTIME; 2045 $map->{last_save} = $cf::RUNTIME;
1854 2046
… …
1856 or return; 2048 or return;
1857 2049
1858 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2050 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1859 # doing this can freeze the server in a sync job, obviously 2051 # doing this can freeze the server in a sync job, obviously
1860 #$cf::WAIT_FOR_TICK->wait; 2052 #$cf::WAIT_FOR_TICK->wait;
2053 undef $guard2;
2054 undef $guard1;
1861 $map->reset; 2055 $map->reset;
1862 undef $guard;
1863 return find $path; 2056 return find $path;
1864 } 2057 }
1865 2058
1866 $cf::MAP{$path} = $map 2059 $cf::MAP{$path} = $map
1867 } 2060 }
… …
1879 2072
1880 { 2073 {
1881 my $guard = cf::lock_acquire "map_data:$path"; 2074 my $guard = cf::lock_acquire "map_data:$path";
1882 2075
1883 return unless $self->valid; 2076 return unless $self->valid;
1884 return if $self->in_memory != cf::MAP_SWAPPED; 2077 return unless $self->in_memory == cf::MAP_SWAPPED;
1885 2078
1886 $self->in_memory (cf::MAP_LOADING); 2079 $self->in_memory (cf::MAP_LOADING);
1887 2080
1888 $self->alloc; 2081 $self->alloc;
1889 2082
… …
1929 } 2122 }
1930 2123
1931 $self->{last_save} = $cf::RUNTIME; 2124 $self->{last_save} = $cf::RUNTIME;
1932 $self->last_access ($cf::RUNTIME); 2125 $self->last_access ($cf::RUNTIME);
1933 2126
1934 $self->in_memory (cf::MAP_IN_MEMORY); 2127 $self->in_memory (cf::MAP_ACTIVE);
1935 } 2128 }
1936 2129
1937 $self->post_load; 2130 $self->post_load;
1938} 2131}
1939 2132
… …
1997 my ($path, $origin, $load) = @_; 2190 my ($path, $origin, $load) = @_;
1998 2191
1999 $path = normalise $path, $origin && $origin->{path}; 2192 $path = normalise $path, $origin && $origin->{path};
2000 2193
2001 if (my $map = $cf::MAP{$path}) { 2194 if (my $map = $cf::MAP{$path}) {
2002 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2195 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2003 } 2196 }
2004 2197
2005 $MAP_PREFETCH{$path} |= $load; 2198 $MAP_PREFETCH{$path} |= $load;
2006 2199
2007 $MAP_PREFETCHER ||= cf::async { 2200 $MAP_PREFETCHER ||= cf::async {
2201 $Coro::current->{desc} = "map prefetcher";
2202
2008 while (%MAP_PREFETCH) { 2203 while (%MAP_PREFETCH) {
2009 while (my ($k, $v) = each %MAP_PREFETCH) { 2204 while (my ($k, $v) = each %MAP_PREFETCH) {
2010 if (my $map = find $k) { 2205 if (my $map = find $k) {
2011 $map->load if $v; 2206 $map->load if $v;
2012 } 2207 }
… …
2038 return if $self->{deny_save}; 2233 return if $self->{deny_save};
2039 2234
2040 local $self->{last_access} = $self->last_access;#d# 2235 local $self->{last_access} = $self->last_access;#d#
2041 2236
2042 cf::async { 2237 cf::async {
2238 $Coro::current->{desc} = "map player save";
2043 $_->contr->save for $self->players; 2239 $_->contr->save for $self->players;
2044 }; 2240 };
2241
2242 cf::get_slot 0.02;
2045 2243
2046 if ($uniq) { 2244 if ($uniq) {
2047 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2245 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2048 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2246 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2049 } else { 2247 } else {
… …
2058 $self->save; 2256 $self->save;
2059 2257
2060 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2258 my $lock = cf::lock_acquire "map_data:$self->{path}";
2061 2259
2062 return if $self->players; 2260 return if $self->players;
2063 return if $self->in_memory != cf::MAP_IN_MEMORY; 2261 return if $self->in_memory != cf::MAP_ACTIVE;
2064 return if $self->{deny_save}; 2262 return if $self->{deny_save};
2065 2263
2264 $self->in_memory (cf::MAP_SWAPPED);
2265
2266 $self->deactivate;
2267 $_->clear_links_to ($self) for values %cf::MAP;
2066 $self->clear; 2268 $self->clear;
2067 $self->in_memory (cf::MAP_SWAPPED);
2068} 2269}
2069 2270
2070sub reset_at { 2271sub reset_at {
2071 my ($self) = @_; 2272 my ($self) = @_;
2072 2273
… …
2104 if $uniq; 2305 if $uniq;
2105 } 2306 }
2106 2307
2107 delete $cf::MAP{$self->path}; 2308 delete $cf::MAP{$self->path};
2108 2309
2310 $self->deactivate;
2311 $_->clear_links_to ($self) for values %cf::MAP;
2109 $self->clear; 2312 $self->clear;
2110
2111 $_->clear_links_to ($self) for values %cf::MAP;
2112 2313
2113 $self->unlink_save; 2314 $self->unlink_save;
2114 $self->destroy; 2315 $self->destroy;
2115} 2316}
2116 2317
… …
2183 2384
2184sub unique_maps() { 2385sub unique_maps() {
2185 [ 2386 [
2186 map { 2387 map {
2187 utf8::decode $_; 2388 utf8::decode $_;
2188 /\.map$/ 2389 s/\.map$//; # TODO future compatibility hack
2390 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2391 ? ()
2189 ? normalise $_ 2392 : normalise $_
2190 : ()
2191 } @{ aio_readdir $UNIQUEDIR or [] } 2393 } @{ aio_readdir $UNIQUEDIR or [] }
2192 ] 2394 ]
2193} 2395}
2194 2396
2195package cf;
2196
2197=back 2397=back
2198 2398
2199=head3 cf::object 2399=head3 cf::object
2200 2400
2201=cut 2401=cut
… …
2204 2404
2205=over 4 2405=over 4
2206 2406
2207=item $ob->inv_recursive 2407=item $ob->inv_recursive
2208 2408
2209Returns 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.
2210 2411
2211=cut 2412=cut
2212 2413
2213sub inv_recursive_; 2414sub inv_recursive_;
2214sub inv_recursive_ { 2415sub inv_recursive_ {
… …
2219 inv_recursive_ inv $_[0] 2420 inv_recursive_ inv $_[0]
2220} 2421}
2221 2422
2222=item $ref = $ob->ref 2423=item $ref = $ob->ref
2223 2424
2224creates and returns a persistent reference to an objetc that can be stored as a string. 2425Creates and returns a persistent reference to an object that can be stored as a string.
2225 2426
2226=item $ob = cf::object::deref ($refstring) 2427=item $ob = cf::object::deref ($refstring)
2227 2428
2228returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2429returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2229even if the object actually exists. May block. 2430even if the object actually exists. May block.
… …
2231=cut 2432=cut
2232 2433
2233sub deref { 2434sub deref {
2234 my ($ref) = @_; 2435 my ($ref) = @_;
2235 2436
2236 # temporary compatibility#TODO#remove
2237 $ref =~ s{^<}{player/<};
2238
2239 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) { 2437 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2240 my ($uuid, $name) = ($1, $2); 2438 my ($uuid, $name) = ($1, $2);
2241 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name 2439 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2242 or return; 2440 or return;
2243 $pl->ob->uuid eq $uuid 2441 $pl->ob->uuid eq $uuid
2244 or return; 2442 or return;
… …
2264can 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
2265dialogue with the given NPC character. 2463dialogue with the given NPC character.
2266 2464
2267=cut 2465=cut
2268 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};
2480
2269# rough implementation of a future "reply" method that works 2481# rough implementation of a future "reply" method that works
2270# with dialog boxes. 2482# with dialog boxes.
2271#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
2272sub cf::object::player::reply($$$;$) { 2484sub cf::object::player::reply($$$;$) {
2273 my ($self, $npc, $msg, $flags) = @_; 2485 my ($self, $npc, $msg, $flags) = @_;
… …
2284 my $dialog = $pl->{npc_dialog}; 2496 my $dialog = $pl->{npc_dialog};
2285 $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));
2286 2498
2287 } else { 2499 } else {
2288 $msg = $npc->name . " says: $msg" if $npc; 2500 $msg = $npc->name . " says: $msg" if $npc;
2289 $self->message ($msg, $flags); 2501 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2290 } 2502 }
2291 } 2503 }
2292} 2504}
2293 2505
2294=item $object->send_msg ($channel, $msg, $color, [extra...]) 2506=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2402her, loading and preparing them map, calling the provided $check callback 2614her, loading and preparing them map, calling the provided $check callback
2403that 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
2404the 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
2405be called at the end of this process. 2617be called at the end of this process.
2406 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
2407=cut 2622=cut
2408 2623
2409our $GOTOGEN; 2624our $GOTOGEN;
2410 2625
2411sub cf::object::player::goto { 2626sub cf::object::player::goto {
… …
2415 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2630 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2416 2631
2417 $self->enter_link; 2632 $self->enter_link;
2418 2633
2419 (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
2420 my $map = eval { 2656 my $map = eval {
2421 my $map = cf::map::find $path; 2657 my $map = defined $path ? cf::map::find $path : undef;
2422 2658
2423 if ($map) { 2659 if ($map) {
2424 $map = $map->customise_for ($self); 2660 $map = $map->customise_for ($self);
2425 $map = $check->($map) if $check && $map; 2661 $map = $check->($map) if $check && $map;
2426 } else { 2662 } else {
2427 $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);
2428 } 2664 }
2429 2665
2430 $map 2666 $map
2431 }; 2667 };
2432 2668
… …
2468} 2704}
2469 2705
2470sub prepare_random_map { 2706sub prepare_random_map {
2471 my ($exit) = @_; 2707 my ($exit) = @_;
2472 2708
2473 my $guard = cf::lock_acquire "exit_prepare:$exit";
2474
2475 # all this does is basically replace the /! path by 2709 # all this does is basically replace the /! path by
2476 # a new random map path (?random/...) with a seed 2710 # a new random map path (?random/...) with a seed
2477 # that depends on the exit object 2711 # that depends on the exit object
2478 2712
2479 my $rmp = parse_random_map_params $exit->msg; 2713 my $rmp = parse_random_map_params $exit->msg;
… …
2481 if ($exit->map) { 2715 if ($exit->map) {
2482 $rmp->{region} = $exit->region->name; 2716 $rmp->{region} = $exit->region->name;
2483 $rmp->{origin_map} = $exit->map->path; 2717 $rmp->{origin_map} = $exit->map->path;
2484 $rmp->{origin_x} = $exit->x; 2718 $rmp->{origin_x} = $exit->x;
2485 $rmp->{origin_y} = $exit->y; 2719 $rmp->{origin_y} = $exit->y;
2720
2721 $exit->map->touch;
2486 } 2722 }
2487 2723
2488 $rmp->{random_seed} ||= $exit->random_seed; 2724 $rmp->{random_seed} ||= $exit->random_seed;
2489 2725
2490 my $data = cf::to_json $rmp; 2726 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2491 my $md5 = Digest::MD5::md5_hex $data; 2727 my $md5 = Digest::MD5::md5_hex $data;
2492 my $meta = "$RANDOMDIR/$md5.meta"; 2728 my $meta = "$RANDOMDIR/$md5.meta";
2493 2729
2494 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2730 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2495 aio_write $fh, 0, (length $data), $data, 0; 2731 aio_write $fh, 0, (length $data), $data, 0;
2496 undef $fh; 2732 undef $fh;
2497 aio_rename "$meta~", $meta; 2733 aio_rename "$meta~", $meta;
2498 2734
2735 my $slaying = "?random/$md5";
2736
2737 if ($exit->valid) {
2499 $exit->slaying ("?random/$md5"); 2738 $exit->slaying ("?random/$md5");
2500 $exit->msg (undef); 2739 $exit->msg (undef);
2740 }
2501 } 2741 }
2502} 2742}
2503 2743
2504sub cf::object::player::enter_exit { 2744sub cf::object::player::enter_exit {
2505 my ($self, $exit) = @_; 2745 my ($self, $exit) = @_;
2506 2746
2507 return unless $self->type == cf::PLAYER; 2747 return unless $self->type == cf::PLAYER;
2508 2748
2509 if ($exit->slaying eq "/!") {
2510 #TODO: this should de-fi-ni-te-ly not be a sync-job
2511 # the problem is that $exit might not survive long enough
2512 # so it needs to be done right now, right here
2513 cf::sync_job { prepare_random_map $exit };
2514 }
2515
2516 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2517 my $hp = $exit->stats->hp;
2518 my $sp = $exit->stats->sp;
2519
2520 $self->enter_link; 2749 $self->enter_link;
2521 2750
2522 # if exit is damned, update players death & WoR home-position
2523 $self->contr->savebed ($slaying, $hp, $sp)
2524 if $exit->flag (FLAG_DAMNED);
2525
2526 (async { 2751 (async {
2527 $self->deactivate_recursive; # just to be sure 2752 $Coro::current->{desc} = "enter_exit";
2753
2528 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
2529 $self->goto ($slaying, $hp, $sp); 2769 $self->goto ($map, $x, $y);
2530 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
2531 1; 2775 1
2532 }) { 2776 }) {
2533 $self->message ("Something went wrong deep within the crossfire server. " 2777 $self->message ("Something went wrong deep within the crossfire server. "
2534 . "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. "
2535 . "Please report this to the dungeon master!", 2779 . "Please report this to the dungeon master!",
2536 cf::NDI_UNIQUE | cf::NDI_RED); 2780 cf::NDI_UNIQUE | cf::NDI_RED);
… …
2566the 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
2567the message unless the client supports the msg packet. 2811the message unless the client supports the msg packet.
2568 2812
2569=cut 2813=cut
2570 2814
2815# non-persistent channels (usually the info channel)
2571our %CHANNEL = ( 2816our %CHANNEL = (
2572 "c/identify" => { 2817 "c/identify" => {
2573 id => "identify", 2818 id => "infobox",
2574 title => "Identify", 2819 title => "Identify",
2575 reply => undef, 2820 reply => undef,
2576 tooltip => "Items recently identified", 2821 tooltip => "Items recently identified",
2577 }, 2822 },
2578 "c/examine" => { 2823 "c/examine" => {
2579 id => "examine", 2824 id => "infobox",
2580 title => "Examine", 2825 title => "Examine",
2581 reply => undef, 2826 reply => undef,
2582 tooltip => "Signs and other items you examined", 2827 tooltip => "Signs and other items you examined",
2583 }, 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 },
2584); 2871);
2585 2872
2586sub cf::client::send_msg { 2873sub cf::client::send_msg {
2587 my ($self, $channel, $msg, $color, @extra) = @_; 2874 my ($self, $channel, $msg, $color, @extra) = @_;
2588 2875
2589 $msg = $self->pl->expand_cfpod ($msg); 2876 $msg = $self->pl->expand_cfpod ($msg);
2590 2877
2591 $color &= cf::NDI_CLIENT_MASK; # just in case... 2878 $color &= cf::NDI_CLIENT_MASK; # just in case...
2592 2879
2593 # check predefined channels, for the benefit of C 2880 # check predefined channels, for the benefit of C
2594 $channel = $CHANNEL{$channel} if $CHANNEL{$channel}; 2881 if ($CHANNEL{$channel}) {
2882 $channel = $CHANNEL{$channel};
2595 2883
2884 $self->ext_msg (channel_info => $channel)
2885 if $self->can_msg;
2886
2887 $channel = $channel->{id};
2888
2596 if (ref $channel) { 2889 } elsif (ref $channel) {
2597 # send meta info to client, if not yet sent 2890 # send meta info to client, if not yet sent
2598 unless (exists $self->{channel}{$channel->{id}}) { 2891 unless (exists $self->{channel}{$channel->{id}}) {
2599 $self->{channel}{$channel->{id}} = $channel; 2892 $self->{channel}{$channel->{id}} = $channel;
2600 $self->ext_msg (channel_info => $channel) 2893 $self->ext_msg (channel_info => $channel)
2601 if $self->can_msg; 2894 if $self->can_msg;
… …
2818=pod 3111=pod
2819 3112
2820The following functions and methods are available within a safe environment: 3113The following functions and methods are available within a safe environment:
2821 3114
2822 cf::object 3115 cf::object
2823 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
2824 insert remove name archname title slaying race decrease_ob_nr 3117 insert remove name archname title slaying race decrease split
2825 3118
2826 cf::object::player 3119 cf::object::player
2827 player 3120 player
2828 3121
2829 cf::player 3122 cf::player
… …
2834 3127
2835=cut 3128=cut
2836 3129
2837for ( 3130for (
2838 ["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
2839 insert remove inv name archname title slaying race 3132 insert remove inv nrof name archname title slaying race
2840 decrease_ob_nr)], 3133 decrease split destroy)],
2841 ["cf::object::player" => qw(player)], 3134 ["cf::object::player" => qw(player)],
2842 ["cf::player" => qw(peaceful)], 3135 ["cf::player" => qw(peaceful)],
2843 ["cf::map" => qw(trigger)], 3136 ["cf::map" => qw(trigger)],
2844) { 3137) {
2845 no strict 'refs'; 3138 no strict 'refs';
… …
2950 { 3243 {
2951 my $faces = $facedata->{faceinfo}; 3244 my $faces = $facedata->{faceinfo};
2952 3245
2953 while (my ($face, $info) = each %$faces) { 3246 while (my ($face, $info) = each %$faces) {
2954 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3247 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3248
2955 cf::face::set_visibility $idx, $info->{visibility}; 3249 cf::face::set_visibility $idx, $info->{visibility};
2956 cf::face::set_magicmap $idx, $info->{magicmap}; 3250 cf::face::set_magicmap $idx, $info->{magicmap};
2957 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};
2958 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};
2959 3253
2960 cf::cede_to_tick; 3254 cf::cede_to_tick;
2961 } 3255 }
2962 3256
2963 while (my ($face, $info) = each %$faces) { 3257 while (my ($face, $info) = each %$faces) {
2964 next unless $info->{smooth}; 3258 next unless $info->{smooth};
3259
2965 my $idx = cf::face::find $face 3260 my $idx = cf::face::find $face
2966 or next; 3261 or next;
3262
2967 if (my $smooth = cf::face::find $info->{smooth}) { 3263 if (my $smooth = cf::face::find $info->{smooth}) {
2968 cf::face::set_smooth $idx, $smooth; 3264 cf::face::set_smooth $idx, $smooth;
2969 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3265 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2970 } else { 3266 } else {
2971 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3267 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
2989 { 3285 {
2990 # TODO: for gcfclient pleasure, we should give resources 3286 # TODO: for gcfclient pleasure, we should give resources
2991 # that gcfclient doesn't grok a >10000 face index. 3287 # that gcfclient doesn't grok a >10000 face index.
2992 my $res = $facedata->{resource}; 3288 my $res = $facedata->{resource};
2993 3289
2994 my $soundconf = delete $res->{"res/sound.conf"};
2995
2996 while (my ($name, $info) = each %$res) { 3290 while (my ($name, $info) = each %$res) {
3291 if (defined $info->{type}) {
2997 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3292 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2998 my $data; 3293 my $data;
2999 3294
3000 if ($info->{type} & 1) { 3295 if ($info->{type} & 1) {
3001 # prepend meta info 3296 # prepend meta info
3002 3297
3003 my $meta = $enc->encode ({ 3298 my $meta = $enc->encode ({
3004 name => $name, 3299 name => $name,
3005 %{ $info->{meta} || {} }, 3300 %{ $info->{meta} || {} },
3006 }); 3301 });
3007 3302
3008 $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};
3009 } else { 3310 } else {
3010 $data = $info->{data}; 3311 $RESOURCE{$name} = $info;
3011 } 3312 }
3012 3313
3013 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3014 cf::face::set_type $idx, $info->{type};
3015
3016 cf::cede_to_tick; 3314 cf::cede_to_tick;
3017 } 3315 }
3018
3019 if ($soundconf) {
3020 $soundconf = $enc->decode (delete $soundconf->{data});
3021
3022 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3023 my $sound = $soundconf->{compat}[$_]
3024 or next;
3025
3026 my $face = cf::face::find "sound/$sound->[1]";
3027 cf::sound::set $sound->[0] => $face;
3028 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3029 }
3030
3031 while (my ($k, $v) = each %{$soundconf->{event}}) {
3032 my $face = cf::face::find "sound/$v";
3033 cf::sound::set $k => $face;
3034 }
3035 }
3036 } 3316 }
3317
3318 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3037 3319
3038 1 3320 1
3039} 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});
3040 3342
3041register_exticmd fx_want => sub { 3343register_exticmd fx_want => sub {
3042 my ($ns, $want) = @_; 3344 my ($ns, $want) = @_;
3043 3345
3044 while (my ($k, $v) = each %$want) { 3346 while (my ($k, $v) = each %$want) {
3045 $ns->fx_want ($k, $v); 3347 $ns->fx_want ($k, $v);
3046 } 3348 }
3047}; 3349};
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}
3048 3360
3049sub reload_regions { 3361sub reload_regions {
3050 # HACK to clear player env face cache, we need some signal framework 3362 # HACK to clear player env face cache, we need some signal framework
3051 # for this (global event?) 3363 # for this (global event?)
3052 %ext::player_env::MUSIC_FACE_CACHE = (); 3364 %ext::player_env::MUSIC_FACE_CACHE = ();
… …
3066} 3378}
3067 3379
3068sub reload_archetypes { 3380sub reload_archetypes {
3069 load_resource_file "$DATADIR/archetypes" 3381 load_resource_file "$DATADIR/archetypes"
3070 or die "unable to load archetypes\n"; 3382 or die "unable to load archetypes\n";
3071 #d# NEED to laod twice to resolve forward references
3072 # this really needs to be done in an extra post-pass
3073 # (which needs to be synchronous, so solve it differently)
3074 load_resource_file "$DATADIR/archetypes"
3075 or die "unable to load archetypes\n";
3076} 3383}
3077 3384
3078sub reload_treasures { 3385sub reload_treasures {
3079 load_resource_file "$DATADIR/treasures" 3386 load_resource_file "$DATADIR/treasures"
3080 or die "unable to load treasurelists\n"; 3387 or die "unable to load treasurelists\n";
3081} 3388}
3082 3389
3083sub reload_resources { 3390sub reload_resources {
3084 warn "reloading resource files...\n"; 3391 warn "reloading resource files...\n";
3085 3392
3393 reload_facedata;
3394 reload_archetypes;
3086 reload_regions; 3395 reload_regions;
3087 reload_facedata;
3088 #reload_archetypes;#d#
3089 reload_archetypes;
3090 reload_treasures; 3396 reload_treasures;
3091 3397
3092 warn "finished reloading resource files\n"; 3398 warn "finished reloading resource files\n";
3093} 3399}
3094 3400
3095sub init { 3401sub init {
3402 my $guard = freeze_mainloop;
3403
3404 evthread_start IO::AIO::poll_fileno;
3405
3096 reload_resources; 3406 reload_resources;
3097} 3407}
3098 3408
3099sub reload_config { 3409sub reload_config {
3100 open my $fh, "<:utf8", "$CONFDIR/config" 3410 open my $fh, "<:utf8", "$CONFDIR/config"
3101 or return; 3411 or return;
3102 3412
3103 local $/; 3413 local $/;
3104 *CFG = YAML::Syck::Load <$fh>; 3414 *CFG = YAML::Load <$fh>;
3105 3415
3106 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3416 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3107 3417
3108 $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};
3109 $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};
… …
3120sub main { 3430sub main {
3121 # we must not ever block the main coroutine 3431 # we must not ever block the main coroutine
3122 local $Coro::idle = sub { 3432 local $Coro::idle = sub {
3123 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#
3124 (async { 3434 (async {
3125 Event::one_event; 3435 $Coro::current->{desc} = "IDLE BUG HANDLER";
3436 EV::loop EV::LOOP_ONESHOT;
3126 })->prio (Coro::PRIO_MAX); 3437 })->prio (Coro::PRIO_MAX);
3127 }; 3438 };
3128 3439
3440 {
3441 my $guard = freeze_mainloop;
3129 reload_config; 3442 reload_config;
3130 db_init; 3443 db_init;
3131 load_extensions; 3444 load_extensions;
3132 3445
3133 $TICK_WATCHER->start; 3446 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3447 }
3448
3134 Event::loop; 3449 EV::loop;
3135} 3450}
3136 3451
3137############################################################################# 3452#############################################################################
3138# initialisation and cleanup 3453# initialisation and cleanup
3139 3454
3140# install some emergency cleanup handlers 3455# install some emergency cleanup handlers
3141BEGIN { 3456BEGIN {
3457 our %SIGWATCHER = ();
3142 for my $signal (qw(INT HUP TERM)) { 3458 for my $signal (qw(INT HUP TERM)) {
3143 Event->signal ( 3459 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3144 reentrant => 0,
3145 data => WF_AUTOCANCEL,
3146 signal => $signal,
3147 prio => 0,
3148 cb => sub {
3149 cf::cleanup "SIG$signal"; 3460 cf::cleanup "SIG$signal";
3150 },
3151 ); 3461 };
3152 } 3462 }
3153} 3463}
3154 3464
3155sub write_runtime { 3465sub write_runtime_sync {
3156 my $runtime = "$LOCALDIR/runtime"; 3466 my $runtime = "$LOCALDIR/runtime";
3157 3467
3158 # first touch the runtime file to show we are still running: 3468 # first touch the runtime file to show we are still running:
3159 # the fsync below can take a very very long time. 3469 # the fsync below can take a very very long time.
3160 3470
… …
3186 and return; 3496 and return;
3187 3497
3188 warn "runtime file written.\n"; 3498 warn "runtime file written.\n";
3189 3499
3190 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 };
3191} 3544}
3192 3545
3193sub emergency_save() { 3546sub emergency_save() {
3194 my $freeze_guard = cf::freeze_mainloop; 3547 my $freeze_guard = cf::freeze_mainloop;
3195 3548
… …
3201 # and maps saved/destroyed asynchronously. 3554 # and maps saved/destroyed asynchronously.
3202 warn "begin emergency player save\n"; 3555 warn "begin emergency player save\n";
3203 for my $login (keys %cf::PLAYER) { 3556 for my $login (keys %cf::PLAYER) {
3204 my $pl = $cf::PLAYER{$login} or next; 3557 my $pl = $cf::PLAYER{$login} or next;
3205 $pl->valid or next; 3558 $pl->valid or next;
3559 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3206 $pl->save; 3560 $pl->save;
3207 } 3561 }
3208 warn "end emergency player save\n"; 3562 warn "end emergency player save\n";
3209 3563
3210 warn "begin emergency map save\n"; 3564 warn "begin emergency map save\n";
… …
3216 warn "end emergency map save\n"; 3570 warn "end emergency map save\n";
3217 3571
3218 warn "begin emergency database checkpoint\n"; 3572 warn "begin emergency database checkpoint\n";
3219 BDB::db_env_txn_checkpoint $DB_ENV; 3573 BDB::db_env_txn_checkpoint $DB_ENV;
3220 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";
3221 }; 3579 };
3222 3580
3223 warn "leave emergency perl save\n"; 3581 warn "leave emergency perl save\n";
3224} 3582}
3225 3583
… …
3240 warn "reloading..."; 3598 warn "reloading...";
3241 3599
3242 warn "entering sync_job"; 3600 warn "entering sync_job";
3243 3601
3244 cf::sync_job { 3602 cf::sync_job {
3245 cf::write_runtime; # external watchdog should not bark 3603 cf::write_runtime_sync; # external watchdog should not bark
3246 cf::emergency_save; 3604 cf::emergency_save;
3247 cf::write_runtime; # external watchdog should not bark 3605 cf::write_runtime_sync; # external watchdog should not bark
3248 3606
3249 warn "syncing database to disk"; 3607 warn "syncing database to disk";
3250 BDB::db_env_txn_checkpoint $DB_ENV; 3608 BDB::db_env_txn_checkpoint $DB_ENV;
3251 3609
3252 # 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
3253
3254 warn "cancelling all WF_AUTOCANCEL watchers";
3255 for (Event::all_watchers) {
3256 $_->cancel if $_->data & WF_AUTOCANCEL;
3257 }
3258 3611
3259 warn "flushing outstanding aio requests"; 3612 warn "flushing outstanding aio requests";
3260 for (;;) { 3613 for (;;) {
3261 BDB::flush; 3614 BDB::flush;
3262 IO::AIO::flush; 3615 IO::AIO::flush;
3263 Coro::cede; 3616 Coro::cede_notself;
3264 last unless IO::AIO::nreqs || BDB::nreqs; 3617 last unless IO::AIO::nreqs || BDB::nreqs;
3265 warn "iterate..."; 3618 warn "iterate...";
3266 } 3619 }
3267 3620
3268 ++$RELOAD; 3621 ++$RELOAD;
… …
3344 warn "leaving sync_job"; 3697 warn "leaving sync_job";
3345 3698
3346 1 3699 1
3347 } or do { 3700 } or do {
3348 warn $@; 3701 warn $@;
3349 warn "error while reloading, exiting."; 3702 cf::cleanup "error while reloading, exiting.";
3350 exit 1;
3351 }; 3703 };
3352 3704
3353 warn "reloaded"; 3705 warn "reloaded";
3354}; 3706};
3355 3707
… …
3357 3709
3358sub reload_perl() { 3710sub reload_perl() {
3359 # doing reload synchronously and two reloads happen back-to-back, 3711 # doing reload synchronously and two reloads happen back-to-back,
3360 # coro crashes during coro_state_free->destroy here. 3712 # coro crashes during coro_state_free->destroy here.
3361 3713
3362 $RELOAD_WATCHER ||= Event->timer ( 3714 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3363 reentrant => 0,
3364 after => 0,
3365 data => WF_AUTOCANCEL,
3366 cb => sub {
3367 do_reload_perl; 3715 do_reload_perl;
3368 undef $RELOAD_WATCHER; 3716 undef $RELOAD_WATCHER;
3369 },
3370 ); 3717 };
3371} 3718}
3372 3719
3373register_command "reload" => sub { 3720register_command "reload" => sub {
3374 my ($who, $arg) = @_; 3721 my ($who, $arg) = @_;
3375 3722
3376 if ($who->flag (FLAG_WIZ)) { 3723 if ($who->flag (FLAG_WIZ)) {
3377 $who->message ("reloading server."); 3724 $who->message ("reloading server.");
3725 async {
3726 $Coro::current->{desc} = "perl_reload";
3378 async { reload_perl }; 3727 reload_perl;
3728 };
3379 } 3729 }
3380}; 3730};
3381 3731
3382unshift @INC, $LIBDIR; 3732unshift @INC, $LIBDIR;
3383 3733
… …
3385 3735
3386our @WAIT_FOR_TICK; 3736our @WAIT_FOR_TICK;
3387our @WAIT_FOR_TICK_BEGIN; 3737our @WAIT_FOR_TICK_BEGIN;
3388 3738
3389sub wait_for_tick { 3739sub wait_for_tick {
3390 return unless $TICK_WATCHER->is_active;
3391 return if $Coro::current == $Coro::main; 3740 return if tick_inhibit || $Coro::current == $Coro::main;
3392 3741
3393 my $signal = new Coro::Signal; 3742 my $signal = new Coro::Signal;
3394 push @WAIT_FOR_TICK, $signal; 3743 push @WAIT_FOR_TICK, $signal;
3395 $signal->wait; 3744 $signal->wait;
3396} 3745}
3397 3746
3398sub wait_for_tick_begin { 3747sub wait_for_tick_begin {
3399 return unless $TICK_WATCHER->is_active;
3400 return if $Coro::current == $Coro::main; 3748 return if tick_inhibit || $Coro::current == $Coro::main;
3401 3749
3402 my $signal = new Coro::Signal; 3750 my $signal = new Coro::Signal;
3403 push @WAIT_FOR_TICK_BEGIN, $signal; 3751 push @WAIT_FOR_TICK_BEGIN, $signal;
3404 $signal->wait; 3752 $signal->wait;
3405} 3753}
3406 3754
3407 my $min = 1e6;#d# 3755sub tick {
3408 my $avg = 10;
3409$TICK_WATCHER = Event->timer (
3410 reentrant => 0,
3411 parked => 1,
3412 prio => 0,
3413 at => $NEXT_TICK || $TICK,
3414 data => WF_AUTOCANCEL,
3415 cb => sub {
3416 if ($Coro::current != $Coro::main) { 3756 if ($Coro::current != $Coro::main) {
3417 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"
3418 unless ++$bug_warning > 10; 3758 unless ++$bug_warning > 10;
3419 return; 3759 return;
3420 } 3760 }
3421 3761
3422 $NOW = $tick_start = Event::time;
3423
3424 cf::server_tick; # one server iteration 3762 cf::server_tick; # one server iteration
3425 3763
3426 0 && sync_job {#d# 3764 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3427 for(1..10) { 3765 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3428 my $t = Event::time; 3766 Coro::async_pool {
3429 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3767 $Coro::current->{desc} = "runtime saver";
3430 or die; 3768 write_runtime_sync
3431 3769 or warn "ERROR: unable to write runtime file: $!";
3432 $map->width (50);
3433 $map->height (50);
3434 $map->alloc;
3435 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work
3436 my $t = Event::time - $t;
3437
3438 #next unless $t < 0.0013;#d#
3439 if ($t < $min) {
3440 $min = $t;
3441 }
3442 $avg = $avg * 0.99 + $t * 0.01;
3443 }
3444 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3445 exit 0;
3446 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3447 }; 3770 };
3771 }
3448 3772
3449 $RUNTIME += $TICK;
3450 $NEXT_TICK += $TICK;
3451
3452 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3453 $NEXT_RUNTIME_WRITE = $NOW + 10;
3454 Coro::async_pool {
3455 write_runtime
3456 or warn "ERROR: unable to write runtime file: $!";
3457 };
3458 }
3459
3460# my $AFTER = Event::time;
3461# warn $AFTER - $NOW;#d#
3462
3463 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3773 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3464 $sig->send; 3774 $sig->send;
3465 } 3775 }
3466 while (my $sig = shift @WAIT_FOR_TICK) { 3776 while (my $sig = shift @WAIT_FOR_TICK) {
3467 $sig->send; 3777 $sig->send;
3468 } 3778 }
3469 3779
3470 $NOW = Event::time; 3780 $LOAD = ($NOW - $TICK_START) / $TICK;
3471
3472 # if we are delayed by four ticks or more, skip them all
3473 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3474
3475 $TICK_WATCHER->at ($NEXT_TICK);
3476 $TICK_WATCHER->start;
3477
3478 $LOAD = ($NOW - $tick_start) / $TICK;
3479 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3781 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3480 3782
3481 _post_tick; 3783 if (0) {
3482 3784 if ($NEXT_TICK) {
3483 3785 my $jitter = $TICK_START - $NEXT_TICK;
3786 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3787 warn "jitter $JITTER\n";#d#
3788 }
3484 }, 3789 }
3485); 3790}
3486 3791
3487{ 3792{
3488 BDB::max_poll_time $TICK * 0.1; 3793 # configure BDB
3489 $BDB_POLL_WATCHER = Event->io ( 3794
3490 reentrant => 0,
3491 fd => BDB::poll_fileno,
3492 poll => 'r',
3493 prio => 0,
3494 data => WF_AUTOCANCEL,
3495 cb => \&BDB::poll_cb,
3496 );
3497 BDB::min_parallel 8; 3795 BDB::min_parallel 8;
3498 3796 BDB::max_poll_reqs $TICK * 0.1;
3499 BDB::set_sync_prepare { 3797 $AnyEvent::BDB::WATCHER->priority (1);
3500 my $status;
3501 my $current = $Coro::current;
3502 (
3503 sub {
3504 $status = $!;
3505 $current->ready; undef $current;
3506 },
3507 sub {
3508 Coro::schedule while defined $current;
3509 $! = $status;
3510 },
3511 )
3512 };
3513 3798
3514 unless ($DB_ENV) { 3799 unless ($DB_ENV) {
3515 $DB_ENV = BDB::db_env_create; 3800 $DB_ENV = BDB::db_env_create;
3801 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3802 | BDB::LOG_AUTOREMOVE, 1);
3803 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3804 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3516 3805
3517 cf::sync_job { 3806 cf::sync_job {
3518 eval { 3807 eval {
3519 BDB::db_env_open 3808 BDB::db_env_open
3520 $DB_ENV, 3809 $DB_ENV,
… …
3522 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3811 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3523 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3812 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3524 0666; 3813 0666;
3525 3814
3526 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3815 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3527
3528 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3529 $DB_ENV->set_lk_detect;
3530 }; 3816 };
3531 3817
3532 cf::cleanup "db_env_open(db): $@" if $@; 3818 cf::cleanup "db_env_open(db): $@" if $@;
3533 }; 3819 };
3534 } 3820 }
3821
3822 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3823 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3824 };
3825 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3826 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3827 };
3828 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3829 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3830 };
3535} 3831}
3536 3832
3537{ 3833{
3834 # configure IO::AIO
3835
3538 IO::AIO::min_parallel 8; 3836 IO::AIO::min_parallel 8;
3539
3540 undef $Coro::AIO::WATCHER;
3541 IO::AIO::max_poll_time $TICK * 0.1; 3837 IO::AIO::max_poll_time $TICK * 0.1;
3542 $AIO_POLL_WATCHER = Event->io ( 3838 undef $AnyEvent::AIO::WATCHER;
3543 reentrant => 0,
3544 data => WF_AUTOCANCEL,
3545 fd => IO::AIO::poll_fileno,
3546 poll => 'r',
3547 prio => 6,
3548 cb => \&IO::AIO::poll_cb,
3549 );
3550} 3839}
3551 3840
3552my $_log_backtrace; 3841my $_log_backtrace;
3553 3842
3554sub _log_backtrace { 3843sub _log_backtrace {
… …
3558 3847
3559 # limit the # of concurrent backtraces 3848 # limit the # of concurrent backtraces
3560 if ($_log_backtrace < 2) { 3849 if ($_log_backtrace < 2) {
3561 ++$_log_backtrace; 3850 ++$_log_backtrace;
3562 async { 3851 async {
3852 $Coro::current->{desc} = "abt $msg";
3853
3563 my @bt = fork_call { 3854 my @bt = fork_call {
3564 @addr = map { sprintf "%x", $_ } @addr; 3855 @addr = map { sprintf "%x", $_ } @addr;
3565 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3856 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3566 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3857 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3567 or die "addr2line: $!"; 3858 or die "addr2line: $!";

Diff Legend

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