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.359 by root, Sat Sep 8 18:15:55 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);
… …
2246=cut 2370=cut
2247 2371
2248sub deref { 2372sub deref {
2249 my ($ref) = @_; 2373 my ($ref) = @_;
2250 2374
2251 # temporary compatibility#TODO#remove
2252 $ref =~ s{^<}{player/<};
2253
2254 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) { 2375 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2255 my ($uuid, $name) = ($1, $2); 2376 my ($uuid, $name) = ($1, $2);
2256 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name 2377 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2257 or return; 2378 or return;
2258 $pl->ob->uuid eq $uuid 2379 $pl->ob->uuid eq $uuid
2259 or return; 2380 or return;
… …
2430 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2551 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2431 2552
2432 $self->enter_link; 2553 $self->enter_link;
2433 2554
2434 (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
2435 my $map = eval { 2577 my $map = eval {
2436 my $map = cf::map::find $path; 2578 my $map = defined $path ? cf::map::find $path : undef;
2437 2579
2438 if ($map) { 2580 if ($map) {
2439 $map = $map->customise_for ($self); 2581 $map = $map->customise_for ($self);
2440 $map = $check->($map) if $check && $map; 2582 $map = $check->($map) if $check && $map;
2441 } else { 2583 } else {
2442 $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);
2443 } 2585 }
2444 2586
2445 $map 2587 $map
2446 }; 2588 };
2447 2589
… …
2500 $rmp->{origin_y} = $exit->y; 2642 $rmp->{origin_y} = $exit->y;
2501 } 2643 }
2502 2644
2503 $rmp->{random_seed} ||= $exit->random_seed; 2645 $rmp->{random_seed} ||= $exit->random_seed;
2504 2646
2505 my $data = cf::to_json $rmp; 2647 my $data = cf::encode_json $rmp;
2506 my $md5 = Digest::MD5::md5_hex $data; 2648 my $md5 = Digest::MD5::md5_hex $data;
2507 my $meta = "$RANDOMDIR/$md5.meta"; 2649 my $meta = "$RANDOMDIR/$md5.meta";
2508 2650
2509 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2651 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2510 aio_write $fh, 0, (length $data), $data, 0; 2652 aio_write $fh, 0, (length $data), $data, 0;
… …
2537 # if exit is damned, update players death & WoR home-position 2679 # if exit is damned, update players death & WoR home-position
2538 $self->contr->savebed ($slaying, $hp, $sp) 2680 $self->contr->savebed ($slaying, $hp, $sp)
2539 if $exit->flag (FLAG_DAMNED); 2681 if $exit->flag (FLAG_DAMNED);
2540 2682
2541 (async { 2683 (async {
2684 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2685
2542 $self->deactivate_recursive; # just to be sure 2686 $self->deactivate_recursive; # just to be sure
2543 unless (eval { 2687 unless (eval {
2544 $self->goto ($slaying, $hp, $sp); 2688 $self->goto ($slaying, $hp, $sp);
2545 2689
2546 1; 2690 1;
… …
2581the 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
2582the message unless the client supports the msg packet. 2726the message unless the client supports the msg packet.
2583 2727
2584=cut 2728=cut
2585 2729
2730# non-persistent channels (usually the info channel)
2586our %CHANNEL = ( 2731our %CHANNEL = (
2587 "c/identify" => { 2732 "c/identify" => {
2588 id => "identify", 2733 id => "infobox",
2589 title => "Identify", 2734 title => "Identify",
2590 reply => undef, 2735 reply => undef,
2591 tooltip => "Items recently identified", 2736 tooltip => "Items recently identified",
2592 }, 2737 },
2593 "c/examine" => { 2738 "c/examine" => {
2594 id => "examine", 2739 id => "infobox",
2595 title => "Examine", 2740 title => "Examine",
2596 reply => undef, 2741 reply => undef,
2597 tooltip => "Signs and other items you examined", 2742 tooltip => "Signs and other items you examined",
2598 }, 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 },
2599); 2780);
2600 2781
2601sub cf::client::send_msg { 2782sub cf::client::send_msg {
2602 my ($self, $channel, $msg, $color, @extra) = @_; 2783 my ($self, $channel, $msg, $color, @extra) = @_;
2603 2784
2604 $msg = $self->pl->expand_cfpod ($msg); 2785 $msg = $self->pl->expand_cfpod ($msg);
2605 2786
2606 $color &= cf::NDI_CLIENT_MASK; # just in case... 2787 $color &= cf::NDI_CLIENT_MASK; # just in case...
2607 2788
2608 # check predefined channels, for the benefit of C 2789 # check predefined channels, for the benefit of C
2609 $channel = $CHANNEL{$channel} if $CHANNEL{$channel}; 2790 if ($CHANNEL{$channel}) {
2791 $channel = $CHANNEL{$channel};
2610 2792
2793 $self->ext_msg (channel_info => $channel)
2794 if $self->can_msg;
2795
2796 $channel = $channel->{id};
2797
2611 if (ref $channel) { 2798 } elsif (ref $channel) {
2612 # send meta info to client, if not yet sent 2799 # send meta info to client, if not yet sent
2613 unless (exists $self->{channel}{$channel->{id}}) { 2800 unless (exists $self->{channel}{$channel->{id}}) {
2614 $self->{channel}{$channel->{id}} = $channel; 2801 $self->{channel}{$channel->{id}} = $channel;
2615 $self->ext_msg (channel_info => $channel) 2802 $self->ext_msg (channel_info => $channel)
2616 if $self->can_msg; 2803 if $self->can_msg;
… …
2833=pod 3020=pod
2834 3021
2835The following functions and methods are available within a safe environment: 3022The following functions and methods are available within a safe environment:
2836 3023
2837 cf::object 3024 cf::object
2838 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
2839 insert remove name archname title slaying race decrease_ob_nr 3026 insert remove name archname title slaying race decrease_ob_nr
2840 3027
2841 cf::object::player 3028 cf::object::player
2842 player 3029 player
2843 3030
… …
2850=cut 3037=cut
2851 3038
2852for ( 3039for (
2853 ["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
2854 insert remove inv name archname title slaying race 3041 insert remove inv name archname title slaying race
2855 decrease_ob_nr)], 3042 decrease_ob_nr destroy)],
2856 ["cf::object::player" => qw(player)], 3043 ["cf::object::player" => qw(player)],
2857 ["cf::player" => qw(peaceful)], 3044 ["cf::player" => qw(peaceful)],
2858 ["cf::map" => qw(trigger)], 3045 ["cf::map" => qw(trigger)],
2859) { 3046) {
2860 no strict 'refs'; 3047 no strict 'refs';
… …
2965 { 3152 {
2966 my $faces = $facedata->{faceinfo}; 3153 my $faces = $facedata->{faceinfo};
2967 3154
2968 while (my ($face, $info) = each %$faces) { 3155 while (my ($face, $info) = each %$faces) {
2969 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3156 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3157
2970 cf::face::set_visibility $idx, $info->{visibility}; 3158 cf::face::set_visibility $idx, $info->{visibility};
2971 cf::face::set_magicmap $idx, $info->{magicmap}; 3159 cf::face::set_magicmap $idx, $info->{magicmap};
2972 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};
2973 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};
2974 3162
2975 cf::cede_to_tick; 3163 cf::cede_to_tick;
2976 } 3164 }
2977 3165
2978 while (my ($face, $info) = each %$faces) { 3166 while (my ($face, $info) = each %$faces) {
2979 next unless $info->{smooth}; 3167 next unless $info->{smooth};
3168
2980 my $idx = cf::face::find $face 3169 my $idx = cf::face::find $face
2981 or next; 3170 or next;
3171
2982 if (my $smooth = cf::face::find $info->{smooth}) { 3172 if (my $smooth = cf::face::find $info->{smooth}) {
2983 cf::face::set_smooth $idx, $smooth; 3173 cf::face::set_smooth $idx, $smooth;
2984 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3174 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2985 } else { 3175 } else {
2986 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3176 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
3004 { 3194 {
3005 # TODO: for gcfclient pleasure, we should give resources 3195 # TODO: for gcfclient pleasure, we should give resources
3006 # that gcfclient doesn't grok a >10000 face index. 3196 # that gcfclient doesn't grok a >10000 face index.
3007 my $res = $facedata->{resource}; 3197 my $res = $facedata->{resource};
3008 3198
3009 my $soundconf = delete $res->{"res/sound.conf"};
3010
3011 while (my ($name, $info) = each %$res) { 3199 while (my ($name, $info) = each %$res) {
3200 if (defined $info->{type}) {
3012 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3201 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3013 my $data; 3202 my $data;
3014 3203
3015 if ($info->{type} & 1) { 3204 if ($info->{type} & 1) {
3016 # prepend meta info 3205 # prepend meta info
3017 3206
3018 my $meta = $enc->encode ({ 3207 my $meta = $enc->encode ({
3019 name => $name, 3208 name => $name,
3020 %{ $info->{meta} || {} }, 3209 %{ $info->{meta} || {} },
3021 }); 3210 });
3022 3211
3023 $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};
3024 } else { 3219 } else {
3025 $data = $info->{data}; 3220 $RESOURCE{$name} = $info;
3026 } 3221 }
3027 3222
3028 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3029 cf::face::set_type $idx, $info->{type};
3030
3031 cf::cede_to_tick; 3223 cf::cede_to_tick;
3032 } 3224 }
3033
3034 if ($soundconf) {
3035 $soundconf = $enc->decode (delete $soundconf->{data});
3036
3037 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3038 my $sound = $soundconf->{compat}[$_]
3039 or next;
3040
3041 my $face = cf::face::find "sound/$sound->[1]";
3042 cf::sound::set $sound->[0] => $face;
3043 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3044 }
3045
3046 while (my ($k, $v) = each %{$soundconf->{event}}) {
3047 my $face = cf::face::find "sound/$v";
3048 cf::sound::set $k => $face;
3049 }
3050 }
3051 } 3225 }
3226
3227 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3052 3228
3053 1 3229 1
3054} 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});
3055 3251
3056register_exticmd fx_want => sub { 3252register_exticmd fx_want => sub {
3057 my ($ns, $want) = @_; 3253 my ($ns, $want) = @_;
3058 3254
3059 while (my ($k, $v) = each %$want) { 3255 while (my ($k, $v) = each %$want) {
… …
3114sub reload_config { 3310sub reload_config {
3115 open my $fh, "<:utf8", "$CONFDIR/config" 3311 open my $fh, "<:utf8", "$CONFDIR/config"
3116 or return; 3312 or return;
3117 3313
3118 local $/; 3314 local $/;
3119 *CFG = YAML::Syck::Load <$fh>; 3315 *CFG = YAML::Load <$fh>;
3120 3316
3121 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3317 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3122 3318
3123 $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};
3124 $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};
… …
3135sub main { 3331sub main {
3136 # we must not ever block the main coroutine 3332 # we must not ever block the main coroutine
3137 local $Coro::idle = sub { 3333 local $Coro::idle = sub {
3138 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#
3139 (async { 3335 (async {
3140 Event::one_event; 3336 $Coro::current->{desc} = "IDLE BUG HANDLER";
3337 EV::loop EV::LOOP_ONESHOT;
3141 })->prio (Coro::PRIO_MAX); 3338 })->prio (Coro::PRIO_MAX);
3142 }; 3339 };
3143 3340
3144 reload_config; 3341 reload_config;
3145 db_init; 3342 db_init;
3146 load_extensions; 3343 load_extensions;
3147 3344
3148 $TICK_WATCHER->start; 3345 $TICK_WATCHER->start;
3346 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3149 Event::loop; 3347 EV::loop;
3150} 3348}
3151 3349
3152############################################################################# 3350#############################################################################
3153# initialisation and cleanup 3351# initialisation and cleanup
3154 3352
3155# install some emergency cleanup handlers 3353# install some emergency cleanup handlers
3156BEGIN { 3354BEGIN {
3355 our %SIGWATCHER = ();
3157 for my $signal (qw(INT HUP TERM)) { 3356 for my $signal (qw(INT HUP TERM)) {
3158 Event->signal ( 3357 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3159 reentrant => 0,
3160 data => WF_AUTOCANCEL,
3161 signal => $signal,
3162 prio => 0,
3163 cb => sub {
3164 cf::cleanup "SIG$signal"; 3358 cf::cleanup "SIG$signal";
3165 },
3166 ); 3359 };
3167 } 3360 }
3168} 3361}
3169 3362
3170sub write_runtime { 3363sub write_runtime {
3171 my $runtime = "$LOCALDIR/runtime"; 3364 my $runtime = "$LOCALDIR/runtime";
… …
3216 # and maps saved/destroyed asynchronously. 3409 # and maps saved/destroyed asynchronously.
3217 warn "begin emergency player save\n"; 3410 warn "begin emergency player save\n";
3218 for my $login (keys %cf::PLAYER) { 3411 for my $login (keys %cf::PLAYER) {
3219 my $pl = $cf::PLAYER{$login} or next; 3412 my $pl = $cf::PLAYER{$login} or next;
3220 $pl->valid or next; 3413 $pl->valid or next;
3414 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3221 $pl->save; 3415 $pl->save;
3222 } 3416 }
3223 warn "end emergency player save\n"; 3417 warn "end emergency player save\n";
3224 3418
3225 warn "begin emergency map save\n"; 3419 warn "begin emergency map save\n";
… …
3264 warn "syncing database to disk"; 3458 warn "syncing database to disk";
3265 BDB::db_env_txn_checkpoint $DB_ENV; 3459 BDB::db_env_txn_checkpoint $DB_ENV;
3266 3460
3267 # 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
3268 3462
3269 warn "cancelling all WF_AUTOCANCEL watchers";
3270 for (Event::all_watchers) {
3271 $_->cancel if $_->data & WF_AUTOCANCEL;
3272 }
3273
3274 warn "flushing outstanding aio requests"; 3463 warn "flushing outstanding aio requests";
3275 for (;;) { 3464 for (;;) {
3276 BDB::flush; 3465 BDB::flush;
3277 IO::AIO::flush; 3466 IO::AIO::flush;
3278 Coro::cede; 3467 Coro::cede_notself;
3279 last unless IO::AIO::nreqs || BDB::nreqs; 3468 last unless IO::AIO::nreqs || BDB::nreqs;
3280 warn "iterate..."; 3469 warn "iterate...";
3281 } 3470 }
3282 3471
3283 ++$RELOAD; 3472 ++$RELOAD;
… …
3372 3561
3373sub reload_perl() { 3562sub reload_perl() {
3374 # doing reload synchronously and two reloads happen back-to-back, 3563 # doing reload synchronously and two reloads happen back-to-back,
3375 # coro crashes during coro_state_free->destroy here. 3564 # coro crashes during coro_state_free->destroy here.
3376 3565
3377 $RELOAD_WATCHER ||= Event->timer ( 3566 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3378 reentrant => 0,
3379 after => 0,
3380 data => WF_AUTOCANCEL,
3381 cb => sub {
3382 do_reload_perl;
3383 undef $RELOAD_WATCHER; 3567 undef $RELOAD_WATCHER;
3384 }, 3568 do_reload_perl;
3385 ); 3569 };
3386} 3570}
3387 3571
3388register_command "reload" => sub { 3572register_command "reload" => sub {
3389 my ($who, $arg) = @_; 3573 my ($who, $arg) = @_;
3390 3574
3391 if ($who->flag (FLAG_WIZ)) { 3575 if ($who->flag (FLAG_WIZ)) {
3392 $who->message ("reloading server."); 3576 $who->message ("reloading server.");
3577 async {
3578 $Coro::current->{desc} = "perl_reload";
3393 async { reload_perl }; 3579 reload_perl;
3580 };
3394 } 3581 }
3395}; 3582};
3396 3583
3397unshift @INC, $LIBDIR; 3584unshift @INC, $LIBDIR;
3398 3585
… …
3417 my $signal = new Coro::Signal; 3604 my $signal = new Coro::Signal;
3418 push @WAIT_FOR_TICK_BEGIN, $signal; 3605 push @WAIT_FOR_TICK_BEGIN, $signal;
3419 $signal->wait; 3606 $signal->wait;
3420} 3607}
3421 3608
3422 my $min = 1e6;#d# 3609$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3423 my $avg = 10;
3424$TICK_WATCHER = Event->timer (
3425 reentrant => 0,
3426 parked => 1,
3427 prio => 0,
3428 at => $NEXT_TICK || $TICK,
3429 data => WF_AUTOCANCEL,
3430 cb => sub {
3431 if ($Coro::current != $Coro::main) { 3610 if ($Coro::current != $Coro::main) {
3432 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"
3433 unless ++$bug_warning > 10; 3612 unless ++$bug_warning > 10;
3434 return; 3613 return;
3435 } 3614 }
3436 3615
3437 $NOW = $tick_start = Event::time; 3616 $NOW = $tick_start = EV::now;
3438 3617
3439 cf::server_tick; # one server iteration 3618 cf::server_tick; # one server iteration
3440 3619
3441 0 && sync_job {#d# 3620 $RUNTIME += $TICK;
3442 for(1..10) { 3621 $NEXT_TICK = $_[0]->at;
3443 my $t = Event::time;
3444 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3445 or die;
3446 3622
3447 $map->width (50); 3623 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3448 $map->height (50); 3624 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3449 $map->alloc; 3625 Coro::async_pool {
3450 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work 3626 $Coro::current->{desc} = "runtime saver";
3451 my $t = Event::time - $t; 3627 write_runtime
3452 3628 or warn "ERROR: unable to write runtime file: $!";
3453 #next unless $t < 0.0013;#d#
3454 if ($t < $min) {
3455 $min = $t;
3456 }
3457 $avg = $avg * 0.99 + $t * 0.01;
3458 }
3459 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3460 exit 0;
3461 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3462 }; 3629 };
3630 }
3463 3631
3464 $RUNTIME += $TICK;
3465 $NEXT_TICK += $TICK;
3466
3467 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3468 $NEXT_RUNTIME_WRITE = $NOW + 10;
3469 Coro::async_pool {
3470 write_runtime
3471 or warn "ERROR: unable to write runtime file: $!";
3472 };
3473 }
3474
3475# my $AFTER = Event::time;
3476# warn $AFTER - $NOW;#d#
3477
3478 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3632 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3479 $sig->send; 3633 $sig->send;
3480 } 3634 }
3481 while (my $sig = shift @WAIT_FOR_TICK) { 3635 while (my $sig = shift @WAIT_FOR_TICK) {
3482 $sig->send; 3636 $sig->send;
3483 } 3637 }
3484 3638
3485 $NOW = Event::time;
3486
3487 # if we are delayed by four ticks or more, skip them all
3488 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3489
3490 $TICK_WATCHER->at ($NEXT_TICK);
3491 $TICK_WATCHER->start;
3492
3493 $LOAD = ($NOW - $tick_start) / $TICK; 3639 $LOAD = ($NOW - $tick_start) / $TICK;
3494 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3640 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3495 3641
3496 _post_tick; 3642 _post_tick;
3497 3643};
3498 3644$TICK_WATCHER->priority (EV::MAXPRI);
3499 },
3500);
3501 3645
3502{ 3646{
3503 BDB::max_poll_time $TICK * 0.1; 3647 # configure BDB
3504 $BDB_POLL_WATCHER = Event->io ( 3648
3505 reentrant => 0,
3506 fd => BDB::poll_fileno,
3507 poll => 'r',
3508 prio => 0,
3509 data => WF_AUTOCANCEL,
3510 cb => \&BDB::poll_cb,
3511 );
3512 BDB::min_parallel 8; 3649 BDB::min_parallel 8;
3513 3650 BDB::max_poll_reqs $TICK * 0.1;
3514 BDB::set_sync_prepare { 3651 $Coro::BDB::WATCHER->priority (1);
3515 my $status;
3516 my $current = $Coro::current;
3517 (
3518 sub {
3519 $status = $!;
3520 $current->ready; undef $current;
3521 },
3522 sub {
3523 Coro::schedule while defined $current;
3524 $! = $status;
3525 },
3526 )
3527 };
3528 3652
3529 unless ($DB_ENV) { 3653 unless ($DB_ENV) {
3530 $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);
3531 3659
3532 cf::sync_job { 3660 cf::sync_job {
3533 eval { 3661 eval {
3534 BDB::db_env_open 3662 BDB::db_env_open
3535 $DB_ENV, 3663 $DB_ENV,
… …
3537 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
3538 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3666 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3539 0666; 3667 0666;
3540 3668
3541 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3669 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3542
3543 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3544 $DB_ENV->set_lk_detect;
3545 }; 3670 };
3546 3671
3547 cf::cleanup "db_env_open(db): $@" if $@; 3672 cf::cleanup "db_env_open(db): $@" if $@;
3548 }; 3673 };
3549 } 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 };
3550} 3685}
3551 3686
3552{ 3687{
3688 # configure IO::AIO
3689
3553 IO::AIO::min_parallel 8; 3690 IO::AIO::min_parallel 8;
3554
3555 undef $Coro::AIO::WATCHER;
3556 IO::AIO::max_poll_time $TICK * 0.1; 3691 IO::AIO::max_poll_time $TICK * 0.1;
3557 $AIO_POLL_WATCHER = Event->io ( 3692 $Coro::AIO::WATCHER->priority (1);
3558 reentrant => 0,
3559 data => WF_AUTOCANCEL,
3560 fd => IO::AIO::poll_fileno,
3561 poll => 'r',
3562 prio => 6,
3563 cb => \&IO::AIO::poll_cb,
3564 );
3565} 3693}
3566 3694
3567my $_log_backtrace; 3695my $_log_backtrace;
3568 3696
3569sub _log_backtrace { 3697sub _log_backtrace {
… …
3573 3701
3574 # limit the # of concurrent backtraces 3702 # limit the # of concurrent backtraces
3575 if ($_log_backtrace < 2) { 3703 if ($_log_backtrace < 2) {
3576 ++$_log_backtrace; 3704 ++$_log_backtrace;
3577 async { 3705 async {
3706 $Coro::current->{desc} = "abt $msg";
3707
3578 my @bt = fork_call { 3708 my @bt = fork_call {
3579 @addr = map { sprintf "%x", $_ } @addr; 3709 @addr = map { sprintf "%x", $_ } @addr;
3580 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3710 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3581 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 |"
3582 or die "addr2line: $!"; 3712 or die "addr2line: $!";

Diff Legend

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