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.407 by root, Sun Jan 13 09:53:53 2008 UTC

… …
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket; 8use Socket;
9use Storable; 9use EV 1.86;
10use Event;
11use Opcode; 10use Opcode;
12use Safe; 11use Safe;
13use Safe::Hole; 12use Safe::Hole;
13use Storable ();
14 14
15use Coro 3.64 (); 15use Coro 4.32 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::EV;
19use Coro::Timer; 19use Coro::Timer;
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::BDB;
23use Coro::Storable; 24use Coro::Storable;
24use Coro::Util (); 25use Coro::Util ();
25 26
26use JSON::XS (); 27use JSON::XS 2.01 ();
27use BDB (); 28use BDB ();
28use Data::Dumper; 29use Data::Dumper;
29use Digest::MD5; 30use Digest::MD5;
30use Fcntl; 31use Fcntl;
31use YAML::Syck (); 32use YAML::Syck ();
32use IO::AIO 2.32 (); 33use IO::AIO 2.51 ();
33use Time::HiRes; 34use Time::HiRes;
34use Compress::LZF; 35use Compress::LZF;
35use Digest::MD5 (); 36use Digest::MD5 ();
36 37
37# configure various modules to our taste 38# configure various modules to our taste
38# 39#
39$Storable::canonical = 1; # reduce rsync transfers 40$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 41Coro::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 42Compress::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 43
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 44# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1; 45$YAML::Syck::ImplicitUnicode = 1;
47 46
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 47$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
… …
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 69our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 70our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 71our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 72our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 73our $BDBDIR = "$LOCALDIR/db";
74our %RESOURCE;
75 75
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77our $TICK_WATCHER; 77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER; 78our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 80our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 81our $USE_FSYNC = 1; # use fsync to write maps - default off
83 82
84our $BDB_POLL_WATCHER; 83our $BDB_POLL_WATCHER;
84our $BDB_DEADLOCK_WATCHER;
85our $BDB_CHECKPOINT_WATCHER;
86our $BDB_TRICKLE_WATCHER;
85our $DB_ENV; 87our $DB_ENV;
86 88
87our %CFG; 89our %CFG;
88 90
89our $UPTIME; $UPTIME ||= time; 91our $UPTIME; $UPTIME ||= time;
90our $RUNTIME; 92our $RUNTIME;
93our $NOW;
91 94
92our (%PLAYER, %PLAYER_LOADING); # all users 95our (%PLAYER, %PLAYER_LOADING); # all users
93our (%MAP, %MAP_LOADING ); # all maps 96our (%MAP, %MAP_LOADING ); # all maps
94our $LINK_MAP; # the special {link} map, which is always available 97our $LINK_MAP; # the special {link} map, which is always available
95 98
… …
159 162
160The raw value load value from the last tick. 163The raw value load value from the last tick.
161 164
162=item %cf::CFG 165=item %cf::CFG
163 166
164Configuration for the server, loaded from C</etc/crossfire/config>, or 167Configuration for the server, loaded from C</etc/deliantra-server/config>, or
165from wherever your confdir points to. 168from wherever your confdir points to.
166 169
167=item cf::wait_for_tick, cf::wait_for_tick_begin 170=item cf::wait_for_tick, cf::wait_for_tick_begin
168 171
169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
… …
187 $msg .= "\n" 190 $msg .= "\n"
188 unless $msg =~ /\n$/; 191 unless $msg =~ /\n$/;
189 192
190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191 194
192 utf8::encode $msg;
193 LOG llevError, $msg; 195 LOG llevError, $msg;
194 }; 196 };
195} 197}
198
199$Coro::State::DIEHOOK = sub {
200 warn Carp::longmess $_[0];
201 Coro::terminate;
202};
196 203
197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 204@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 205@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 206@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 207@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
213)) { 220)) {
214 no strict 'refs'; 221 no strict 'refs';
215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 222 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
216} 223}
217 224
218$Event::DIED = sub { 225$EV::DIED = sub {
219 warn "error in event callback: @_"; 226 warn "error in event callback: @_";
220}; 227};
221 228
222############################################################################# 229#############################################################################
223 230
… …
246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 253 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
247 $d 254 $d
248 } || "[unable to dump $_[0]: '$@']"; 255 } || "[unable to dump $_[0]: '$@']";
249} 256}
250 257
251=item $ref = cf::from_json $json 258=item $ref = cf::decode_json $json
252 259
253Converts a JSON string into the corresponding perl data structure. 260Converts a JSON string into the corresponding perl data structure.
254 261
255=item $json = cf::to_json $ref 262=item $json = cf::encode_json $ref
256 263
257Converts a perl data structure into its JSON representation. 264Converts a perl data structure into its JSON representation.
258 265
259=cut 266=cut
260 267
261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 268our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
262 269
263sub to_json ($) { $json_coder->encode ($_[0]) } 270sub encode_json($) { $json_coder->encode ($_[0]) }
264sub from_json ($) { $json_coder->decode ($_[0]) } 271sub decode_json($) { $json_coder->decode ($_[0]) }
265 272
266=item cf::lock_wait $string 273=item cf::lock_wait $string
267 274
268Wait until the given lock is available. See cf::lock_acquire. 275Wait until the given lock is available. See cf::lock_acquire.
269 276
… …
285Return true if the lock is currently active, i.e. somebody has locked it. 292Return true if the lock is currently active, i.e. somebody has locked it.
286 293
287=cut 294=cut
288 295
289our %LOCK; 296our %LOCK;
297our %LOCKER;#d#
290 298
291sub lock_wait($) { 299sub lock_wait($) {
292 my ($key) = @_; 300 my ($key) = @_;
301
302 if ($LOCKER{$key} == $Coro::current) {#d#
303 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
304 return;#d#
305 }#d#
293 306
294 # wait for lock, if any 307 # wait for lock, if any
295 while ($LOCK{$key}) { 308 while ($LOCK{$key}) {
296 push @{ $LOCK{$key} }, $Coro::current; 309 push @{ $LOCK{$key} }, $Coro::current;
297 Coro::schedule; 310 Coro::schedule;
… …
303 316
304 # wait, to be sure we are not locked 317 # wait, to be sure we are not locked
305 lock_wait $key; 318 lock_wait $key;
306 319
307 $LOCK{$key} = []; 320 $LOCK{$key} = [];
321 $LOCKER{$key} = $Coro::current;#d#
308 322
309 Coro::guard { 323 Coro::guard {
324 delete $LOCKER{$key};#d#
310 # wake up all waiters, to be on the safe side 325 # wake up all waiters, to be on the safe side
311 $_->ready for @{ delete $LOCK{$key} }; 326 $_->ready for @{ delete $LOCK{$key} };
312 } 327 }
313} 328}
314 329
… …
326 }; 341 };
327 $TICK_WATCHER->stop; 342 $TICK_WATCHER->stop;
328 $guard 343 $guard
329} 344}
330 345
346=item cf::periodic $interval, $cb
347
348Like EV::periodic, but randomly selects a starting point so that the actions
349get spread over timer.
350
351=cut
352
353sub periodic($$) {
354 my ($interval, $cb) = @_;
355
356 my $start = rand List::Util::min 180, $interval;
357
358 EV::periodic $start, $interval, 0, $cb
359}
360
331=item cf::get_slot $time[, $priority[, $name]] 361=item cf::get_slot $time[, $priority[, $name]]
332 362
333Allocate $time seconds of blocking CPU time at priority C<$priority>: 363Allocate $time seconds of blocking CPU time at priority C<$priority>:
334This call blocks and returns only when you have at least C<$time> seconds 364This call blocks and returns only when you have at least C<$time> seconds
335of cpu time till the next tick. The slot is only valid till the next cede. 365of cpu time till the next tick. The slot is only valid till the next cede.
… …
344our @SLOT_QUEUE; 374our @SLOT_QUEUE;
345our $SLOT_QUEUE; 375our $SLOT_QUEUE;
346 376
347$SLOT_QUEUE->cancel if $SLOT_QUEUE; 377$SLOT_QUEUE->cancel if $SLOT_QUEUE;
348$SLOT_QUEUE = Coro::async { 378$SLOT_QUEUE = Coro::async {
379 $Coro::current->desc ("timeslot manager");
380
349 my $signal = new Coro::Signal; 381 my $signal = new Coro::Signal;
350 382
351 while () { 383 while () {
352 next_job: 384 next_job:
353 my $avail = cf::till_tick; 385 my $avail = cf::till_tick;
… …
361 } 393 }
362 } 394 }
363 } 395 }
364 396
365 if (@SLOT_QUEUE) { 397 if (@SLOT_QUEUE) {
366 # we do not use wait_For_tick() as it returns immediately when tick is inactive 398 # we do not use wait_for_tick() as it returns immediately when tick is inactive
367 push @cf::WAIT_FOR_TICK, $signal; 399 push @cf::WAIT_FOR_TICK, $signal;
368 $signal->wait; 400 $signal->wait;
369 } else { 401 } else {
370 Coro::schedule; 402 Coro::schedule;
371 } 403 }
… …
394 426
395BEGIN { *async = \&Coro::async_pool } 427BEGIN { *async = \&Coro::async_pool }
396 428
397=item cf::sync_job { BLOCK } 429=item cf::sync_job { BLOCK }
398 430
399The design of Crossfire TRT requires that the main coroutine ($Coro::main) 431The design of Deliantra requires that the main coroutine ($Coro::main)
400is always able to handle events or runnable, as Crossfire TRT is only 432is 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 433partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
402acceptable. 434acceptable.
403 435
404If it must be done, put the blocking parts into C<sync_job>. This will run 436If 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 437the given BLOCK in another coroutine while waiting for the result. The
… …
410 442
411sub sync_job(&) { 443sub sync_job(&) {
412 my ($job) = @_; 444 my ($job) = @_;
413 445
414 if ($Coro::current == $Coro::main) { 446 if ($Coro::current == $Coro::main) {
415 my $time = Event::time; 447 my $time = EV::time;
416 448
417 # this is the main coro, too bad, we have to block 449 # this is the main coro, too bad, we have to block
418 # till the operation succeeds, freezing the server :/ 450 # till the operation succeeds, freezing the server :/
419 451
452 LOG llevError, Carp::longmess "sync job";#d#
453
420 # TODO: use suspend/resume instead 454 # TODO: use suspend/resume instead
421 # (but this is cancel-safe) 455 # (but this is cancel-safe)
422 my $freeze_guard = freeze_mainloop; 456 my $freeze_guard = freeze_mainloop;
423 457
424 my $busy = 1; 458 my $busy = 1;
425 my @res; 459 my @res;
426 460
427 (async { 461 (async {
462 $Coro::current->desc ("sync job coro");
428 @res = eval { $job->() }; 463 @res = eval { $job->() };
429 warn $@ if $@; 464 warn $@ if $@;
430 undef $busy; 465 undef $busy;
431 })->prio (Coro::PRIO_MAX); 466 })->prio (Coro::PRIO_MAX);
432 467
433 while ($busy) { 468 while ($busy) {
434 Coro::cede or Event::one_event; 469 if (Coro::nready) {
470 Coro::cede_notself;
471 } else {
472 EV::loop EV::LOOP_ONESHOT;
435 } 473 }
474 }
436 475
437 $time = Event::time - $time; 476 $time = EV::time - $time;
438 477
439 LOG llevError | logBacktrace, Carp::longmess "long sync job" 478 LOG llevError | logBacktrace, Carp::longmess "long sync job"
440 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active; 479 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
441 480
442 $tick_start += $time; # do not account sync jobs to server load 481 $tick_start += $time; # do not account sync jobs to server load
… …
472=item fork_call { }, $args 511=item fork_call { }, $args
473 512
474Executes the given code block with the given arguments in a seperate 513Executes the given code block with the given arguments in a seperate
475process, returning the results. Everything must be serialisable with 514process, returning the results. Everything must be serialisable with
476Coro::Storable. May, of course, block. Note that the executed sub may 515Coro::Storable. May, of course, block. Note that the executed sub may
477never block itself or use any form of Event handling. 516never block itself or use any form of event handling.
478 517
479=cut 518=cut
480 519
481sub fork_call(&@) { 520sub fork_call(&@) {
482 my ($cb, @args) = @_; 521 my ($cb, @args) = @_;
… …
500=item cf::db_put $family => $key => $value 539=item cf::db_put $family => $key => $value
501 540
502Stores the given C<$value> in the family. It can currently store binary 541Stores 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). 542data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
504 543
544=item $db = cf::db_table "name"
545
546Create and/or open a new database table. The string must not be "db" and must be unique
547within each server.
548
505=cut 549=cut
550
551sub db_table($) {
552 my ($name) = @_;
553 my $db = BDB::db_create $DB_ENV;
554
555 eval {
556 $db->set_flags (BDB::CHKSUM);
557
558 utf8::encode $name;
559 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
560 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
561 cf::cleanup "db_open(db): $!" if $!;
562 };
563 cf::cleanup "db_open(db): $@" if $@;
564
565 $db
566}
506 567
507our $DB; 568our $DB;
508 569
509sub db_init { 570sub db_init {
510 unless ($DB) {
511 $DB = BDB::db_create $DB_ENV;
512
513 cf::sync_job { 571 cf::sync_job {
514 eval { 572 $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 } 573 };
524} 574}
525 575
526sub db_get($$) { 576sub db_get($$) {
527 my $key = "$_[0]/$_[1]"; 577 my $key = "$_[0]/$_[1]";
528 578
… …
632attach callbacks/event handlers (a collection of which is called an "attachment") 682attach callbacks/event handlers (a collection of which is called an "attachment")
633to it. All such attachable objects support the following methods. 683to it. All such attachable objects support the following methods.
634 684
635In the following description, CLASS can be any of C<global>, C<object> 685In 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 686C<player>, C<client> or C<map> (i.e. the attachable objects in
637Crossfire TRT). 687Deliantra).
638 688
639=over 4 689=over 4
640 690
641=item $attachable->attach ($attachment, key => $value...) 691=item $attachable->attach ($attachment, key => $value...)
642 692
… …
924 } 974 }
925 975
926 0 976 0
927} 977}
928 978
929=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 979=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
930 980
931=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 981=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
932 982
933Generate an object-specific event with the given arguments. 983Generate an object-specific event with the given arguments.
934 984
… …
940 990
941=cut 991=cut
942 992
943############################################################################# 993#############################################################################
944# object support 994# object support
945#
946 995
996sub _object_equal($$);
997sub _object_equal($$) {
998 my ($a, $b) = @_;
999
1000 return 0 unless (ref $a) eq (ref $b);
1001
1002 if ("HASH" eq ref $a) {
1003 my @ka = keys %$a;
1004 my @kb = keys %$b;
1005
1006 return 0 if @ka != @kb;
1007
1008 for (0 .. $#ka) {
1009 return 0 unless $ka[$_] eq $kb[$_];
1010 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1011 }
1012
1013 } elsif ("ARRAY" eq ref $a) {
1014
1015 return 0 if @$a != @$b;
1016
1017 for (0 .. $#$a) {
1018 return 0 unless _object_equal $a->[$_], $b->[$_];
1019 }
1020
1021 } elsif ($a ne $b) {
1022 return 0;
1023 }
1024
1025 1
1026}
1027
1028our $SLOW_MERGES;#d#
947sub _can_merge { 1029sub _can_merge {
948 my ($ob1, $ob2) = @_; 1030 my ($ob1, $ob2) = @_;
949 1031
950 local $Storable::canonical = 1; 1032 ++$SLOW_MERGES;#d#
951 my $fob1 = Storable::freeze $ob1;
952 my $fob2 = Storable::freeze $ob2;
953 1033
954 $fob1 eq $fob2 1034 # we do the slow way here
1035 return _object_equal $ob1, $ob2
955} 1036}
956 1037
957sub reattach { 1038sub reattach {
958 # basically do the same as instantiate, without calling instantiate 1039 # basically do the same as instantiate, without calling instantiate
959 my ($obj) = @_; 1040 my ($obj) = @_;
… …
981cf::attachable->attach ( 1062cf::attachable->attach (
982 prio => -1000000, 1063 prio => -1000000,
983 on_instantiate => sub { 1064 on_instantiate => sub {
984 my ($obj, $data) = @_; 1065 my ($obj, $data) = @_;
985 1066
986 $data = from_json $data; 1067 $data = decode_json $data;
987 1068
988 for (@$data) { 1069 for (@$data) {
989 my ($name, $args) = @$_; 1070 my ($name, $args) = @$_;
990 1071
991 $obj->attach ($name, %{$args || {} }); 1072 $obj->attach ($name, %{$args || {} });
… …
1005); 1086);
1006 1087
1007sub object_freezer_save { 1088sub object_freezer_save {
1008 my ($filename, $rdata, $objs) = @_; 1089 my ($filename, $rdata, $objs) = @_;
1009 1090
1010 my $guard = cf::lock_acquire "io";
1011
1012 sync_job { 1091 sync_job {
1013 if (length $$rdata) { 1092 if (length $$rdata) {
1093 utf8::decode (my $decname = $filename);
1014 warn sprintf "saving %s (%d,%d)\n", 1094 warn sprintf "saving %s (%d,%d)\n",
1015 $filename, length $$rdata, scalar @$objs; 1095 $decname, length $$rdata, scalar @$objs;
1016 1096
1017 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1097 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1018 chmod SAVE_MODE, $fh; 1098 chmod SAVE_MODE, $fh;
1019 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1099 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1020 aio_fsync $fh if $cf::USE_FSYNC; 1100 aio_fsync $fh if $cf::USE_FSYNC;
1021 close $fh; 1101 close $fh;
1022 1102
1023 if (@$objs) { 1103 if (@$objs) {
1024 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1104 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1025 chmod SAVE_MODE, $fh; 1105 chmod SAVE_MODE, $fh;
1026 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1106 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1027 aio_write $fh, 0, (length $data), $data, 0; 1107 aio_write $fh, 0, (length $data), $data, 0;
1028 aio_fsync $fh if $cf::USE_FSYNC; 1108 aio_fsync $fh if $cf::USE_FSYNC;
1029 close $fh; 1109 close $fh;
1030 aio_rename "$filename.pst~", "$filename.pst"; 1110 aio_rename "$filename.pst~", "$filename.pst";
1031 } 1111 }
… …
1040 } else { 1120 } else {
1041 aio_unlink $filename; 1121 aio_unlink $filename;
1042 aio_unlink "$filename.pst"; 1122 aio_unlink "$filename.pst";
1043 } 1123 }
1044 }; 1124 };
1045
1046 undef $guard;
1047} 1125}
1048 1126
1049sub object_freezer_as_string { 1127sub object_freezer_as_string {
1050 my ($rdata, $objs) = @_; 1128 my ($rdata, $objs) = @_;
1051 1129
… …
1056 1134
1057sub object_thawer_load { 1135sub object_thawer_load {
1058 my ($filename) = @_; 1136 my ($filename) = @_;
1059 1137
1060 my ($data, $av); 1138 my ($data, $av);
1061
1062 my $guard = cf::lock_acquire "io";
1063 1139
1064 (aio_load $filename, $data) >= 0 1140 (aio_load $filename, $data) >= 0
1065 or return; 1141 or return;
1066 1142
1067 unless (aio_stat "$filename.pst") { 1143 unless (aio_stat "$filename.pst") {
1068 (aio_load "$filename.pst", $av) >= 0 1144 (aio_load "$filename.pst", $av) >= 0
1069 or return; 1145 or return;
1070 1146
1071 undef $guard;
1072 $av = eval { (Storable::thaw $av)->{objs} }; 1147 my $st = eval { Coro::Storable::thaw $av };
1148 $av = $st->{objs};
1073 } 1149 }
1074 1150
1151 utf8::decode (my $decname = $filename);
1075 warn sprintf "loading %s (%d)\n", 1152 warn sprintf "loading %s (%d,%d)\n",
1076 $filename, length $data, scalar @{$av || []}; 1153 $decname, length $data, scalar @{$av || []};
1077 1154
1078 ($data, $av) 1155 ($data, $av)
1079} 1156}
1080 1157
1081=head2 COMMAND CALLBACKS 1158=head2 COMMAND CALLBACKS
… …
1269 1346
1270=head3 cf::player 1347=head3 cf::player
1271 1348
1272=over 4 1349=over 4
1273 1350
1351=item cf::player::num_playing
1352
1353Returns the official number of playing players, as per the Crossfire metaserver rules.
1354
1355=cut
1356
1357sub num_playing {
1358 scalar grep
1359 $_->ob->map
1360 && !$_->hidden
1361 && !$_->ob->flag (cf::FLAG_WIZ),
1362 cf::player::list
1363}
1364
1274=item cf::player::find $login 1365=item cf::player::find $login
1275 1366
1276Returns the given player object, loading it if necessary (might block). 1367Returns the given player object, loading it if necessary (might block).
1277 1368
1278=cut 1369=cut
… …
1316 aio_unlink +(playerdir $login) . "/$login.pl"; 1407 aio_unlink +(playerdir $login) . "/$login.pl";
1317 1408
1318 my $f = new_from_file cf::object::thawer path $login 1409 my $f = new_from_file cf::object::thawer path $login
1319 or return; 1410 or return;
1320 1411
1321 $f->next;
1322 my $pl = cf::player::load_pl $f 1412 my $pl = cf::player::load_pl $f
1323 or return; 1413 or return;
1324 local $cf::PLAYER_LOADING{$login} = $pl; 1414 local $cf::PLAYER_LOADING{$login} = $pl;
1325 $f->resolve_delayed_derefs; 1415 $f->resolve_delayed_derefs;
1326 $cf::PLAYER{$login} = $pl 1416 $cf::PLAYER{$login} = $pl
… …
1478 1568
1479Expand crossfire pod fragments into protocol xml. 1569Expand crossfire pod fragments into protocol xml.
1480 1570
1481=cut 1571=cut
1482 1572
1573use re 'eval';
1574
1575my $group;
1576my $interior; $interior = qr{
1577 # match a pod interior sequence sans C<< >>
1578 (?:
1579 \ (.*?)\ (?{ $group = $^N })
1580 | < (??{$interior}) >
1581 )
1582}x;
1583
1483sub expand_cfpod { 1584sub expand_cfpod {
1484 ((my $self), (local $_)) = @_; 1585 my ($self, $pod) = @_;
1485 1586
1486 # escape & and < 1587 my $xml;
1487 s/&/&amp;/g;
1488 s/(?<![BIUGHT])</&lt;/g;
1489 1588
1490 # this is buggy, it needs to properly take care of nested <'s 1589 while () {
1590 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1591 $group = $1;
1491 1592
1492 1 while 1593 $group =~ s/&/&amp;/g;
1493 # replace B<>, I<>, U<> etc. 1594 $group =~ s/</&lt;/g;
1494 s/B<([^\>]*)>/<b>$1<\/b>/ 1595
1495 || s/I<([^\>]*)>/<i>$1<\/i>/ 1596 $xml .= $group;
1496 || s/U<([^\>]*)>/<u>$1<\/u>/ 1597 } elsif ($pod =~ m%\G
1497 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/ 1598 ([BCGHITU])
1498 # replace G<male|female> tags 1599 <
1499 || s{G<([^>|]*)\|([^>]*)>}{ 1600 (?:
1500 $self->gender ? $2 : $1 1601 ([^<>]*) (?{ $group = $^N })
1501 }ge 1602 | < $interior >
1502 # replace H<hint text> 1603 )
1503 || s{H<([^\>]*)>} 1604 >
1605 %gcsx
1504 { 1606 ) {
1607 my ($code, $data) = ($1, $group);
1608
1609 if ($code eq "B") {
1610 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1611 } elsif ($code eq "I") {
1612 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1613 } elsif ($code eq "U") {
1614 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1615 } elsif ($code eq "C") {
1616 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1617 } elsif ($code eq "T") {
1618 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1619 } elsif ($code eq "G") {
1620 my ($male, $female) = split /\|/, $data;
1621 $data = $self->gender ? $female : $male;
1622 $xml .= expand_cfpod ($self, $data);
1623 } elsif ($code eq "H") {
1505 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1624 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1506 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1625 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1507 "") 1626 "")
1508 [$self->{hintmode}] 1627 [$self->{hintmode}];
1628 } else {
1629 $xml .= "error processing '$code($data)' directive";
1509 }ge; 1630 }
1631 } else {
1632 if ($pod =~ /\G(.+)/) {
1633 warn "parse error while expanding $pod (at $1)";
1634 }
1635 last;
1636 }
1637 }
1510 1638
1639 for ($xml) {
1511 # create single paragraphs (very hackish) 1640 # create single paragraphs (very hackish)
1512 s/(?<=\S)\n(?=\w)/ /g; 1641 s/(?<=\S)\n(?=\w)/ /g;
1513 1642
1514 # compress some whitespace 1643 # compress some whitespace
1515 s/\s+\n/\n/g; # ws line-ends 1644 s/\s+\n/\n/g; # ws line-ends
1516 s/\n\n+/\n/g; # double lines 1645 s/\n\n+/\n/g; # double lines
1517 s/^\n+//; # beginning lines 1646 s/^\n+//; # beginning lines
1518 s/\n+$//; # ending lines 1647 s/\n+$//; # ending lines
1648 }
1519 1649
1520 $_ 1650 $xml
1521} 1651}
1652
1653no re 'eval';
1522 1654
1523sub hintmode { 1655sub hintmode {
1524 $_[0]{hintmode} = $_[1] if @_ > 1; 1656 $_[0]{hintmode} = $_[1] if @_ > 1;
1525 $_[0]{hintmode} 1657 $_[0]{hintmode}
1526} 1658}
… …
1841sub find { 1973sub find {
1842 my ($path, $origin) = @_; 1974 my ($path, $origin) = @_;
1843 1975
1844 $path = normalise $path, $origin && $origin->path; 1976 $path = normalise $path, $origin && $origin->path;
1845 1977
1978 cf::lock_wait "map_data:$path";#d#remove
1846 cf::lock_wait "map_find:$path"; 1979 cf::lock_wait "map_find:$path";
1847 1980
1848 $cf::MAP{$path} || do { 1981 $cf::MAP{$path} || do {
1849 my $guard = cf::lock_acquire "map_find:$path"; 1982 my $guard1 = cf::lock_acquire "map_find:$path";
1983 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1984
1850 my $map = new_from_path cf::map $path 1985 my $map = new_from_path cf::map $path
1851 or return; 1986 or return;
1852 1987
1853 $map->{last_save} = $cf::RUNTIME; 1988 $map->{last_save} = $cf::RUNTIME;
1854 1989
… …
1856 or return; 1991 or return;
1857 1992
1858 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1993 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1859 # doing this can freeze the server in a sync job, obviously 1994 # doing this can freeze the server in a sync job, obviously
1860 #$cf::WAIT_FOR_TICK->wait; 1995 #$cf::WAIT_FOR_TICK->wait;
1996 undef $guard1;
1997 undef $guard2;
1861 $map->reset; 1998 $map->reset;
1862 undef $guard;
1863 return find $path; 1999 return find $path;
1864 } 2000 }
1865 2001
1866 $cf::MAP{$path} = $map 2002 $cf::MAP{$path} = $map
1867 } 2003 }
… …
1879 2015
1880 { 2016 {
1881 my $guard = cf::lock_acquire "map_data:$path"; 2017 my $guard = cf::lock_acquire "map_data:$path";
1882 2018
1883 return unless $self->valid; 2019 return unless $self->valid;
1884 return if $self->in_memory != cf::MAP_SWAPPED; 2020 return unless $self->in_memory == cf::MAP_SWAPPED;
1885 2021
1886 $self->in_memory (cf::MAP_LOADING); 2022 $self->in_memory (cf::MAP_LOADING);
1887 2023
1888 $self->alloc; 2024 $self->alloc;
1889 2025
… …
2003 } 2139 }
2004 2140
2005 $MAP_PREFETCH{$path} |= $load; 2141 $MAP_PREFETCH{$path} |= $load;
2006 2142
2007 $MAP_PREFETCHER ||= cf::async { 2143 $MAP_PREFETCHER ||= cf::async {
2144 $Coro::current->{desc} = "map prefetcher";
2145
2008 while (%MAP_PREFETCH) { 2146 while (%MAP_PREFETCH) {
2009 while (my ($k, $v) = each %MAP_PREFETCH) { 2147 while (my ($k, $v) = each %MAP_PREFETCH) {
2010 if (my $map = find $k) { 2148 if (my $map = find $k) {
2011 $map->load if $v; 2149 $map->load if $v;
2012 } 2150 }
… …
2038 return if $self->{deny_save}; 2176 return if $self->{deny_save};
2039 2177
2040 local $self->{last_access} = $self->last_access;#d# 2178 local $self->{last_access} = $self->last_access;#d#
2041 2179
2042 cf::async { 2180 cf::async {
2181 $Coro::current->{desc} = "map player save";
2043 $_->contr->save for $self->players; 2182 $_->contr->save for $self->players;
2044 }; 2183 };
2045 2184
2046 if ($uniq) { 2185 if ($uniq) {
2047 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2186 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
2061 2200
2062 return if $self->players; 2201 return if $self->players;
2063 return if $self->in_memory != cf::MAP_IN_MEMORY; 2202 return if $self->in_memory != cf::MAP_IN_MEMORY;
2064 return if $self->{deny_save}; 2203 return if $self->{deny_save};
2065 2204
2205 $self->in_memory (cf::MAP_SWAPPED);
2206
2207 $self->deactivate;
2208 $_->clear_links_to ($self) for values %cf::MAP;
2066 $self->clear; 2209 $self->clear;
2067 $self->in_memory (cf::MAP_SWAPPED);
2068} 2210}
2069 2211
2070sub reset_at { 2212sub reset_at {
2071 my ($self) = @_; 2213 my ($self) = @_;
2072 2214
… …
2104 if $uniq; 2246 if $uniq;
2105 } 2247 }
2106 2248
2107 delete $cf::MAP{$self->path}; 2249 delete $cf::MAP{$self->path};
2108 2250
2251 $self->deactivate;
2252 $_->clear_links_to ($self) for values %cf::MAP;
2109 $self->clear; 2253 $self->clear;
2110
2111 $_->clear_links_to ($self) for values %cf::MAP;
2112 2254
2113 $self->unlink_save; 2255 $self->unlink_save;
2114 $self->destroy; 2256 $self->destroy;
2115} 2257}
2116 2258
… …
2231=cut 2373=cut
2232 2374
2233sub deref { 2375sub deref {
2234 my ($ref) = @_; 2376 my ($ref) = @_;
2235 2377
2236 # temporary compatibility#TODO#remove
2237 $ref =~ s{^<}{player/<};
2238
2239 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) { 2378 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2240 my ($uuid, $name) = ($1, $2); 2379 my ($uuid, $name) = ($1, $2);
2241 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name 2380 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2242 or return; 2381 or return;
2243 $pl->ob->uuid eq $uuid 2382 $pl->ob->uuid eq $uuid
2244 or return; 2383 or return;
… …
2415 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2554 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2416 2555
2417 $self->enter_link; 2556 $self->enter_link;
2418 2557
2419 (async { 2558 (async {
2559 $Coro::current->{desc} = "player::goto $path $x $y";
2560
2561 # *tag paths override both path and x|y
2562 if ($path =~ /^\*(.*)$/) {
2563 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2564 my $ob = $obs[rand @obs];
2565
2566 # see if we actually can go there
2567 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2568 $ob = $obs[rand @obs];
2569 } else {
2570 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2571 }
2572 # else put us there anyways for now #d#
2573
2574 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2575 } else {
2576 ($path, $x, $y) = (undef, undef, undef);
2577 }
2578 }
2579
2420 my $map = eval { 2580 my $map = eval {
2421 my $map = cf::map::find $path; 2581 my $map = defined $path ? cf::map::find $path : undef;
2422 2582
2423 if ($map) { 2583 if ($map) {
2424 $map = $map->customise_for ($self); 2584 $map = $map->customise_for ($self);
2425 $map = $check->($map) if $check && $map; 2585 $map = $check->($map) if $check && $map;
2426 } else { 2586 } else {
2427 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2587 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2428 } 2588 }
2429 2589
2430 $map 2590 $map
2431 }; 2591 };
2432 2592
… …
2485 $rmp->{origin_y} = $exit->y; 2645 $rmp->{origin_y} = $exit->y;
2486 } 2646 }
2487 2647
2488 $rmp->{random_seed} ||= $exit->random_seed; 2648 $rmp->{random_seed} ||= $exit->random_seed;
2489 2649
2490 my $data = cf::to_json $rmp; 2650 my $data = cf::encode_json $rmp;
2491 my $md5 = Digest::MD5::md5_hex $data; 2651 my $md5 = Digest::MD5::md5_hex $data;
2492 my $meta = "$RANDOMDIR/$md5.meta"; 2652 my $meta = "$RANDOMDIR/$md5.meta";
2493 2653
2494 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2654 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2495 aio_write $fh, 0, (length $data), $data, 0; 2655 aio_write $fh, 0, (length $data), $data, 0;
… …
2522 # if exit is damned, update players death & WoR home-position 2682 # if exit is damned, update players death & WoR home-position
2523 $self->contr->savebed ($slaying, $hp, $sp) 2683 $self->contr->savebed ($slaying, $hp, $sp)
2524 if $exit->flag (FLAG_DAMNED); 2684 if $exit->flag (FLAG_DAMNED);
2525 2685
2526 (async { 2686 (async {
2687 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2688
2527 $self->deactivate_recursive; # just to be sure 2689 $self->deactivate_recursive; # just to be sure
2528 unless (eval { 2690 unless (eval {
2529 $self->goto ($slaying, $hp, $sp); 2691 $self->goto ($slaying, $hp, $sp);
2530 2692
2531 1; 2693 1;
… …
2566the message, with C<log> being the default. If C<$color> is negative, suppress 2728the message, with C<log> being the default. If C<$color> is negative, suppress
2567the message unless the client supports the msg packet. 2729the message unless the client supports the msg packet.
2568 2730
2569=cut 2731=cut
2570 2732
2733# non-persistent channels (usually the info channel)
2571our %CHANNEL = ( 2734our %CHANNEL = (
2572 "c/identify" => { 2735 "c/identify" => {
2573 id => "identify", 2736 id => "infobox",
2574 title => "Identify", 2737 title => "Identify",
2575 reply => undef, 2738 reply => undef,
2576 tooltip => "Items recently identified", 2739 tooltip => "Items recently identified",
2577 }, 2740 },
2578 "c/examine" => { 2741 "c/examine" => {
2579 id => "examine", 2742 id => "infobox",
2580 title => "Examine", 2743 title => "Examine",
2581 reply => undef, 2744 reply => undef,
2582 tooltip => "Signs and other items you examined", 2745 tooltip => "Signs and other items you examined",
2583 }, 2746 },
2747 "c/book" => {
2748 id => "infobox",
2749 title => "Book",
2750 reply => undef,
2751 tooltip => "The contents of a note or book",
2752 },
2753 "c/lookat" => {
2754 id => "infobox",
2755 title => "Look",
2756 reply => undef,
2757 tooltip => "What you saw there",
2758 },
2759 "c/who" => {
2760 id => "infobox",
2761 title => "Players",
2762 reply => undef,
2763 tooltip => "Shows players who are currently online",
2764 },
2765 "c/body" => {
2766 id => "infobox",
2767 title => "Body Parts",
2768 reply => undef,
2769 tooltip => "Shows which body parts you posess and are available",
2770 },
2771 "c/uptime" => {
2772 id => "infobox",
2773 title => "Uptime",
2774 reply => undef,
2775 tooltip => "How long the server has been running since last restart",
2776 },
2777 "c/mapinfo" => {
2778 id => "infobox",
2779 title => "Map Info",
2780 reply => undef,
2781 tooltip => "Information related to the maps",
2782 },
2584); 2783);
2585 2784
2586sub cf::client::send_msg { 2785sub cf::client::send_msg {
2587 my ($self, $channel, $msg, $color, @extra) = @_; 2786 my ($self, $channel, $msg, $color, @extra) = @_;
2588 2787
2589 $msg = $self->pl->expand_cfpod ($msg); 2788 $msg = $self->pl->expand_cfpod ($msg);
2590 2789
2591 $color &= cf::NDI_CLIENT_MASK; # just in case... 2790 $color &= cf::NDI_CLIENT_MASK; # just in case...
2592 2791
2593 # check predefined channels, for the benefit of C 2792 # check predefined channels, for the benefit of C
2594 $channel = $CHANNEL{$channel} if $CHANNEL{$channel}; 2793 if ($CHANNEL{$channel}) {
2794 $channel = $CHANNEL{$channel};
2595 2795
2796 $self->ext_msg (channel_info => $channel)
2797 if $self->can_msg;
2798
2799 $channel = $channel->{id};
2800
2596 if (ref $channel) { 2801 } elsif (ref $channel) {
2597 # send meta info to client, if not yet sent 2802 # send meta info to client, if not yet sent
2598 unless (exists $self->{channel}{$channel->{id}}) { 2803 unless (exists $self->{channel}{$channel->{id}}) {
2599 $self->{channel}{$channel->{id}} = $channel; 2804 $self->{channel}{$channel->{id}} = $channel;
2600 $self->ext_msg (channel_info => $channel) 2805 $self->ext_msg (channel_info => $channel)
2601 if $self->can_msg; 2806 if $self->can_msg;
… …
2818=pod 3023=pod
2819 3024
2820The following functions and methods are available within a safe environment: 3025The following functions and methods are available within a safe environment:
2821 3026
2822 cf::object 3027 cf::object
2823 contr pay_amount pay_player map x y force_find force_add 3028 contr pay_amount pay_player map x y force_find force_add destroy
2824 insert remove name archname title slaying race decrease_ob_nr 3029 insert remove name archname title slaying race decrease_ob_nr
2825 3030
2826 cf::object::player 3031 cf::object::player
2827 player 3032 player
2828 3033
… …
2835=cut 3040=cut
2836 3041
2837for ( 3042for (
2838 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3043 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2839 insert remove inv name archname title slaying race 3044 insert remove inv name archname title slaying race
2840 decrease_ob_nr)], 3045 decrease_ob_nr destroy)],
2841 ["cf::object::player" => qw(player)], 3046 ["cf::object::player" => qw(player)],
2842 ["cf::player" => qw(peaceful)], 3047 ["cf::player" => qw(peaceful)],
2843 ["cf::map" => qw(trigger)], 3048 ["cf::map" => qw(trigger)],
2844) { 3049) {
2845 no strict 'refs'; 3050 no strict 'refs';
… …
2950 { 3155 {
2951 my $faces = $facedata->{faceinfo}; 3156 my $faces = $facedata->{faceinfo};
2952 3157
2953 while (my ($face, $info) = each %$faces) { 3158 while (my ($face, $info) = each %$faces) {
2954 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3159 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3160
2955 cf::face::set_visibility $idx, $info->{visibility}; 3161 cf::face::set_visibility $idx, $info->{visibility};
2956 cf::face::set_magicmap $idx, $info->{magicmap}; 3162 cf::face::set_magicmap $idx, $info->{magicmap};
2957 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3163 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}; 3164 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2959 3165
2960 cf::cede_to_tick; 3166 cf::cede_to_tick;
2961 } 3167 }
2962 3168
2963 while (my ($face, $info) = each %$faces) { 3169 while (my ($face, $info) = each %$faces) {
2964 next unless $info->{smooth}; 3170 next unless $info->{smooth};
3171
2965 my $idx = cf::face::find $face 3172 my $idx = cf::face::find $face
2966 or next; 3173 or next;
3174
2967 if (my $smooth = cf::face::find $info->{smooth}) { 3175 if (my $smooth = cf::face::find $info->{smooth}) {
2968 cf::face::set_smooth $idx, $smooth; 3176 cf::face::set_smooth $idx, $smooth;
2969 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3177 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2970 } else { 3178 } else {
2971 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3179 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
2989 { 3197 {
2990 # TODO: for gcfclient pleasure, we should give resources 3198 # TODO: for gcfclient pleasure, we should give resources
2991 # that gcfclient doesn't grok a >10000 face index. 3199 # that gcfclient doesn't grok a >10000 face index.
2992 my $res = $facedata->{resource}; 3200 my $res = $facedata->{resource};
2993 3201
2994 my $soundconf = delete $res->{"res/sound.conf"};
2995
2996 while (my ($name, $info) = each %$res) { 3202 while (my ($name, $info) = each %$res) {
3203 if (defined $info->{type}) {
2997 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3204 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2998 my $data; 3205 my $data;
2999 3206
3000 if ($info->{type} & 1) { 3207 if ($info->{type} & 1) {
3001 # prepend meta info 3208 # prepend meta info
3002 3209
3003 my $meta = $enc->encode ({ 3210 my $meta = $enc->encode ({
3004 name => $name, 3211 name => $name,
3005 %{ $info->{meta} || {} }, 3212 %{ $info->{meta} || {} },
3006 }); 3213 });
3007 3214
3008 $data = pack "(w/a*)*", $meta, $info->{data}; 3215 $data = pack "(w/a*)*", $meta, $info->{data};
3216 } else {
3217 $data = $info->{data};
3218 }
3219
3220 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3221 cf::face::set_type $idx, $info->{type};
3009 } else { 3222 } else {
3010 $data = $info->{data}; 3223 $RESOURCE{$name} = $info;
3011 } 3224 }
3012 3225
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; 3226 cf::cede_to_tick;
3017 } 3227 }
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 } 3228 }
3229
3230 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3037 3231
3038 1 3232 1
3039} 3233}
3234
3235cf::global->attach (on_resource_update => sub {
3236 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3237 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3238
3239 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3240 my $sound = $soundconf->{compat}[$_]
3241 or next;
3242
3243 my $face = cf::face::find "sound/$sound->[1]";
3244 cf::sound::set $sound->[0] => $face;
3245 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3246 }
3247
3248 while (my ($k, $v) = each %{$soundconf->{event}}) {
3249 my $face = cf::face::find "sound/$v";
3250 cf::sound::set $k => $face;
3251 }
3252 }
3253});
3040 3254
3041register_exticmd fx_want => sub { 3255register_exticmd fx_want => sub {
3042 my ($ns, $want) = @_; 3256 my ($ns, $want) = @_;
3043 3257
3044 while (my ($k, $v) = each %$want) { 3258 while (my ($k, $v) = each %$want) {
… …
3120sub main { 3334sub main {
3121 # we must not ever block the main coroutine 3335 # we must not ever block the main coroutine
3122 local $Coro::idle = sub { 3336 local $Coro::idle = sub {
3123 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3337 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3124 (async { 3338 (async {
3125 Event::one_event; 3339 $Coro::current->{desc} = "IDLE BUG HANDLER";
3340 EV::loop EV::LOOP_ONESHOT;
3126 })->prio (Coro::PRIO_MAX); 3341 })->prio (Coro::PRIO_MAX);
3127 }; 3342 };
3128 3343
3129 reload_config; 3344 reload_config;
3130 db_init; 3345 db_init;
3131 load_extensions; 3346 load_extensions;
3132 3347
3133 $TICK_WATCHER->start; 3348 $TICK_WATCHER->start;
3349 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3134 Event::loop; 3350 EV::loop;
3135} 3351}
3136 3352
3137############################################################################# 3353#############################################################################
3138# initialisation and cleanup 3354# initialisation and cleanup
3139 3355
3140# install some emergency cleanup handlers 3356# install some emergency cleanup handlers
3141BEGIN { 3357BEGIN {
3358 our %SIGWATCHER = ();
3142 for my $signal (qw(INT HUP TERM)) { 3359 for my $signal (qw(INT HUP TERM)) {
3143 Event->signal ( 3360 $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"; 3361 cf::cleanup "SIG$signal";
3150 },
3151 ); 3362 };
3152 } 3363 }
3153} 3364}
3154 3365
3155sub write_runtime { 3366sub write_runtime {
3156 my $runtime = "$LOCALDIR/runtime"; 3367 my $runtime = "$LOCALDIR/runtime";
… …
3201 # and maps saved/destroyed asynchronously. 3412 # and maps saved/destroyed asynchronously.
3202 warn "begin emergency player save\n"; 3413 warn "begin emergency player save\n";
3203 for my $login (keys %cf::PLAYER) { 3414 for my $login (keys %cf::PLAYER) {
3204 my $pl = $cf::PLAYER{$login} or next; 3415 my $pl = $cf::PLAYER{$login} or next;
3205 $pl->valid or next; 3416 $pl->valid or next;
3417 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3206 $pl->save; 3418 $pl->save;
3207 } 3419 }
3208 warn "end emergency player save\n"; 3420 warn "end emergency player save\n";
3209 3421
3210 warn "begin emergency map save\n"; 3422 warn "begin emergency map save\n";
… …
3249 warn "syncing database to disk"; 3461 warn "syncing database to disk";
3250 BDB::db_env_txn_checkpoint $DB_ENV; 3462 BDB::db_env_txn_checkpoint $DB_ENV;
3251 3463
3252 # if anything goes wrong in here, we should simply crash as we already saved 3464 # if anything goes wrong in here, we should simply crash as we already saved
3253 3465
3254 warn "cancelling all WF_AUTOCANCEL watchers";
3255 for (Event::all_watchers) {
3256 $_->cancel if $_->data & WF_AUTOCANCEL;
3257 }
3258
3259 warn "flushing outstanding aio requests"; 3466 warn "flushing outstanding aio requests";
3260 for (;;) { 3467 for (;;) {
3261 BDB::flush; 3468 BDB::flush;
3262 IO::AIO::flush; 3469 IO::AIO::flush;
3263 Coro::cede; 3470 Coro::cede_notself;
3264 last unless IO::AIO::nreqs || BDB::nreqs; 3471 last unless IO::AIO::nreqs || BDB::nreqs;
3265 warn "iterate..."; 3472 warn "iterate...";
3266 } 3473 }
3267 3474
3268 ++$RELOAD; 3475 ++$RELOAD;
… …
3357 3564
3358sub reload_perl() { 3565sub reload_perl() {
3359 # doing reload synchronously and two reloads happen back-to-back, 3566 # doing reload synchronously and two reloads happen back-to-back,
3360 # coro crashes during coro_state_free->destroy here. 3567 # coro crashes during coro_state_free->destroy here.
3361 3568
3362 $RELOAD_WATCHER ||= Event->timer ( 3569 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3363 reentrant => 0,
3364 after => 0,
3365 data => WF_AUTOCANCEL,
3366 cb => sub {
3367 do_reload_perl;
3368 undef $RELOAD_WATCHER; 3570 undef $RELOAD_WATCHER;
3369 }, 3571 do_reload_perl;
3370 ); 3572 };
3371} 3573}
3372 3574
3373register_command "reload" => sub { 3575register_command "reload" => sub {
3374 my ($who, $arg) = @_; 3576 my ($who, $arg) = @_;
3375 3577
3376 if ($who->flag (FLAG_WIZ)) { 3578 if ($who->flag (FLAG_WIZ)) {
3377 $who->message ("reloading server."); 3579 $who->message ("reloading server.");
3580 async {
3581 $Coro::current->{desc} = "perl_reload";
3378 async { reload_perl }; 3582 reload_perl;
3583 };
3379 } 3584 }
3380}; 3585};
3381 3586
3382unshift @INC, $LIBDIR; 3587unshift @INC, $LIBDIR;
3383 3588
… …
3402 my $signal = new Coro::Signal; 3607 my $signal = new Coro::Signal;
3403 push @WAIT_FOR_TICK_BEGIN, $signal; 3608 push @WAIT_FOR_TICK_BEGIN, $signal;
3404 $signal->wait; 3609 $signal->wait;
3405} 3610}
3406 3611
3407 my $min = 1e6;#d# 3612$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
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) { 3613 if ($Coro::current != $Coro::main) {
3417 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3614 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3418 unless ++$bug_warning > 10; 3615 unless ++$bug_warning > 10;
3419 return; 3616 return;
3420 } 3617 }
3421 3618
3422 $NOW = $tick_start = Event::time; 3619 $NOW = $tick_start = EV::now;
3423 3620
3424 cf::server_tick; # one server iteration 3621 cf::server_tick; # one server iteration
3425 3622
3426 0 && sync_job {#d# 3623 $RUNTIME += $TICK;
3427 for(1..10) { 3624 $NEXT_TICK = $_[0]->at;
3428 my $t = Event::time;
3429 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3430 or die;
3431 3625
3432 $map->width (50); 3626 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3433 $map->height (50); 3627 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3434 $map->alloc; 3628 Coro::async_pool {
3435 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work 3629 $Coro::current->{desc} = "runtime saver";
3436 my $t = Event::time - $t; 3630 write_runtime
3437 3631 or warn "ERROR: unable to write runtime file: $!";
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 }; 3632 };
3633 }
3448 3634
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) { 3635 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3464 $sig->send; 3636 $sig->send;
3465 } 3637 }
3466 while (my $sig = shift @WAIT_FOR_TICK) { 3638 while (my $sig = shift @WAIT_FOR_TICK) {
3467 $sig->send; 3639 $sig->send;
3468 } 3640 }
3469 3641
3470 $NOW = Event::time;
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; 3642 $LOAD = ($NOW - $tick_start) / $TICK;
3479 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3643 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3480 3644
3481 _post_tick; 3645 _post_tick;
3482 3646};
3483 3647$TICK_WATCHER->priority (EV::MAXPRI);
3484 },
3485);
3486 3648
3487{ 3649{
3488 BDB::max_poll_time $TICK * 0.1; 3650 # configure BDB
3489 $BDB_POLL_WATCHER = Event->io ( 3651
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; 3652 BDB::min_parallel 8;
3498 3653 BDB::max_poll_reqs $TICK * 0.1;
3499 BDB::set_sync_prepare { 3654 $Coro::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 3655
3514 unless ($DB_ENV) { 3656 unless ($DB_ENV) {
3515 $DB_ENV = BDB::db_env_create; 3657 $DB_ENV = BDB::db_env_create;
3658 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3659 | BDB::LOG_AUTOREMOVE, 1);
3660 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3661 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3516 3662
3517 cf::sync_job { 3663 cf::sync_job {
3518 eval { 3664 eval {
3519 BDB::db_env_open 3665 BDB::db_env_open
3520 $DB_ENV, 3666 $DB_ENV,
… …
3522 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3668 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3523 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3669 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3524 0666; 3670 0666;
3525 3671
3526 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3672 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 }; 3673 };
3531 3674
3532 cf::cleanup "db_env_open(db): $@" if $@; 3675 cf::cleanup "db_env_open(db): $@" if $@;
3533 }; 3676 };
3534 } 3677 }
3678
3679 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3680 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3681 };
3682 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3683 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3684 };
3685 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3686 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3687 };
3535} 3688}
3536 3689
3537{ 3690{
3691 # configure IO::AIO
3692
3538 IO::AIO::min_parallel 8; 3693 IO::AIO::min_parallel 8;
3539
3540 undef $Coro::AIO::WATCHER;
3541 IO::AIO::max_poll_time $TICK * 0.1; 3694 IO::AIO::max_poll_time $TICK * 0.1;
3542 $AIO_POLL_WATCHER = Event->io ( 3695 $Coro::AIO::WATCHER->priority (1);
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} 3696}
3551 3697
3552my $_log_backtrace; 3698my $_log_backtrace;
3553 3699
3554sub _log_backtrace { 3700sub _log_backtrace {
… …
3558 3704
3559 # limit the # of concurrent backtraces 3705 # limit the # of concurrent backtraces
3560 if ($_log_backtrace < 2) { 3706 if ($_log_backtrace < 2) {
3561 ++$_log_backtrace; 3707 ++$_log_backtrace;
3562 async { 3708 async {
3709 $Coro::current->{desc} = "abt $msg";
3710
3563 my @bt = fork_call { 3711 my @bt = fork_call {
3564 @addr = map { sprintf "%x", $_ } @addr; 3712 @addr = map { sprintf "%x", $_ } @addr;
3565 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3713 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3566 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3714 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3567 or die "addr2line: $!"; 3715 or die "addr2line: $!";

Diff Legend

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