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.358 by root, Fri Sep 7 18:10:52 2007 UTC vs.
Revision 1.408 by root, Mon Jan 14 10:12:12 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 ();
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
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
47 43
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 44$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49 45
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 46sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 47
… …
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 66our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 68our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 69our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 70our $BDBDIR = "$LOCALDIR/db";
71our %RESOURCE;
75 72
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 73our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77our $TICK_WATCHER; 74our $TICK_WATCHER;
78our $AIO_POLL_WATCHER; 75our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 76our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 77our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 78our $USE_FSYNC = 1; # use fsync to write maps - default off
83 79
84our $BDB_POLL_WATCHER; 80our $BDB_POLL_WATCHER;
81our $BDB_DEADLOCK_WATCHER;
82our $BDB_CHECKPOINT_WATCHER;
83our $BDB_TRICKLE_WATCHER;
85our $DB_ENV; 84our $DB_ENV;
86 85
87our %CFG; 86our %CFG;
88 87
89our $UPTIME; $UPTIME ||= time; 88our $UPTIME; $UPTIME ||= time;
90our $RUNTIME; 89our $RUNTIME;
90our $NOW;
91 91
92our (%PLAYER, %PLAYER_LOADING); # all users 92our (%PLAYER, %PLAYER_LOADING); # all users
93our (%MAP, %MAP_LOADING ); # all maps 93our (%MAP, %MAP_LOADING ); # all maps
94our $LINK_MAP; # the special {link} map, which is always available 94our $LINK_MAP; # the special {link} map, which is always available
95 95
… …
159 159
160The raw value load value from the last tick. 160The raw value load value from the last tick.
161 161
162=item %cf::CFG 162=item %cf::CFG
163 163
164Configuration for the server, loaded from C</etc/crossfire/config>, or 164Configuration for the server, loaded from C</etc/deliantra-server/config>, or
165from wherever your confdir points to. 165from wherever your confdir points to.
166 166
167=item cf::wait_for_tick, cf::wait_for_tick_begin 167=item cf::wait_for_tick, cf::wait_for_tick_begin
168 168
169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
… …
187 $msg .= "\n" 187 $msg .= "\n"
188 unless $msg =~ /\n$/; 188 unless $msg =~ /\n$/;
189 189
190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191 191
192 utf8::encode $msg;
193 LOG llevError, $msg; 192 LOG llevError, $msg;
194 }; 193 };
195} 194}
195
196$Coro::State::DIEHOOK = sub {
197 warn Carp::longmess $_[0];
198 Coro::terminate;
199};
196 200
197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 201@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 202@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 203@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 204@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
213)) { 217)) {
214 no strict 'refs'; 218 no strict 'refs';
215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 219 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
216} 220}
217 221
218$Event::DIED = sub { 222$EV::DIED = sub {
219 warn "error in event callback: @_"; 223 warn "error in event callback: @_";
220}; 224};
221 225
222############################################################################# 226#############################################################################
223 227
… …
246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 250 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
247 $d 251 $d
248 } || "[unable to dump $_[0]: '$@']"; 252 } || "[unable to dump $_[0]: '$@']";
249} 253}
250 254
251=item $ref = cf::from_json $json 255=item $ref = cf::decode_json $json
252 256
253Converts a JSON string into the corresponding perl data structure. 257Converts a JSON string into the corresponding perl data structure.
254 258
255=item $json = cf::to_json $ref 259=item $json = cf::encode_json $ref
256 260
257Converts a perl data structure into its JSON representation. 261Converts a perl data structure into its JSON representation.
258 262
259=cut 263=cut
260 264
261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 265our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
262 266
263sub to_json ($) { $json_coder->encode ($_[0]) } 267sub encode_json($) { $json_coder->encode ($_[0]) }
264sub from_json ($) { $json_coder->decode ($_[0]) } 268sub decode_json($) { $json_coder->decode ($_[0]) }
265 269
266=item cf::lock_wait $string 270=item cf::lock_wait $string
267 271
268Wait until the given lock is available. See cf::lock_acquire. 272Wait until the given lock is available. See cf::lock_acquire.
269 273
… …
334 }; 338 };
335 $TICK_WATCHER->stop; 339 $TICK_WATCHER->stop;
336 $guard 340 $guard
337} 341}
338 342
343=item cf::periodic $interval, $cb
344
345Like EV::periodic, but randomly selects a starting point so that the actions
346get spread over timer.
347
348=cut
349
350sub periodic($$) {
351 my ($interval, $cb) = @_;
352
353 my $start = rand List::Util::min 180, $interval;
354
355 EV::periodic $start, $interval, 0, $cb
356}
357
339=item cf::get_slot $time[, $priority[, $name]] 358=item cf::get_slot $time[, $priority[, $name]]
340 359
341Allocate $time seconds of blocking CPU time at priority C<$priority>: 360Allocate $time seconds of blocking CPU time at priority C<$priority>:
342This call blocks and returns only when you have at least C<$time> seconds 361This call blocks and returns only when you have at least C<$time> seconds
343of cpu time till the next tick. The slot is only valid till the next cede. 362of cpu time till the next tick. The slot is only valid till the next cede.
… …
352our @SLOT_QUEUE; 371our @SLOT_QUEUE;
353our $SLOT_QUEUE; 372our $SLOT_QUEUE;
354 373
355$SLOT_QUEUE->cancel if $SLOT_QUEUE; 374$SLOT_QUEUE->cancel if $SLOT_QUEUE;
356$SLOT_QUEUE = Coro::async { 375$SLOT_QUEUE = Coro::async {
376 $Coro::current->desc ("timeslot manager");
377
357 my $signal = new Coro::Signal; 378 my $signal = new Coro::Signal;
358 379
359 while () { 380 while () {
360 next_job: 381 next_job:
361 my $avail = cf::till_tick; 382 my $avail = cf::till_tick;
… …
369 } 390 }
370 } 391 }
371 } 392 }
372 393
373 if (@SLOT_QUEUE) { 394 if (@SLOT_QUEUE) {
374 # we do not use wait_For_tick() as it returns immediately when tick is inactive 395 # we do not use wait_for_tick() as it returns immediately when tick is inactive
375 push @cf::WAIT_FOR_TICK, $signal; 396 push @cf::WAIT_FOR_TICK, $signal;
376 $signal->wait; 397 $signal->wait;
377 } else { 398 } else {
378 Coro::schedule; 399 Coro::schedule;
379 } 400 }
… …
402 423
403BEGIN { *async = \&Coro::async_pool } 424BEGIN { *async = \&Coro::async_pool }
404 425
405=item cf::sync_job { BLOCK } 426=item cf::sync_job { BLOCK }
406 427
407The design of Crossfire TRT requires that the main coroutine ($Coro::main) 428The design of Deliantra requires that the main coroutine ($Coro::main)
408is always able to handle events or runnable, as Crossfire TRT is only 429is always able to handle events or runnable, as Deliantra is only
409partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 430partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
410acceptable. 431acceptable.
411 432
412If it must be done, put the blocking parts into C<sync_job>. This will run 433If it must be done, put the blocking parts into C<sync_job>. This will run
413the given BLOCK in another coroutine while waiting for the result. The 434the given BLOCK in another coroutine while waiting for the result. The
… …
418 439
419sub sync_job(&) { 440sub sync_job(&) {
420 my ($job) = @_; 441 my ($job) = @_;
421 442
422 if ($Coro::current == $Coro::main) { 443 if ($Coro::current == $Coro::main) {
423 my $time = Event::time; 444 my $time = EV::time;
424 445
425 # this is the main coro, too bad, we have to block 446 # this is the main coro, too bad, we have to block
426 # till the operation succeeds, freezing the server :/ 447 # till the operation succeeds, freezing the server :/
427 448
449 LOG llevError, Carp::longmess "sync job";#d#
450
428 # TODO: use suspend/resume instead 451 # TODO: use suspend/resume instead
429 # (but this is cancel-safe) 452 # (but this is cancel-safe)
430 my $freeze_guard = freeze_mainloop; 453 my $freeze_guard = freeze_mainloop;
431 454
432 my $busy = 1; 455 my $busy = 1;
433 my @res; 456 my @res;
434 457
435 (async { 458 (async {
459 $Coro::current->desc ("sync job coro");
436 @res = eval { $job->() }; 460 @res = eval { $job->() };
437 warn $@ if $@; 461 warn $@ if $@;
438 undef $busy; 462 undef $busy;
439 })->prio (Coro::PRIO_MAX); 463 })->prio (Coro::PRIO_MAX);
440 464
441 while ($busy) { 465 while ($busy) {
442 Coro::cede or Event::one_event; 466 if (Coro::nready) {
467 Coro::cede_notself;
468 } else {
469 EV::loop EV::LOOP_ONESHOT;
443 } 470 }
471 }
444 472
445 $time = Event::time - $time; 473 $time = EV::time - $time;
446 474
447 LOG llevError | logBacktrace, Carp::longmess "long sync job" 475 LOG llevError | logBacktrace, Carp::longmess "long sync job"
448 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active; 476 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
449 477
450 $tick_start += $time; # do not account sync jobs to server load 478 $tick_start += $time; # do not account sync jobs to server load
… …
480=item fork_call { }, $args 508=item fork_call { }, $args
481 509
482Executes the given code block with the given arguments in a seperate 510Executes the given code block with the given arguments in a seperate
483process, returning the results. Everything must be serialisable with 511process, returning the results. Everything must be serialisable with
484Coro::Storable. May, of course, block. Note that the executed sub may 512Coro::Storable. May, of course, block. Note that the executed sub may
485never block itself or use any form of Event handling. 513never block itself or use any form of event handling.
486 514
487=cut 515=cut
488 516
489sub fork_call(&@) { 517sub fork_call(&@) {
490 my ($cb, @args) = @_; 518 my ($cb, @args) = @_;
… …
508=item cf::db_put $family => $key => $value 536=item cf::db_put $family => $key => $value
509 537
510Stores the given C<$value> in the family. It can currently store binary 538Stores the given C<$value> in the family. It can currently store binary
511data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 539data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
512 540
541=item $db = cf::db_table "name"
542
543Create and/or open a new database table. The string must not be "db" and must be unique
544within each server.
545
513=cut 546=cut
547
548sub db_table($) {
549 my ($name) = @_;
550 my $db = BDB::db_create $DB_ENV;
551
552 eval {
553 $db->set_flags (BDB::CHKSUM);
554
555 utf8::encode $name;
556 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
557 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
558 cf::cleanup "db_open(db): $!" if $!;
559 };
560 cf::cleanup "db_open(db): $@" if $@;
561
562 $db
563}
514 564
515our $DB; 565our $DB;
516 566
517sub db_init { 567sub db_init {
518 unless ($DB) {
519 $DB = BDB::db_create $DB_ENV;
520
521 cf::sync_job { 568 cf::sync_job {
522 eval { 569 $DB ||= db_table "db";
523 $DB->set_flags (BDB::CHKSUM);
524
525 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
526 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
527 cf::cleanup "db_open(db): $!" if $!;
528 };
529 cf::cleanup "db_open(db): $@" if $@;
530 };
531 } 570 };
532} 571}
533 572
534sub db_get($$) { 573sub db_get($$) {
535 my $key = "$_[0]/$_[1]"; 574 my $key = "$_[0]/$_[1]";
536 575
… …
640attach callbacks/event handlers (a collection of which is called an "attachment") 679attach callbacks/event handlers (a collection of which is called an "attachment")
641to it. All such attachable objects support the following methods. 680to it. All such attachable objects support the following methods.
642 681
643In the following description, CLASS can be any of C<global>, C<object> 682In the following description, CLASS can be any of C<global>, C<object>
644C<player>, C<client> or C<map> (i.e. the attachable objects in 683C<player>, C<client> or C<map> (i.e. the attachable objects in
645Crossfire TRT). 684Deliantra).
646 685
647=over 4 686=over 4
648 687
649=item $attachable->attach ($attachment, key => $value...) 688=item $attachable->attach ($attachment, key => $value...)
650 689
… …
932 } 971 }
933 972
934 0 973 0
935} 974}
936 975
937=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 976=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
938 977
939=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 978=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
940 979
941Generate an object-specific event with the given arguments. 980Generate an object-specific event with the given arguments.
942 981
… …
948 987
949=cut 988=cut
950 989
951############################################################################# 990#############################################################################
952# object support 991# object support
953#
954 992
993sub _object_equal($$);
994sub _object_equal($$) {
995 my ($a, $b) = @_;
996
997 return 0 unless (ref $a) eq (ref $b);
998
999 if ("HASH" eq ref $a) {
1000 my @ka = keys %$a;
1001 my @kb = keys %$b;
1002
1003 return 0 if @ka != @kb;
1004
1005 for (0 .. $#ka) {
1006 return 0 unless $ka[$_] eq $kb[$_];
1007 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1008 }
1009
1010 } elsif ("ARRAY" eq ref $a) {
1011
1012 return 0 if @$a != @$b;
1013
1014 for (0 .. $#$a) {
1015 return 0 unless _object_equal $a->[$_], $b->[$_];
1016 }
1017
1018 } elsif ($a ne $b) {
1019 return 0;
1020 }
1021
1022 1
1023}
1024
1025our $SLOW_MERGES;#d#
955sub _can_merge { 1026sub _can_merge {
956 my ($ob1, $ob2) = @_; 1027 my ($ob1, $ob2) = @_;
957 1028
958 local $Storable::canonical = 1; 1029 ++$SLOW_MERGES;#d#
959 my $fob1 = Storable::freeze $ob1;
960 my $fob2 = Storable::freeze $ob2;
961 1030
962 $fob1 eq $fob2 1031 # we do the slow way here
1032 return _object_equal $ob1, $ob2
963} 1033}
964 1034
965sub reattach { 1035sub reattach {
966 # basically do the same as instantiate, without calling instantiate 1036 # basically do the same as instantiate, without calling instantiate
967 my ($obj) = @_; 1037 my ($obj) = @_;
… …
989cf::attachable->attach ( 1059cf::attachable->attach (
990 prio => -1000000, 1060 prio => -1000000,
991 on_instantiate => sub { 1061 on_instantiate => sub {
992 my ($obj, $data) = @_; 1062 my ($obj, $data) = @_;
993 1063
994 $data = from_json $data; 1064 $data = decode_json $data;
995 1065
996 for (@$data) { 1066 for (@$data) {
997 my ($name, $args) = @$_; 1067 my ($name, $args) = @$_;
998 1068
999 $obj->attach ($name, %{$args || {} }); 1069 $obj->attach ($name, %{$args || {} });
… …
1013); 1083);
1014 1084
1015sub object_freezer_save { 1085sub object_freezer_save {
1016 my ($filename, $rdata, $objs) = @_; 1086 my ($filename, $rdata, $objs) = @_;
1017 1087
1018 my $guard = cf::lock_acquire "io";
1019
1020 sync_job { 1088 sync_job {
1021 if (length $$rdata) { 1089 if (length $$rdata) {
1090 utf8::decode (my $decname = $filename);
1022 warn sprintf "saving %s (%d,%d)\n", 1091 warn sprintf "saving %s (%d,%d)\n",
1023 $filename, length $$rdata, scalar @$objs; 1092 $decname, length $$rdata, scalar @$objs;
1024 1093
1025 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1094 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1026 chmod SAVE_MODE, $fh; 1095 chmod SAVE_MODE, $fh;
1027 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1096 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1028 aio_fsync $fh if $cf::USE_FSYNC; 1097 aio_fsync $fh if $cf::USE_FSYNC;
1029 close $fh; 1098 close $fh;
1030 1099
1031 if (@$objs) { 1100 if (@$objs) {
1032 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1101 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1033 chmod SAVE_MODE, $fh; 1102 chmod SAVE_MODE, $fh;
1034 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1103 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1035 aio_write $fh, 0, (length $data), $data, 0; 1104 aio_write $fh, 0, (length $data), $data, 0;
1036 aio_fsync $fh if $cf::USE_FSYNC; 1105 aio_fsync $fh if $cf::USE_FSYNC;
1037 close $fh; 1106 close $fh;
1038 aio_rename "$filename.pst~", "$filename.pst"; 1107 aio_rename "$filename.pst~", "$filename.pst";
1039 } 1108 }
… …
1048 } else { 1117 } else {
1049 aio_unlink $filename; 1118 aio_unlink $filename;
1050 aio_unlink "$filename.pst"; 1119 aio_unlink "$filename.pst";
1051 } 1120 }
1052 }; 1121 };
1053
1054 undef $guard;
1055} 1122}
1056 1123
1057sub object_freezer_as_string { 1124sub object_freezer_as_string {
1058 my ($rdata, $objs) = @_; 1125 my ($rdata, $objs) = @_;
1059 1126
… …
1064 1131
1065sub object_thawer_load { 1132sub object_thawer_load {
1066 my ($filename) = @_; 1133 my ($filename) = @_;
1067 1134
1068 my ($data, $av); 1135 my ($data, $av);
1069
1070 my $guard = cf::lock_acquire "io";
1071 1136
1072 (aio_load $filename, $data) >= 0 1137 (aio_load $filename, $data) >= 0
1073 or return; 1138 or return;
1074 1139
1075 unless (aio_stat "$filename.pst") { 1140 unless (aio_stat "$filename.pst") {
1076 (aio_load "$filename.pst", $av) >= 0 1141 (aio_load "$filename.pst", $av) >= 0
1077 or return; 1142 or return;
1078 1143
1079 undef $guard;
1080 $av = eval { (Storable::thaw $av)->{objs} }; 1144 my $st = eval { Coro::Storable::thaw $av };
1145 $av = $st->{objs};
1081 } 1146 }
1082 1147
1148 utf8::decode (my $decname = $filename);
1083 warn sprintf "loading %s (%d)\n", 1149 warn sprintf "loading %s (%d,%d)\n",
1084 $filename, length $data, scalar @{$av || []}; 1150 $decname, length $data, scalar @{$av || []};
1085 1151
1086 ($data, $av) 1152 ($data, $av)
1087} 1153}
1088 1154
1089=head2 COMMAND CALLBACKS 1155=head2 COMMAND CALLBACKS
… …
1277 1343
1278=head3 cf::player 1344=head3 cf::player
1279 1345
1280=over 4 1346=over 4
1281 1347
1348=item cf::player::num_playing
1349
1350Returns the official number of playing players, as per the Crossfire metaserver rules.
1351
1352=cut
1353
1354sub num_playing {
1355 scalar grep
1356 $_->ob->map
1357 && !$_->hidden
1358 && !$_->ob->flag (cf::FLAG_WIZ),
1359 cf::player::list
1360}
1361
1282=item cf::player::find $login 1362=item cf::player::find $login
1283 1363
1284Returns the given player object, loading it if necessary (might block). 1364Returns the given player object, loading it if necessary (might block).
1285 1365
1286=cut 1366=cut
… …
1324 aio_unlink +(playerdir $login) . "/$login.pl"; 1404 aio_unlink +(playerdir $login) . "/$login.pl";
1325 1405
1326 my $f = new_from_file cf::object::thawer path $login 1406 my $f = new_from_file cf::object::thawer path $login
1327 or return; 1407 or return;
1328 1408
1329 $f->next;
1330 my $pl = cf::player::load_pl $f 1409 my $pl = cf::player::load_pl $f
1331 or return; 1410 or return;
1332 local $cf::PLAYER_LOADING{$login} = $pl; 1411 local $cf::PLAYER_LOADING{$login} = $pl;
1333 $f->resolve_delayed_derefs; 1412 $f->resolve_delayed_derefs;
1334 $cf::PLAYER{$login} = $pl 1413 $cf::PLAYER{$login} = $pl
… …
1486 1565
1487Expand crossfire pod fragments into protocol xml. 1566Expand crossfire pod fragments into protocol xml.
1488 1567
1489=cut 1568=cut
1490 1569
1570use re 'eval';
1571
1572my $group;
1573my $interior; $interior = qr{
1574 # match a pod interior sequence sans C<< >>
1575 (?:
1576 \ (.*?)\ (?{ $group = $^N })
1577 | < (??{$interior}) >
1578 )
1579}x;
1580
1491sub expand_cfpod { 1581sub expand_cfpod {
1492 ((my $self), (local $_)) = @_; 1582 my ($self, $pod) = @_;
1493 1583
1494 # escape & and < 1584 my $xml;
1495 s/&/&amp;/g;
1496 s/(?<![BIUGHT])</&lt;/g;
1497 1585
1498 # this is buggy, it needs to properly take care of nested <'s 1586 while () {
1587 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1588 $group = $1;
1499 1589
1500 1 while 1590 $group =~ s/&/&amp;/g;
1501 # replace B<>, I<>, U<> etc. 1591 $group =~ s/</&lt;/g;
1502 s/B<([^\>]*)>/<b>$1<\/b>/ 1592
1503 || s/I<([^\>]*)>/<i>$1<\/i>/ 1593 $xml .= $group;
1504 || s/U<([^\>]*)>/<u>$1<\/u>/ 1594 } elsif ($pod =~ m%\G
1505 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/ 1595 ([BCGHITU])
1506 # replace G<male|female> tags 1596 <
1507 || s{G<([^>|]*)\|([^>]*)>}{ 1597 (?:
1508 $self->gender ? $2 : $1 1598 ([^<>]*) (?{ $group = $^N })
1509 }ge 1599 | < $interior >
1510 # replace H<hint text> 1600 )
1511 || s{H<([^\>]*)>} 1601 >
1602 %gcsx
1512 { 1603 ) {
1604 my ($code, $data) = ($1, $group);
1605
1606 if ($code eq "B") {
1607 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1608 } elsif ($code eq "I") {
1609 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1610 } elsif ($code eq "U") {
1611 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1612 } elsif ($code eq "C") {
1613 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1614 } elsif ($code eq "T") {
1615 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1616 } elsif ($code eq "G") {
1617 my ($male, $female) = split /\|/, $data;
1618 $data = $self->gender ? $female : $male;
1619 $xml .= expand_cfpod ($self, $data);
1620 } elsif ($code eq "H") {
1513 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1621 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1514 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1622 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1515 "") 1623 "")
1516 [$self->{hintmode}] 1624 [$self->{hintmode}];
1625 } else {
1626 $xml .= "error processing '$code($data)' directive";
1517 }ge; 1627 }
1628 } else {
1629 if ($pod =~ /\G(.+)/) {
1630 warn "parse error while expanding $pod (at $1)";
1631 }
1632 last;
1633 }
1634 }
1518 1635
1636 for ($xml) {
1519 # create single paragraphs (very hackish) 1637 # create single paragraphs (very hackish)
1520 s/(?<=\S)\n(?=\w)/ /g; 1638 s/(?<=\S)\n(?=\w)/ /g;
1521 1639
1522 # compress some whitespace 1640 # compress some whitespace
1523 s/\s+\n/\n/g; # ws line-ends 1641 s/\s+\n/\n/g; # ws line-ends
1524 s/\n\n+/\n/g; # double lines 1642 s/\n\n+/\n/g; # double lines
1525 s/^\n+//; # beginning lines 1643 s/^\n+//; # beginning lines
1526 s/\n+$//; # ending lines 1644 s/\n+$//; # ending lines
1645 }
1527 1646
1528 $_ 1647 $xml
1529} 1648}
1649
1650no re 'eval';
1530 1651
1531sub hintmode { 1652sub hintmode {
1532 $_[0]{hintmode} = $_[1] if @_ > 1; 1653 $_[0]{hintmode} = $_[1] if @_ > 1;
1533 $_[0]{hintmode} 1654 $_[0]{hintmode}
1534} 1655}
… …
1891 2012
1892 { 2013 {
1893 my $guard = cf::lock_acquire "map_data:$path"; 2014 my $guard = cf::lock_acquire "map_data:$path";
1894 2015
1895 return unless $self->valid; 2016 return unless $self->valid;
1896 return if $self->in_memory != cf::MAP_SWAPPED; 2017 return unless $self->in_memory == cf::MAP_SWAPPED;
1897 2018
1898 $self->in_memory (cf::MAP_LOADING); 2019 $self->in_memory (cf::MAP_LOADING);
1899 2020
1900 $self->alloc; 2021 $self->alloc;
1901 2022
… …
2015 } 2136 }
2016 2137
2017 $MAP_PREFETCH{$path} |= $load; 2138 $MAP_PREFETCH{$path} |= $load;
2018 2139
2019 $MAP_PREFETCHER ||= cf::async { 2140 $MAP_PREFETCHER ||= cf::async {
2141 $Coro::current->{desc} = "map prefetcher";
2142
2020 while (%MAP_PREFETCH) { 2143 while (%MAP_PREFETCH) {
2021 while (my ($k, $v) = each %MAP_PREFETCH) { 2144 while (my ($k, $v) = each %MAP_PREFETCH) {
2022 if (my $map = find $k) { 2145 if (my $map = find $k) {
2023 $map->load if $v; 2146 $map->load if $v;
2024 } 2147 }
… …
2050 return if $self->{deny_save}; 2173 return if $self->{deny_save};
2051 2174
2052 local $self->{last_access} = $self->last_access;#d# 2175 local $self->{last_access} = $self->last_access;#d#
2053 2176
2054 cf::async { 2177 cf::async {
2178 $Coro::current->{desc} = "map player save";
2055 $_->contr->save for $self->players; 2179 $_->contr->save for $self->players;
2056 }; 2180 };
2057 2181
2058 if ($uniq) { 2182 if ($uniq) {
2059 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2183 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
2073 2197
2074 return if $self->players; 2198 return if $self->players;
2075 return if $self->in_memory != cf::MAP_IN_MEMORY; 2199 return if $self->in_memory != cf::MAP_IN_MEMORY;
2076 return if $self->{deny_save}; 2200 return if $self->{deny_save};
2077 2201
2202 $self->in_memory (cf::MAP_SWAPPED);
2203
2078 $self->deactivate; 2204 $self->deactivate;
2205 $_->clear_links_to ($self) for values %cf::MAP;
2079 $self->clear; 2206 $self->clear;
2080 $self->in_memory (cf::MAP_SWAPPED);
2081} 2207}
2082 2208
2083sub reset_at { 2209sub reset_at {
2084 my ($self) = @_; 2210 my ($self) = @_;
2085 2211
… …
2118 } 2244 }
2119 2245
2120 delete $cf::MAP{$self->path}; 2246 delete $cf::MAP{$self->path};
2121 2247
2122 $self->deactivate; 2248 $self->deactivate;
2249 $_->clear_links_to ($self) for values %cf::MAP;
2123 $self->clear; 2250 $self->clear;
2124
2125 $_->clear_links_to ($self) for values %cf::MAP;
2126 2251
2127 $self->unlink_save; 2252 $self->unlink_save;
2128 $self->destroy; 2253 $self->destroy;
2129} 2254}
2130 2255
… …
2245=cut 2370=cut
2246 2371
2247sub deref { 2372sub deref {
2248 my ($ref) = @_; 2373 my ($ref) = @_;
2249 2374
2250 # temporary compatibility#TODO#remove
2251 $ref =~ s{^<}{player/<};
2252
2253 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) { 2375 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2254 my ($uuid, $name) = ($1, $2); 2376 my ($uuid, $name) = ($1, $2);
2255 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name 2377 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2256 or return; 2378 or return;
2257 $pl->ob->uuid eq $uuid 2379 $pl->ob->uuid eq $uuid
2258 or return; 2380 or return;
… …
2429 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2551 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2430 2552
2431 $self->enter_link; 2553 $self->enter_link;
2432 2554
2433 (async { 2555 (async {
2556 $Coro::current->{desc} = "player::goto $path $x $y";
2557
2558 # *tag paths override both path and x|y
2559 if ($path =~ /^\*(.*)$/) {
2560 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2561 my $ob = $obs[rand @obs];
2562
2563 # see if we actually can go there
2564 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2565 $ob = $obs[rand @obs];
2566 } else {
2567 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2568 }
2569 # else put us there anyways for now #d#
2570
2571 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2572 } else {
2573 ($path, $x, $y) = (undef, undef, undef);
2574 }
2575 }
2576
2434 my $map = eval { 2577 my $map = eval {
2435 my $map = cf::map::find $path; 2578 my $map = defined $path ? cf::map::find $path : undef;
2436 2579
2437 if ($map) { 2580 if ($map) {
2438 $map = $map->customise_for ($self); 2581 $map = $map->customise_for ($self);
2439 $map = $check->($map) if $check && $map; 2582 $map = $check->($map) if $check && $map;
2440 } else { 2583 } else {
2441 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2584 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2442 } 2585 }
2443 2586
2444 $map 2587 $map
2445 }; 2588 };
2446 2589
… …
2499 $rmp->{origin_y} = $exit->y; 2642 $rmp->{origin_y} = $exit->y;
2500 } 2643 }
2501 2644
2502 $rmp->{random_seed} ||= $exit->random_seed; 2645 $rmp->{random_seed} ||= $exit->random_seed;
2503 2646
2504 my $data = cf::to_json $rmp; 2647 my $data = cf::encode_json $rmp;
2505 my $md5 = Digest::MD5::md5_hex $data; 2648 my $md5 = Digest::MD5::md5_hex $data;
2506 my $meta = "$RANDOMDIR/$md5.meta"; 2649 my $meta = "$RANDOMDIR/$md5.meta";
2507 2650
2508 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2651 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2509 aio_write $fh, 0, (length $data), $data, 0; 2652 aio_write $fh, 0, (length $data), $data, 0;
… …
2536 # if exit is damned, update players death & WoR home-position 2679 # if exit is damned, update players death & WoR home-position
2537 $self->contr->savebed ($slaying, $hp, $sp) 2680 $self->contr->savebed ($slaying, $hp, $sp)
2538 if $exit->flag (FLAG_DAMNED); 2681 if $exit->flag (FLAG_DAMNED);
2539 2682
2540 (async { 2683 (async {
2684 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2685
2541 $self->deactivate_recursive; # just to be sure 2686 $self->deactivate_recursive; # just to be sure
2542 unless (eval { 2687 unless (eval {
2543 $self->goto ($slaying, $hp, $sp); 2688 $self->goto ($slaying, $hp, $sp);
2544 2689
2545 1; 2690 1;
… …
2580the message, with C<log> being the default. If C<$color> is negative, suppress 2725the message, with C<log> being the default. If C<$color> is negative, suppress
2581the message unless the client supports the msg packet. 2726the message unless the client supports the msg packet.
2582 2727
2583=cut 2728=cut
2584 2729
2730# non-persistent channels (usually the info channel)
2585our %CHANNEL = ( 2731our %CHANNEL = (
2586 "c/identify" => { 2732 "c/identify" => {
2587 id => "identify", 2733 id => "infobox",
2588 title => "Identify", 2734 title => "Identify",
2589 reply => undef, 2735 reply => undef,
2590 tooltip => "Items recently identified", 2736 tooltip => "Items recently identified",
2591 }, 2737 },
2592 "c/examine" => { 2738 "c/examine" => {
2593 id => "examine", 2739 id => "infobox",
2594 title => "Examine", 2740 title => "Examine",
2595 reply => undef, 2741 reply => undef,
2596 tooltip => "Signs and other items you examined", 2742 tooltip => "Signs and other items you examined",
2597 }, 2743 },
2744 "c/book" => {
2745 id => "infobox",
2746 title => "Book",
2747 reply => undef,
2748 tooltip => "The contents of a note or book",
2749 },
2750 "c/lookat" => {
2751 id => "infobox",
2752 title => "Look",
2753 reply => undef,
2754 tooltip => "What you saw there",
2755 },
2756 "c/who" => {
2757 id => "infobox",
2758 title => "Players",
2759 reply => undef,
2760 tooltip => "Shows players who are currently online",
2761 },
2762 "c/body" => {
2763 id => "infobox",
2764 title => "Body Parts",
2765 reply => undef,
2766 tooltip => "Shows which body parts you posess and are available",
2767 },
2768 "c/uptime" => {
2769 id => "infobox",
2770 title => "Uptime",
2771 reply => undef,
2772 tooltip => "How long the server has been running since last restart",
2773 },
2774 "c/mapinfo" => {
2775 id => "infobox",
2776 title => "Map Info",
2777 reply => undef,
2778 tooltip => "Information related to the maps",
2779 },
2598); 2780);
2599 2781
2600sub cf::client::send_msg { 2782sub cf::client::send_msg {
2601 my ($self, $channel, $msg, $color, @extra) = @_; 2783 my ($self, $channel, $msg, $color, @extra) = @_;
2602 2784
2603 $msg = $self->pl->expand_cfpod ($msg); 2785 $msg = $self->pl->expand_cfpod ($msg);
2604 2786
2605 $color &= cf::NDI_CLIENT_MASK; # just in case... 2787 $color &= cf::NDI_CLIENT_MASK; # just in case...
2606 2788
2607 # check predefined channels, for the benefit of C 2789 # check predefined channels, for the benefit of C
2608 $channel = $CHANNEL{$channel} if $CHANNEL{$channel}; 2790 if ($CHANNEL{$channel}) {
2791 $channel = $CHANNEL{$channel};
2609 2792
2793 $self->ext_msg (channel_info => $channel)
2794 if $self->can_msg;
2795
2796 $channel = $channel->{id};
2797
2610 if (ref $channel) { 2798 } elsif (ref $channel) {
2611 # send meta info to client, if not yet sent 2799 # send meta info to client, if not yet sent
2612 unless (exists $self->{channel}{$channel->{id}}) { 2800 unless (exists $self->{channel}{$channel->{id}}) {
2613 $self->{channel}{$channel->{id}} = $channel; 2801 $self->{channel}{$channel->{id}} = $channel;
2614 $self->ext_msg (channel_info => $channel) 2802 $self->ext_msg (channel_info => $channel)
2615 if $self->can_msg; 2803 if $self->can_msg;
… …
2832=pod 3020=pod
2833 3021
2834The following functions and methods are available within a safe environment: 3022The following functions and methods are available within a safe environment:
2835 3023
2836 cf::object 3024 cf::object
2837 contr pay_amount pay_player map x y force_find force_add 3025 contr pay_amount pay_player map x y force_find force_add destroy
2838 insert remove name archname title slaying race decrease_ob_nr 3026 insert remove name archname title slaying race decrease_ob_nr
2839 3027
2840 cf::object::player 3028 cf::object::player
2841 player 3029 player
2842 3030
… …
2849=cut 3037=cut
2850 3038
2851for ( 3039for (
2852 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3040 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2853 insert remove inv name archname title slaying race 3041 insert remove inv name archname title slaying race
2854 decrease_ob_nr)], 3042 decrease_ob_nr destroy)],
2855 ["cf::object::player" => qw(player)], 3043 ["cf::object::player" => qw(player)],
2856 ["cf::player" => qw(peaceful)], 3044 ["cf::player" => qw(peaceful)],
2857 ["cf::map" => qw(trigger)], 3045 ["cf::map" => qw(trigger)],
2858) { 3046) {
2859 no strict 'refs'; 3047 no strict 'refs';
… …
2964 { 3152 {
2965 my $faces = $facedata->{faceinfo}; 3153 my $faces = $facedata->{faceinfo};
2966 3154
2967 while (my ($face, $info) = each %$faces) { 3155 while (my ($face, $info) = each %$faces) {
2968 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3156 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3157
2969 cf::face::set_visibility $idx, $info->{visibility}; 3158 cf::face::set_visibility $idx, $info->{visibility};
2970 cf::face::set_magicmap $idx, $info->{magicmap}; 3159 cf::face::set_magicmap $idx, $info->{magicmap};
2971 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3160 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2972 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3161 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2973 3162
2974 cf::cede_to_tick; 3163 cf::cede_to_tick;
2975 } 3164 }
2976 3165
2977 while (my ($face, $info) = each %$faces) { 3166 while (my ($face, $info) = each %$faces) {
2978 next unless $info->{smooth}; 3167 next unless $info->{smooth};
3168
2979 my $idx = cf::face::find $face 3169 my $idx = cf::face::find $face
2980 or next; 3170 or next;
3171
2981 if (my $smooth = cf::face::find $info->{smooth}) { 3172 if (my $smooth = cf::face::find $info->{smooth}) {
2982 cf::face::set_smooth $idx, $smooth; 3173 cf::face::set_smooth $idx, $smooth;
2983 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3174 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2984 } else { 3175 } else {
2985 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3176 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
3003 { 3194 {
3004 # TODO: for gcfclient pleasure, we should give resources 3195 # TODO: for gcfclient pleasure, we should give resources
3005 # that gcfclient doesn't grok a >10000 face index. 3196 # that gcfclient doesn't grok a >10000 face index.
3006 my $res = $facedata->{resource}; 3197 my $res = $facedata->{resource};
3007 3198
3008 my $soundconf = delete $res->{"res/sound.conf"};
3009
3010 while (my ($name, $info) = each %$res) { 3199 while (my ($name, $info) = each %$res) {
3200 if (defined $info->{type}) {
3011 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3201 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3012 my $data; 3202 my $data;
3013 3203
3014 if ($info->{type} & 1) { 3204 if ($info->{type} & 1) {
3015 # prepend meta info 3205 # prepend meta info
3016 3206
3017 my $meta = $enc->encode ({ 3207 my $meta = $enc->encode ({
3018 name => $name, 3208 name => $name,
3019 %{ $info->{meta} || {} }, 3209 %{ $info->{meta} || {} },
3020 }); 3210 });
3021 3211
3022 $data = pack "(w/a*)*", $meta, $info->{data}; 3212 $data = pack "(w/a*)*", $meta, $info->{data};
3213 } else {
3214 $data = $info->{data};
3215 }
3216
3217 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3218 cf::face::set_type $idx, $info->{type};
3023 } else { 3219 } else {
3024 $data = $info->{data}; 3220 $RESOURCE{$name} = $info;
3025 } 3221 }
3026 3222
3027 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3028 cf::face::set_type $idx, $info->{type};
3029
3030 cf::cede_to_tick; 3223 cf::cede_to_tick;
3031 } 3224 }
3032
3033 if ($soundconf) {
3034 $soundconf = $enc->decode (delete $soundconf->{data});
3035
3036 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3037 my $sound = $soundconf->{compat}[$_]
3038 or next;
3039
3040 my $face = cf::face::find "sound/$sound->[1]";
3041 cf::sound::set $sound->[0] => $face;
3042 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3043 }
3044
3045 while (my ($k, $v) = each %{$soundconf->{event}}) {
3046 my $face = cf::face::find "sound/$v";
3047 cf::sound::set $k => $face;
3048 }
3049 }
3050 } 3225 }
3226
3227 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3051 3228
3052 1 3229 1
3053} 3230}
3231
3232cf::global->attach (on_resource_update => sub {
3233 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3234 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3235
3236 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3237 my $sound = $soundconf->{compat}[$_]
3238 or next;
3239
3240 my $face = cf::face::find "sound/$sound->[1]";
3241 cf::sound::set $sound->[0] => $face;
3242 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3243 }
3244
3245 while (my ($k, $v) = each %{$soundconf->{event}}) {
3246 my $face = cf::face::find "sound/$v";
3247 cf::sound::set $k => $face;
3248 }
3249 }
3250});
3054 3251
3055register_exticmd fx_want => sub { 3252register_exticmd fx_want => sub {
3056 my ($ns, $want) = @_; 3253 my ($ns, $want) = @_;
3057 3254
3058 while (my ($k, $v) = each %$want) { 3255 while (my ($k, $v) = each %$want) {
… …
3113sub reload_config { 3310sub reload_config {
3114 open my $fh, "<:utf8", "$CONFDIR/config" 3311 open my $fh, "<:utf8", "$CONFDIR/config"
3115 or return; 3312 or return;
3116 3313
3117 local $/; 3314 local $/;
3118 *CFG = YAML::Syck::Load <$fh>; 3315 *CFG = YAML::Load <$fh>;
3119 3316
3120 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3317 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3121 3318
3122 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3319 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3123 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3320 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3134sub main { 3331sub main {
3135 # we must not ever block the main coroutine 3332 # we must not ever block the main coroutine
3136 local $Coro::idle = sub { 3333 local $Coro::idle = sub {
3137 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3334 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3138 (async { 3335 (async {
3139 Event::one_event; 3336 $Coro::current->{desc} = "IDLE BUG HANDLER";
3337 EV::loop EV::LOOP_ONESHOT;
3140 })->prio (Coro::PRIO_MAX); 3338 })->prio (Coro::PRIO_MAX);
3141 }; 3339 };
3142 3340
3143 reload_config; 3341 reload_config;
3144 db_init; 3342 db_init;
3145 load_extensions; 3343 load_extensions;
3146 3344
3147 $TICK_WATCHER->start; 3345 $TICK_WATCHER->start;
3346 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3148 Event::loop; 3347 EV::loop;
3149} 3348}
3150 3349
3151############################################################################# 3350#############################################################################
3152# initialisation and cleanup 3351# initialisation and cleanup
3153 3352
3154# install some emergency cleanup handlers 3353# install some emergency cleanup handlers
3155BEGIN { 3354BEGIN {
3355 our %SIGWATCHER = ();
3156 for my $signal (qw(INT HUP TERM)) { 3356 for my $signal (qw(INT HUP TERM)) {
3157 Event->signal ( 3357 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3158 reentrant => 0,
3159 data => WF_AUTOCANCEL,
3160 signal => $signal,
3161 prio => 0,
3162 cb => sub {
3163 cf::cleanup "SIG$signal"; 3358 cf::cleanup "SIG$signal";
3164 },
3165 ); 3359 };
3166 } 3360 }
3167} 3361}
3168 3362
3169sub write_runtime { 3363sub write_runtime {
3170 my $runtime = "$LOCALDIR/runtime"; 3364 my $runtime = "$LOCALDIR/runtime";
… …
3215 # and maps saved/destroyed asynchronously. 3409 # and maps saved/destroyed asynchronously.
3216 warn "begin emergency player save\n"; 3410 warn "begin emergency player save\n";
3217 for my $login (keys %cf::PLAYER) { 3411 for my $login (keys %cf::PLAYER) {
3218 my $pl = $cf::PLAYER{$login} or next; 3412 my $pl = $cf::PLAYER{$login} or next;
3219 $pl->valid or next; 3413 $pl->valid or next;
3414 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3220 $pl->save; 3415 $pl->save;
3221 } 3416 }
3222 warn "end emergency player save\n"; 3417 warn "end emergency player save\n";
3223 3418
3224 warn "begin emergency map save\n"; 3419 warn "begin emergency map save\n";
… …
3263 warn "syncing database to disk"; 3458 warn "syncing database to disk";
3264 BDB::db_env_txn_checkpoint $DB_ENV; 3459 BDB::db_env_txn_checkpoint $DB_ENV;
3265 3460
3266 # if anything goes wrong in here, we should simply crash as we already saved 3461 # if anything goes wrong in here, we should simply crash as we already saved
3267 3462
3268 warn "cancelling all WF_AUTOCANCEL watchers";
3269 for (Event::all_watchers) {
3270 $_->cancel if $_->data & WF_AUTOCANCEL;
3271 }
3272
3273 warn "flushing outstanding aio requests"; 3463 warn "flushing outstanding aio requests";
3274 for (;;) { 3464 for (;;) {
3275 BDB::flush; 3465 BDB::flush;
3276 IO::AIO::flush; 3466 IO::AIO::flush;
3277 Coro::cede; 3467 Coro::cede_notself;
3278 last unless IO::AIO::nreqs || BDB::nreqs; 3468 last unless IO::AIO::nreqs || BDB::nreqs;
3279 warn "iterate..."; 3469 warn "iterate...";
3280 } 3470 }
3281 3471
3282 ++$RELOAD; 3472 ++$RELOAD;
… …
3371 3561
3372sub reload_perl() { 3562sub reload_perl() {
3373 # doing reload synchronously and two reloads happen back-to-back, 3563 # doing reload synchronously and two reloads happen back-to-back,
3374 # coro crashes during coro_state_free->destroy here. 3564 # coro crashes during coro_state_free->destroy here.
3375 3565
3376 $RELOAD_WATCHER ||= Event->timer ( 3566 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3377 reentrant => 0,
3378 after => 0,
3379 data => WF_AUTOCANCEL,
3380 cb => sub {
3381 do_reload_perl;
3382 undef $RELOAD_WATCHER; 3567 undef $RELOAD_WATCHER;
3383 }, 3568 do_reload_perl;
3384 ); 3569 };
3385} 3570}
3386 3571
3387register_command "reload" => sub { 3572register_command "reload" => sub {
3388 my ($who, $arg) = @_; 3573 my ($who, $arg) = @_;
3389 3574
3390 if ($who->flag (FLAG_WIZ)) { 3575 if ($who->flag (FLAG_WIZ)) {
3391 $who->message ("reloading server."); 3576 $who->message ("reloading server.");
3577 async {
3578 $Coro::current->{desc} = "perl_reload";
3392 async { reload_perl }; 3579 reload_perl;
3580 };
3393 } 3581 }
3394}; 3582};
3395 3583
3396unshift @INC, $LIBDIR; 3584unshift @INC, $LIBDIR;
3397 3585
… …
3416 my $signal = new Coro::Signal; 3604 my $signal = new Coro::Signal;
3417 push @WAIT_FOR_TICK_BEGIN, $signal; 3605 push @WAIT_FOR_TICK_BEGIN, $signal;
3418 $signal->wait; 3606 $signal->wait;
3419} 3607}
3420 3608
3421 my $min = 1e6;#d# 3609$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3422 my $avg = 10;
3423$TICK_WATCHER = Event->timer (
3424 reentrant => 0,
3425 parked => 1,
3426 prio => 0,
3427 at => $NEXT_TICK || $TICK,
3428 data => WF_AUTOCANCEL,
3429 cb => sub {
3430 if ($Coro::current != $Coro::main) { 3610 if ($Coro::current != $Coro::main) {
3431 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3611 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3432 unless ++$bug_warning > 10; 3612 unless ++$bug_warning > 10;
3433 return; 3613 return;
3434 } 3614 }
3435 3615
3436 $NOW = $tick_start = Event::time; 3616 $NOW = $tick_start = EV::now;
3437 3617
3438 cf::server_tick; # one server iteration 3618 cf::server_tick; # one server iteration
3439 3619
3440 0 && sync_job {#d# 3620 $RUNTIME += $TICK;
3441 for(1..10) { 3621 $NEXT_TICK = $_[0]->at;
3442 my $t = Event::time;
3443 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3444 or die;
3445 3622
3446 $map->width (50); 3623 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3447 $map->height (50); 3624 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3448 $map->alloc; 3625 Coro::async_pool {
3449 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work 3626 $Coro::current->{desc} = "runtime saver";
3450 my $t = Event::time - $t; 3627 write_runtime
3451 3628 or warn "ERROR: unable to write runtime file: $!";
3452 #next unless $t < 0.0013;#d#
3453 if ($t < $min) {
3454 $min = $t;
3455 }
3456 $avg = $avg * 0.99 + $t * 0.01;
3457 }
3458 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3459 exit 0;
3460 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3461 }; 3629 };
3630 }
3462 3631
3463 $RUNTIME += $TICK;
3464 $NEXT_TICK += $TICK;
3465
3466 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3467 $NEXT_RUNTIME_WRITE = $NOW + 10;
3468 Coro::async_pool {
3469 write_runtime
3470 or warn "ERROR: unable to write runtime file: $!";
3471 };
3472 }
3473
3474# my $AFTER = Event::time;
3475# warn $AFTER - $NOW;#d#
3476
3477 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3632 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3478 $sig->send; 3633 $sig->send;
3479 } 3634 }
3480 while (my $sig = shift @WAIT_FOR_TICK) { 3635 while (my $sig = shift @WAIT_FOR_TICK) {
3481 $sig->send; 3636 $sig->send;
3482 } 3637 }
3483 3638
3484 $NOW = Event::time;
3485
3486 # if we are delayed by four ticks or more, skip them all
3487 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3488
3489 $TICK_WATCHER->at ($NEXT_TICK);
3490 $TICK_WATCHER->start;
3491
3492 $LOAD = ($NOW - $tick_start) / $TICK; 3639 $LOAD = ($NOW - $tick_start) / $TICK;
3493 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3640 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3494 3641
3495 _post_tick; 3642 _post_tick;
3496 3643};
3497 3644$TICK_WATCHER->priority (EV::MAXPRI);
3498 },
3499);
3500 3645
3501{ 3646{
3502 BDB::max_poll_time $TICK * 0.1; 3647 # configure BDB
3503 $BDB_POLL_WATCHER = Event->io ( 3648
3504 reentrant => 0,
3505 fd => BDB::poll_fileno,
3506 poll => 'r',
3507 prio => 0,
3508 data => WF_AUTOCANCEL,
3509 cb => \&BDB::poll_cb,
3510 );
3511 BDB::min_parallel 8; 3649 BDB::min_parallel 8;
3512 3650 BDB::max_poll_reqs $TICK * 0.1;
3513 BDB::set_sync_prepare { 3651 $Coro::BDB::WATCHER->priority (1);
3514 my $status;
3515 my $current = $Coro::current;
3516 (
3517 sub {
3518 $status = $!;
3519 $current->ready; undef $current;
3520 },
3521 sub {
3522 Coro::schedule while defined $current;
3523 $! = $status;
3524 },
3525 )
3526 };
3527 3652
3528 unless ($DB_ENV) { 3653 unless ($DB_ENV) {
3529 $DB_ENV = BDB::db_env_create; 3654 $DB_ENV = BDB::db_env_create;
3655 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3656 | BDB::LOG_AUTOREMOVE, 1);
3657 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3658 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3530 3659
3531 cf::sync_job { 3660 cf::sync_job {
3532 eval { 3661 eval {
3533 BDB::db_env_open 3662 BDB::db_env_open
3534 $DB_ENV, 3663 $DB_ENV,
… …
3536 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3665 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3537 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3666 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3538 0666; 3667 0666;
3539 3668
3540 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3669 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3541
3542 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3543 $DB_ENV->set_lk_detect;
3544 }; 3670 };
3545 3671
3546 cf::cleanup "db_env_open(db): $@" if $@; 3672 cf::cleanup "db_env_open(db): $@" if $@;
3547 }; 3673 };
3548 } 3674 }
3675
3676 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3677 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3678 };
3679 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3680 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3681 };
3682 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3683 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3684 };
3549} 3685}
3550 3686
3551{ 3687{
3688 # configure IO::AIO
3689
3552 IO::AIO::min_parallel 8; 3690 IO::AIO::min_parallel 8;
3553
3554 undef $Coro::AIO::WATCHER;
3555 IO::AIO::max_poll_time $TICK * 0.1; 3691 IO::AIO::max_poll_time $TICK * 0.1;
3556 $AIO_POLL_WATCHER = Event->io ( 3692 $Coro::AIO::WATCHER->priority (1);
3557 reentrant => 0,
3558 data => WF_AUTOCANCEL,
3559 fd => IO::AIO::poll_fileno,
3560 poll => 'r',
3561 prio => 6,
3562 cb => \&IO::AIO::poll_cb,
3563 );
3564} 3693}
3565 3694
3566my $_log_backtrace; 3695my $_log_backtrace;
3567 3696
3568sub _log_backtrace { 3697sub _log_backtrace {
… …
3572 3701
3573 # limit the # of concurrent backtraces 3702 # limit the # of concurrent backtraces
3574 if ($_log_backtrace < 2) { 3703 if ($_log_backtrace < 2) {
3575 ++$_log_backtrace; 3704 ++$_log_backtrace;
3576 async { 3705 async {
3706 $Coro::current->{desc} = "abt $msg";
3707
3577 my @bt = fork_call { 3708 my @bt = fork_call {
3578 @addr = map { sprintf "%x", $_ } @addr; 3709 @addr = map { sprintf "%x", $_ } @addr;
3579 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3710 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3580 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3711 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3581 or die "addr2line: $!"; 3712 or die "addr2line: $!";

Diff Legend

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