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.361 by root, Sun Sep 9 12:52:48 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
… …
1338 aio_unlink +(playerdir $login) . "/$login.pl"; 1404 aio_unlink +(playerdir $login) . "/$login.pl";
1339 1405
1340 my $f = new_from_file cf::object::thawer path $login 1406 my $f = new_from_file cf::object::thawer path $login
1341 or return; 1407 or return;
1342 1408
1343 $f->next;
1344 my $pl = cf::player::load_pl $f 1409 my $pl = cf::player::load_pl $f
1345 or return; 1410 or return;
1346 local $cf::PLAYER_LOADING{$login} = $pl; 1411 local $cf::PLAYER_LOADING{$login} = $pl;
1347 $f->resolve_delayed_derefs; 1412 $f->resolve_delayed_derefs;
1348 $cf::PLAYER{$login} = $pl 1413 $cf::PLAYER{$login} = $pl
… …
1500 1565
1501Expand crossfire pod fragments into protocol xml. 1566Expand crossfire pod fragments into protocol xml.
1502 1567
1503=cut 1568=cut
1504 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
1505sub expand_cfpod { 1581sub expand_cfpod {
1506 ((my $self), (local $_)) = @_; 1582 my ($self, $pod) = @_;
1507 1583
1508 # escape & and < 1584 my $xml;
1509 s/&/&amp;/g;
1510 s/(?<![BIUGHT])</&lt;/g;
1511 1585
1512 # this is buggy, it needs to properly take care of nested <'s 1586 while () {
1587 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1588 $group = $1;
1513 1589
1514 1 while 1590 $group =~ s/&/&amp;/g;
1515 # replace B<>, I<>, U<> etc. 1591 $group =~ s/</&lt;/g;
1516 s/B<([^\>]*)>/<b>$1<\/b>/ 1592
1517 || s/I<([^\>]*)>/<i>$1<\/i>/ 1593 $xml .= $group;
1518 || s/U<([^\>]*)>/<u>$1<\/u>/ 1594 } elsif ($pod =~ m%\G
1519 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/ 1595 ([BCGHITU])
1520 # replace G<male|female> tags 1596 <
1521 || s{G<([^>|]*)\|([^>]*)>}{ 1597 (?:
1522 $self->gender ? $2 : $1 1598 ([^<>]*) (?{ $group = $^N })
1523 }ge 1599 | < $interior >
1524 # replace H<hint text> 1600 )
1525 || s{H<([^\>]*)>} 1601 >
1602 %gcsx
1526 { 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") {
1527 ("<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>",
1528 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1622 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1529 "") 1623 "")
1530 [$self->{hintmode}] 1624 [$self->{hintmode}];
1625 } else {
1626 $xml .= "error processing '$code($data)' directive";
1531 }ge; 1627 }
1628 } else {
1629 if ($pod =~ /\G(.+)/) {
1630 warn "parse error while expanding $pod (at $1)";
1631 }
1632 last;
1633 }
1634 }
1532 1635
1636 for ($xml) {
1533 # create single paragraphs (very hackish) 1637 # create single paragraphs (very hackish)
1534 s/(?<=\S)\n(?=\w)/ /g; 1638 s/(?<=\S)\n(?=\w)/ /g;
1535 1639
1536 # compress some whitespace 1640 # compress some whitespace
1537 s/\s+\n/\n/g; # ws line-ends 1641 s/\s+\n/\n/g; # ws line-ends
1538 s/\n\n+/\n/g; # double lines 1642 s/\n\n+/\n/g; # double lines
1539 s/^\n+//; # beginning lines 1643 s/^\n+//; # beginning lines
1540 s/\n+$//; # ending lines 1644 s/\n+$//; # ending lines
1645 }
1541 1646
1542 $_ 1647 $xml
1543} 1648}
1649
1650no re 'eval';
1544 1651
1545sub hintmode { 1652sub hintmode {
1546 $_[0]{hintmode} = $_[1] if @_ > 1; 1653 $_[0]{hintmode} = $_[1] if @_ > 1;
1547 $_[0]{hintmode} 1654 $_[0]{hintmode}
1548} 1655}
… …
2029 } 2136 }
2030 2137
2031 $MAP_PREFETCH{$path} |= $load; 2138 $MAP_PREFETCH{$path} |= $load;
2032 2139
2033 $MAP_PREFETCHER ||= cf::async { 2140 $MAP_PREFETCHER ||= cf::async {
2141 $Coro::current->{desc} = "map prefetcher";
2142
2034 while (%MAP_PREFETCH) { 2143 while (%MAP_PREFETCH) {
2035 while (my ($k, $v) = each %MAP_PREFETCH) { 2144 while (my ($k, $v) = each %MAP_PREFETCH) {
2036 if (my $map = find $k) { 2145 if (my $map = find $k) {
2037 $map->load if $v; 2146 $map->load if $v;
2038 } 2147 }
… …
2064 return if $self->{deny_save}; 2173 return if $self->{deny_save};
2065 2174
2066 local $self->{last_access} = $self->last_access;#d# 2175 local $self->{last_access} = $self->last_access;#d#
2067 2176
2068 cf::async { 2177 cf::async {
2178 $Coro::current->{desc} = "map player save";
2069 $_->contr->save for $self->players; 2179 $_->contr->save for $self->players;
2070 }; 2180 };
2071 2181
2072 if ($uniq) { 2182 if ($uniq) {
2073 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2183 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
2260=cut 2370=cut
2261 2371
2262sub deref { 2372sub deref {
2263 my ($ref) = @_; 2373 my ($ref) = @_;
2264 2374
2265 # temporary compatibility#TODO#remove
2266 $ref =~ s{^<}{player/<};
2267
2268 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) { 2375 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2269 my ($uuid, $name) = ($1, $2); 2376 my ($uuid, $name) = ($1, $2);
2270 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name 2377 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2271 or return; 2378 or return;
2272 $pl->ob->uuid eq $uuid 2379 $pl->ob->uuid eq $uuid
2273 or return; 2380 or return;
… …
2444 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2551 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2445 2552
2446 $self->enter_link; 2553 $self->enter_link;
2447 2554
2448 (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
2449 my $map = eval { 2577 my $map = eval {
2450 my $map = cf::map::find $path; 2578 my $map = defined $path ? cf::map::find $path : undef;
2451 2579
2452 if ($map) { 2580 if ($map) {
2453 $map = $map->customise_for ($self); 2581 $map = $map->customise_for ($self);
2454 $map = $check->($map) if $check && $map; 2582 $map = $check->($map) if $check && $map;
2455 } else { 2583 } else {
2456 $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);
2457 } 2585 }
2458 2586
2459 $map 2587 $map
2460 }; 2588 };
2461 2589
… …
2514 $rmp->{origin_y} = $exit->y; 2642 $rmp->{origin_y} = $exit->y;
2515 } 2643 }
2516 2644
2517 $rmp->{random_seed} ||= $exit->random_seed; 2645 $rmp->{random_seed} ||= $exit->random_seed;
2518 2646
2519 my $data = cf::to_json $rmp; 2647 my $data = cf::encode_json $rmp;
2520 my $md5 = Digest::MD5::md5_hex $data; 2648 my $md5 = Digest::MD5::md5_hex $data;
2521 my $meta = "$RANDOMDIR/$md5.meta"; 2649 my $meta = "$RANDOMDIR/$md5.meta";
2522 2650
2523 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2651 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2524 aio_write $fh, 0, (length $data), $data, 0; 2652 aio_write $fh, 0, (length $data), $data, 0;
… …
2551 # if exit is damned, update players death & WoR home-position 2679 # if exit is damned, update players death & WoR home-position
2552 $self->contr->savebed ($slaying, $hp, $sp) 2680 $self->contr->savebed ($slaying, $hp, $sp)
2553 if $exit->flag (FLAG_DAMNED); 2681 if $exit->flag (FLAG_DAMNED);
2554 2682
2555 (async { 2683 (async {
2684 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2685
2556 $self->deactivate_recursive; # just to be sure 2686 $self->deactivate_recursive; # just to be sure
2557 unless (eval { 2687 unless (eval {
2558 $self->goto ($slaying, $hp, $sp); 2688 $self->goto ($slaying, $hp, $sp);
2559 2689
2560 1; 2690 1;
… …
2595the 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
2596the message unless the client supports the msg packet. 2726the message unless the client supports the msg packet.
2597 2727
2598=cut 2728=cut
2599 2729
2730# non-persistent channels (usually the info channel)
2600our %CHANNEL = ( 2731our %CHANNEL = (
2601 "c/identify" => { 2732 "c/identify" => {
2602 id => "identify", 2733 id => "infobox",
2603 title => "Identify", 2734 title => "Identify",
2604 reply => undef, 2735 reply => undef,
2605 tooltip => "Items recently identified", 2736 tooltip => "Items recently identified",
2606 }, 2737 },
2607 "c/examine" => { 2738 "c/examine" => {
2608 id => "examine", 2739 id => "infobox",
2609 title => "Examine", 2740 title => "Examine",
2610 reply => undef, 2741 reply => undef,
2611 tooltip => "Signs and other items you examined", 2742 tooltip => "Signs and other items you examined",
2612 }, 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 },
2613); 2780);
2614 2781
2615sub cf::client::send_msg { 2782sub cf::client::send_msg {
2616 my ($self, $channel, $msg, $color, @extra) = @_; 2783 my ($self, $channel, $msg, $color, @extra) = @_;
2617 2784
2618 $msg = $self->pl->expand_cfpod ($msg); 2785 $msg = $self->pl->expand_cfpod ($msg);
2619 2786
2620 $color &= cf::NDI_CLIENT_MASK; # just in case... 2787 $color &= cf::NDI_CLIENT_MASK; # just in case...
2621 2788
2622 # check predefined channels, for the benefit of C 2789 # check predefined channels, for the benefit of C
2623 $channel = $CHANNEL{$channel} if $CHANNEL{$channel}; 2790 if ($CHANNEL{$channel}) {
2791 $channel = $CHANNEL{$channel};
2624 2792
2793 $self->ext_msg (channel_info => $channel)
2794 if $self->can_msg;
2795
2796 $channel = $channel->{id};
2797
2625 if (ref $channel) { 2798 } elsif (ref $channel) {
2626 # send meta info to client, if not yet sent 2799 # send meta info to client, if not yet sent
2627 unless (exists $self->{channel}{$channel->{id}}) { 2800 unless (exists $self->{channel}{$channel->{id}}) {
2628 $self->{channel}{$channel->{id}} = $channel; 2801 $self->{channel}{$channel->{id}} = $channel;
2629 $self->ext_msg (channel_info => $channel) 2802 $self->ext_msg (channel_info => $channel)
2630 if $self->can_msg; 2803 if $self->can_msg;
… …
2847=pod 3020=pod
2848 3021
2849The following functions and methods are available within a safe environment: 3022The following functions and methods are available within a safe environment:
2850 3023
2851 cf::object 3024 cf::object
2852 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
2853 insert remove name archname title slaying race decrease_ob_nr 3026 insert remove name archname title slaying race decrease_ob_nr
2854 3027
2855 cf::object::player 3028 cf::object::player
2856 player 3029 player
2857 3030
… …
2864=cut 3037=cut
2865 3038
2866for ( 3039for (
2867 ["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
2868 insert remove inv name archname title slaying race 3041 insert remove inv name archname title slaying race
2869 decrease_ob_nr)], 3042 decrease_ob_nr destroy)],
2870 ["cf::object::player" => qw(player)], 3043 ["cf::object::player" => qw(player)],
2871 ["cf::player" => qw(peaceful)], 3044 ["cf::player" => qw(peaceful)],
2872 ["cf::map" => qw(trigger)], 3045 ["cf::map" => qw(trigger)],
2873) { 3046) {
2874 no strict 'refs'; 3047 no strict 'refs';
… …
2979 { 3152 {
2980 my $faces = $facedata->{faceinfo}; 3153 my $faces = $facedata->{faceinfo};
2981 3154
2982 while (my ($face, $info) = each %$faces) { 3155 while (my ($face, $info) = each %$faces) {
2983 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3156 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3157
2984 cf::face::set_visibility $idx, $info->{visibility}; 3158 cf::face::set_visibility $idx, $info->{visibility};
2985 cf::face::set_magicmap $idx, $info->{magicmap}; 3159 cf::face::set_magicmap $idx, $info->{magicmap};
2986 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};
2987 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};
2988 3162
2989 cf::cede_to_tick; 3163 cf::cede_to_tick;
2990 } 3164 }
2991 3165
2992 while (my ($face, $info) = each %$faces) { 3166 while (my ($face, $info) = each %$faces) {
2993 next unless $info->{smooth}; 3167 next unless $info->{smooth};
3168
2994 my $idx = cf::face::find $face 3169 my $idx = cf::face::find $face
2995 or next; 3170 or next;
3171
2996 if (my $smooth = cf::face::find $info->{smooth}) { 3172 if (my $smooth = cf::face::find $info->{smooth}) {
2997 cf::face::set_smooth $idx, $smooth; 3173 cf::face::set_smooth $idx, $smooth;
2998 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3174 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2999 } else { 3175 } else {
3000 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3176 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
3018 { 3194 {
3019 # TODO: for gcfclient pleasure, we should give resources 3195 # TODO: for gcfclient pleasure, we should give resources
3020 # that gcfclient doesn't grok a >10000 face index. 3196 # that gcfclient doesn't grok a >10000 face index.
3021 my $res = $facedata->{resource}; 3197 my $res = $facedata->{resource};
3022 3198
3023 my $soundconf = delete $res->{"res/sound.conf"};
3024
3025 while (my ($name, $info) = each %$res) { 3199 while (my ($name, $info) = each %$res) {
3200 if (defined $info->{type}) {
3026 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3201 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3027 my $data; 3202 my $data;
3028 3203
3029 if ($info->{type} & 1) { 3204 if ($info->{type} & 1) {
3030 # prepend meta info 3205 # prepend meta info
3031 3206
3032 my $meta = $enc->encode ({ 3207 my $meta = $enc->encode ({
3033 name => $name, 3208 name => $name,
3034 %{ $info->{meta} || {} }, 3209 %{ $info->{meta} || {} },
3035 }); 3210 });
3036 3211
3037 $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};
3038 } else { 3219 } else {
3039 $data = $info->{data}; 3220 $RESOURCE{$name} = $info;
3040 } 3221 }
3041 3222
3042 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3043 cf::face::set_type $idx, $info->{type};
3044
3045 cf::cede_to_tick; 3223 cf::cede_to_tick;
3046 } 3224 }
3047
3048 if ($soundconf) {
3049 $soundconf = $enc->decode (delete $soundconf->{data});
3050
3051 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3052 my $sound = $soundconf->{compat}[$_]
3053 or next;
3054
3055 my $face = cf::face::find "sound/$sound->[1]";
3056 cf::sound::set $sound->[0] => $face;
3057 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3058 }
3059
3060 while (my ($k, $v) = each %{$soundconf->{event}}) {
3061 my $face = cf::face::find "sound/$v";
3062 cf::sound::set $k => $face;
3063 }
3064 }
3065 } 3225 }
3226
3227 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3066 3228
3067 1 3229 1
3068} 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});
3069 3251
3070register_exticmd fx_want => sub { 3252register_exticmd fx_want => sub {
3071 my ($ns, $want) = @_; 3253 my ($ns, $want) = @_;
3072 3254
3073 while (my ($k, $v) = each %$want) { 3255 while (my ($k, $v) = each %$want) {
… …
3128sub reload_config { 3310sub reload_config {
3129 open my $fh, "<:utf8", "$CONFDIR/config" 3311 open my $fh, "<:utf8", "$CONFDIR/config"
3130 or return; 3312 or return;
3131 3313
3132 local $/; 3314 local $/;
3133 *CFG = YAML::Syck::Load <$fh>; 3315 *CFG = YAML::Load <$fh>;
3134 3316
3135 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3317 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3136 3318
3137 $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};
3138 $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};
… …
3149sub main { 3331sub main {
3150 # we must not ever block the main coroutine 3332 # we must not ever block the main coroutine
3151 local $Coro::idle = sub { 3333 local $Coro::idle = sub {
3152 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#
3153 (async { 3335 (async {
3154 Event::one_event; 3336 $Coro::current->{desc} = "IDLE BUG HANDLER";
3337 EV::loop EV::LOOP_ONESHOT;
3155 })->prio (Coro::PRIO_MAX); 3338 })->prio (Coro::PRIO_MAX);
3156 }; 3339 };
3157 3340
3158 reload_config; 3341 reload_config;
3159 db_init; 3342 db_init;
3160 load_extensions; 3343 load_extensions;
3161 3344
3162 $TICK_WATCHER->start; 3345 $TICK_WATCHER->start;
3346 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3163 Event::loop; 3347 EV::loop;
3164} 3348}
3165 3349
3166############################################################################# 3350#############################################################################
3167# initialisation and cleanup 3351# initialisation and cleanup
3168 3352
3169# install some emergency cleanup handlers 3353# install some emergency cleanup handlers
3170BEGIN { 3354BEGIN {
3355 our %SIGWATCHER = ();
3171 for my $signal (qw(INT HUP TERM)) { 3356 for my $signal (qw(INT HUP TERM)) {
3172 Event->signal ( 3357 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3173 reentrant => 0,
3174 data => WF_AUTOCANCEL,
3175 signal => $signal,
3176 prio => 0,
3177 cb => sub {
3178 cf::cleanup "SIG$signal"; 3358 cf::cleanup "SIG$signal";
3179 },
3180 ); 3359 };
3181 } 3360 }
3182} 3361}
3183 3362
3184sub write_runtime { 3363sub write_runtime {
3185 my $runtime = "$LOCALDIR/runtime"; 3364 my $runtime = "$LOCALDIR/runtime";
… …
3230 # and maps saved/destroyed asynchronously. 3409 # and maps saved/destroyed asynchronously.
3231 warn "begin emergency player save\n"; 3410 warn "begin emergency player save\n";
3232 for my $login (keys %cf::PLAYER) { 3411 for my $login (keys %cf::PLAYER) {
3233 my $pl = $cf::PLAYER{$login} or next; 3412 my $pl = $cf::PLAYER{$login} or next;
3234 $pl->valid or next; 3413 $pl->valid or next;
3414 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3235 $pl->save; 3415 $pl->save;
3236 } 3416 }
3237 warn "end emergency player save\n"; 3417 warn "end emergency player save\n";
3238 3418
3239 warn "begin emergency map save\n"; 3419 warn "begin emergency map save\n";
… …
3278 warn "syncing database to disk"; 3458 warn "syncing database to disk";
3279 BDB::db_env_txn_checkpoint $DB_ENV; 3459 BDB::db_env_txn_checkpoint $DB_ENV;
3280 3460
3281 # 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
3282 3462
3283 warn "cancelling all WF_AUTOCANCEL watchers";
3284 for (Event::all_watchers) {
3285 $_->cancel if $_->data & WF_AUTOCANCEL;
3286 }
3287
3288 warn "flushing outstanding aio requests"; 3463 warn "flushing outstanding aio requests";
3289 for (;;) { 3464 for (;;) {
3290 BDB::flush; 3465 BDB::flush;
3291 IO::AIO::flush; 3466 IO::AIO::flush;
3292 Coro::cede; 3467 Coro::cede_notself;
3293 last unless IO::AIO::nreqs || BDB::nreqs; 3468 last unless IO::AIO::nreqs || BDB::nreqs;
3294 warn "iterate..."; 3469 warn "iterate...";
3295 } 3470 }
3296 3471
3297 ++$RELOAD; 3472 ++$RELOAD;
… …
3386 3561
3387sub reload_perl() { 3562sub reload_perl() {
3388 # doing reload synchronously and two reloads happen back-to-back, 3563 # doing reload synchronously and two reloads happen back-to-back,
3389 # coro crashes during coro_state_free->destroy here. 3564 # coro crashes during coro_state_free->destroy here.
3390 3565
3391 $RELOAD_WATCHER ||= Event->timer ( 3566 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3392 reentrant => 0,
3393 after => 0,
3394 data => WF_AUTOCANCEL,
3395 cb => sub {
3396 do_reload_perl;
3397 undef $RELOAD_WATCHER; 3567 undef $RELOAD_WATCHER;
3398 }, 3568 do_reload_perl;
3399 ); 3569 };
3400} 3570}
3401 3571
3402register_command "reload" => sub { 3572register_command "reload" => sub {
3403 my ($who, $arg) = @_; 3573 my ($who, $arg) = @_;
3404 3574
3405 if ($who->flag (FLAG_WIZ)) { 3575 if ($who->flag (FLAG_WIZ)) {
3406 $who->message ("reloading server."); 3576 $who->message ("reloading server.");
3577 async {
3578 $Coro::current->{desc} = "perl_reload";
3407 async { reload_perl }; 3579 reload_perl;
3580 };
3408 } 3581 }
3409}; 3582};
3410 3583
3411unshift @INC, $LIBDIR; 3584unshift @INC, $LIBDIR;
3412 3585
… …
3431 my $signal = new Coro::Signal; 3604 my $signal = new Coro::Signal;
3432 push @WAIT_FOR_TICK_BEGIN, $signal; 3605 push @WAIT_FOR_TICK_BEGIN, $signal;
3433 $signal->wait; 3606 $signal->wait;
3434} 3607}
3435 3608
3436 my $min = 1e6;#d# 3609$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3437 my $avg = 10;
3438$TICK_WATCHER = Event->timer (
3439 reentrant => 0,
3440 parked => 1,
3441 prio => 0,
3442 at => $NEXT_TICK || $TICK,
3443 data => WF_AUTOCANCEL,
3444 cb => sub {
3445 if ($Coro::current != $Coro::main) { 3610 if ($Coro::current != $Coro::main) {
3446 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"
3447 unless ++$bug_warning > 10; 3612 unless ++$bug_warning > 10;
3448 return; 3613 return;
3449 } 3614 }
3450 3615
3451 $NOW = $tick_start = Event::time; 3616 $NOW = $tick_start = EV::now;
3452 3617
3453 cf::server_tick; # one server iteration 3618 cf::server_tick; # one server iteration
3454 3619
3455 0 && sync_job {#d# 3620 $RUNTIME += $TICK;
3456 for(1..10) { 3621 $NEXT_TICK = $_[0]->at;
3457 my $t = Event::time;
3458 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3459 or die;
3460 3622
3461 $map->width (50); 3623 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3462 $map->height (50); 3624 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3463 $map->alloc; 3625 Coro::async_pool {
3464 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work 3626 $Coro::current->{desc} = "runtime saver";
3465 my $t = Event::time - $t; 3627 write_runtime
3466 3628 or warn "ERROR: unable to write runtime file: $!";
3467 #next unless $t < 0.0013;#d#
3468 if ($t < $min) {
3469 $min = $t;
3470 }
3471 $avg = $avg * 0.99 + $t * 0.01;
3472 }
3473 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3474 exit 0;
3475 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3476 }; 3629 };
3630 }
3477 3631
3478 $RUNTIME += $TICK;
3479 $NEXT_TICK += $TICK;
3480
3481 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3482 $NEXT_RUNTIME_WRITE = $NOW + 10;
3483 Coro::async_pool {
3484 write_runtime
3485 or warn "ERROR: unable to write runtime file: $!";
3486 };
3487 }
3488
3489# my $AFTER = Event::time;
3490# warn $AFTER - $NOW;#d#
3491
3492 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3632 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3493 $sig->send; 3633 $sig->send;
3494 } 3634 }
3495 while (my $sig = shift @WAIT_FOR_TICK) { 3635 while (my $sig = shift @WAIT_FOR_TICK) {
3496 $sig->send; 3636 $sig->send;
3497 } 3637 }
3498 3638
3499 $NOW = Event::time;
3500
3501 # if we are delayed by four ticks or more, skip them all
3502 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3503
3504 $TICK_WATCHER->at ($NEXT_TICK);
3505 $TICK_WATCHER->start;
3506
3507 $LOAD = ($NOW - $tick_start) / $TICK; 3639 $LOAD = ($NOW - $tick_start) / $TICK;
3508 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3640 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3509 3641
3510 _post_tick; 3642 _post_tick;
3511 3643};
3512 3644$TICK_WATCHER->priority (EV::MAXPRI);
3513 },
3514);
3515 3645
3516{ 3646{
3517 BDB::max_poll_time $TICK * 0.1; 3647 # configure BDB
3518 $BDB_POLL_WATCHER = Event->io ( 3648
3519 reentrant => 0,
3520 fd => BDB::poll_fileno,
3521 poll => 'r',
3522 prio => 0,
3523 data => WF_AUTOCANCEL,
3524 cb => \&BDB::poll_cb,
3525 );
3526 BDB::min_parallel 8; 3649 BDB::min_parallel 8;
3527 3650 BDB::max_poll_reqs $TICK * 0.1;
3528 BDB::set_sync_prepare { 3651 $Coro::BDB::WATCHER->priority (1);
3529 my $status;
3530 my $current = $Coro::current;
3531 (
3532 sub {
3533 $status = $!;
3534 $current->ready; undef $current;
3535 },
3536 sub {
3537 Coro::schedule while defined $current;
3538 $! = $status;
3539 },
3540 )
3541 };
3542 3652
3543 unless ($DB_ENV) { 3653 unless ($DB_ENV) {
3544 $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);
3545 3659
3546 cf::sync_job { 3660 cf::sync_job {
3547 eval { 3661 eval {
3548 BDB::db_env_open 3662 BDB::db_env_open
3549 $DB_ENV, 3663 $DB_ENV,
… …
3551 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
3552 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3666 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3553 0666; 3667 0666;
3554 3668
3555 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3669 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3556
3557 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3558 $DB_ENV->set_lk_detect;
3559 }; 3670 };
3560 3671
3561 cf::cleanup "db_env_open(db): $@" if $@; 3672 cf::cleanup "db_env_open(db): $@" if $@;
3562 }; 3673 };
3563 } 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 };
3564} 3685}
3565 3686
3566{ 3687{
3688 # configure IO::AIO
3689
3567 IO::AIO::min_parallel 8; 3690 IO::AIO::min_parallel 8;
3568
3569 undef $Coro::AIO::WATCHER;
3570 IO::AIO::max_poll_time $TICK * 0.1; 3691 IO::AIO::max_poll_time $TICK * 0.1;
3571 $AIO_POLL_WATCHER = Event->io ( 3692 $Coro::AIO::WATCHER->priority (1);
3572 reentrant => 0,
3573 data => WF_AUTOCANCEL,
3574 fd => IO::AIO::poll_fileno,
3575 poll => 'r',
3576 prio => 6,
3577 cb => \&IO::AIO::poll_cb,
3578 );
3579} 3693}
3580 3694
3581my $_log_backtrace; 3695my $_log_backtrace;
3582 3696
3583sub _log_backtrace { 3697sub _log_backtrace {
… …
3587 3701
3588 # limit the # of concurrent backtraces 3702 # limit the # of concurrent backtraces
3589 if ($_log_backtrace < 2) { 3703 if ($_log_backtrace < 2) {
3590 ++$_log_backtrace; 3704 ++$_log_backtrace;
3591 async { 3705 async {
3706 $Coro::current->{desc} = "abt $msg";
3707
3592 my @bt = fork_call { 3708 my @bt = fork_call {
3593 @addr = map { sprintf "%x", $_ } @addr; 3709 @addr = map { sprintf "%x", $_ } @addr;
3594 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3710 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3595 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 |"
3596 or die "addr2line: $!"; 3712 or die "addr2line: $!";

Diff Legend

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