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.349 by root, Fri Aug 31 04:10:43 2007 UTC vs.
Revision 1.398 by root, Wed Dec 5 11:08:34 2007 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;
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.1 ();
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::Storable; 23use Coro::Storable;
24use Coro::Util (); 24use Coro::Util ();
25 25
26use JSON::XS (); 26use JSON::XS 2.01 ();
27use BDB (); 27use BDB ();
28use Data::Dumper; 28use Data::Dumper;
29use Digest::MD5; 29use Digest::MD5;
30use Fcntl; 30use Fcntl;
31use YAML::Syck (); 31use YAML::Syck ();
32use IO::AIO 2.32 (); 32use IO::AIO 2.51 ();
33use Time::HiRes; 33use Time::HiRes;
34use Compress::LZF; 34use Compress::LZF;
35use Digest::MD5 (); 35use Digest::MD5 ();
36 36
37# configure various modules to our taste 37# configure various modules to our taste
38# 38#
39$Storable::canonical = 1; # reduce rsync transfers 39$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 40Coro::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 41Compress::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 42
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 43# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1; 44$YAML::Syck::ImplicitUnicode = 1;
47 45
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 46$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
… …
80our $NEXT_TICK; 78our $NEXT_TICK;
81our $NOW; 79our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 80our $USE_FSYNC = 1; # use fsync to write maps - default off
83 81
84our $BDB_POLL_WATCHER; 82our $BDB_POLL_WATCHER;
83our $BDB_DEADLOCK_WATCHER;
84our $BDB_CHECKPOINT_WATCHER;
85our $BDB_TRICKLE_WATCHER;
85our $DB_ENV; 86our $DB_ENV;
86 87
87our %CFG; 88our %CFG;
88 89
89our $UPTIME; $UPTIME ||= time; 90our $UPTIME; $UPTIME ||= time;
90our $RUNTIME; 91our $RUNTIME;
91 92
92our %PLAYER; # all users 93our (%PLAYER, %PLAYER_LOADING); # all users
93our %MAP; # all maps 94our (%MAP, %MAP_LOADING ); # all maps
94our $LINK_MAP; # the special {link} map, which is always available 95our $LINK_MAP; # the special {link} map, which is always available
95 96
96# used to convert map paths into valid unix filenames by replacing / by ∕ 97# used to convert map paths into valid unix filenames by replacing / by ∕
97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 98our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
98 99
… …
159 160
160The raw value load value from the last tick. 161The raw value load value from the last tick.
161 162
162=item %cf::CFG 163=item %cf::CFG
163 164
164Configuration for the server, loaded from C</etc/crossfire/config>, or 165Configuration for the server, loaded from C</etc/deliantra-server/config>, or
165from wherever your confdir points to. 166from wherever your confdir points to.
166 167
167=item cf::wait_for_tick, cf::wait_for_tick_begin 168=item cf::wait_for_tick, cf::wait_for_tick_begin
168 169
169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 170These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
… …
187 $msg .= "\n" 188 $msg .= "\n"
188 unless $msg =~ /\n$/; 189 unless $msg =~ /\n$/;
189 190
190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 191 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191 192
192 utf8::encode $msg;
193 LOG llevError, $msg; 193 LOG llevError, $msg;
194 }; 194 };
195} 195}
196 196
197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
213)) { 213)) {
214 no strict 'refs'; 214 no strict 'refs';
215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
216} 216}
217 217
218$Event::DIED = sub { 218$EV::DIED = sub {
219 warn "error in event callback: @_"; 219 warn "error in event callback: @_";
220}; 220};
221 221
222############################################################################# 222#############################################################################
223 223
… …
246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
247 $d 247 $d
248 } || "[unable to dump $_[0]: '$@']"; 248 } || "[unable to dump $_[0]: '$@']";
249} 249}
250 250
251=item $ref = cf::from_json $json 251=item $ref = cf::decode_json $json
252 252
253Converts a JSON string into the corresponding perl data structure. 253Converts a JSON string into the corresponding perl data structure.
254 254
255=item $json = cf::to_json $ref 255=item $json = cf::encode_json $ref
256 256
257Converts a perl data structure into its JSON representation. 257Converts a perl data structure into its JSON representation.
258 258
259=cut 259=cut
260 260
261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
262 262
263sub to_json ($) { $json_coder->encode ($_[0]) } 263sub encode_json($) { $json_coder->encode ($_[0]) }
264sub from_json ($) { $json_coder->decode ($_[0]) } 264sub decode_json($) { $json_coder->decode ($_[0]) }
265 265
266=item cf::lock_wait $string 266=item cf::lock_wait $string
267 267
268Wait until the given lock is available. See cf::lock_acquire. 268Wait until the given lock is available. See cf::lock_acquire.
269 269
… …
285Return true if the lock is currently active, i.e. somebody has locked it. 285Return true if the lock is currently active, i.e. somebody has locked it.
286 286
287=cut 287=cut
288 288
289our %LOCK; 289our %LOCK;
290our %LOCKER;#d#
290 291
291sub lock_wait($) { 292sub lock_wait($) {
292 my ($key) = @_; 293 my ($key) = @_;
294
295 if ($LOCKER{$key} == $Coro::current) {#d#
296 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
297 return;#d#
298 }#d#
293 299
294 # wait for lock, if any 300 # wait for lock, if any
295 while ($LOCK{$key}) { 301 while ($LOCK{$key}) {
296 push @{ $LOCK{$key} }, $Coro::current; 302 push @{ $LOCK{$key} }, $Coro::current;
297 Coro::schedule; 303 Coro::schedule;
… …
303 309
304 # wait, to be sure we are not locked 310 # wait, to be sure we are not locked
305 lock_wait $key; 311 lock_wait $key;
306 312
307 $LOCK{$key} = []; 313 $LOCK{$key} = [];
314 $LOCKER{$key} = $Coro::current;#d#
308 315
309 Coro::guard { 316 Coro::guard {
317 delete $LOCKER{$key};#d#
310 # wake up all waiters, to be on the safe side 318 # wake up all waiters, to be on the safe side
311 $_->ready for @{ delete $LOCK{$key} }; 319 $_->ready for @{ delete $LOCK{$key} };
312 } 320 }
313} 321}
314 322
… …
326 }; 334 };
327 $TICK_WATCHER->stop; 335 $TICK_WATCHER->stop;
328 $guard 336 $guard
329} 337}
330 338
339=item cf::periodic $interval, $cb
340
341Like EV::periodic, but randomly selects a starting point so that the actions
342get spread over timer.
343
344=cut
345
346sub periodic($$) {
347 my ($interval, $cb) = @_;
348
349 my $start = rand List::Util::min 180, $interval;
350
351 EV::periodic $start, $interval, 0, $cb
352}
353
331=item cf::get_slot $time[, $priority[, $name]] 354=item cf::get_slot $time[, $priority[, $name]]
332 355
333Allocate $time seconds of blocking CPU time at priority C<$priority>: 356Allocate $time seconds of blocking CPU time at priority C<$priority>:
334This call blocks and returns only when you have at least C<$time> seconds 357This call blocks and returns only when you have at least C<$time> seconds
335of cpu time till the next tick. The slot is only valid till the next cede. 358of cpu time till the next tick. The slot is only valid till the next cede.
… …
344our @SLOT_QUEUE; 367our @SLOT_QUEUE;
345our $SLOT_QUEUE; 368our $SLOT_QUEUE;
346 369
347$SLOT_QUEUE->cancel if $SLOT_QUEUE; 370$SLOT_QUEUE->cancel if $SLOT_QUEUE;
348$SLOT_QUEUE = Coro::async { 371$SLOT_QUEUE = Coro::async {
372 $Coro::current->desc ("timeslot manager");
373
349 my $signal = new Coro::Signal; 374 my $signal = new Coro::Signal;
350 375
351 while () { 376 while () {
352 next_job: 377 next_job:
353 my $avail = cf::till_tick; 378 my $avail = cf::till_tick;
… …
361 } 386 }
362 } 387 }
363 } 388 }
364 389
365 if (@SLOT_QUEUE) { 390 if (@SLOT_QUEUE) {
366 # we do not use wait_For_tick() as it returns immediately when tick is inactive 391 # we do not use wait_for_tick() as it returns immediately when tick is inactive
367 push @cf::WAIT_FOR_TICK, $signal; 392 push @cf::WAIT_FOR_TICK, $signal;
368 $signal->wait; 393 $signal->wait;
369 } else { 394 } else {
370 Coro::schedule; 395 Coro::schedule;
371 } 396 }
… …
394 419
395BEGIN { *async = \&Coro::async_pool } 420BEGIN { *async = \&Coro::async_pool }
396 421
397=item cf::sync_job { BLOCK } 422=item cf::sync_job { BLOCK }
398 423
399The design of Crossfire TRT requires that the main coroutine ($Coro::main) 424The design of Deliantra requires that the main coroutine ($Coro::main)
400is always able to handle events or runnable, as Crossfire TRT is only 425is always able to handle events or runnable, as Deliantra is only
401partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 426partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
402acceptable. 427acceptable.
403 428
404If it must be done, put the blocking parts into C<sync_job>. This will run 429If it must be done, put the blocking parts into C<sync_job>. This will run
405the given BLOCK in another coroutine while waiting for the result. The 430the given BLOCK in another coroutine while waiting for the result. The
… …
410 435
411sub sync_job(&) { 436sub sync_job(&) {
412 my ($job) = @_; 437 my ($job) = @_;
413 438
414 if ($Coro::current == $Coro::main) { 439 if ($Coro::current == $Coro::main) {
415 my $time = Event::time; 440 my $time = EV::time;
416 441
417 # this is the main coro, too bad, we have to block 442 # this is the main coro, too bad, we have to block
418 # till the operation succeeds, freezing the server :/ 443 # till the operation succeeds, freezing the server :/
419 444
445 LOG llevError, Carp::longmess "sync job";#d#
446
420 # TODO: use suspend/resume instead 447 # TODO: use suspend/resume instead
421 # (but this is cancel-safe) 448 # (but this is cancel-safe)
422 my $freeze_guard = freeze_mainloop; 449 my $freeze_guard = freeze_mainloop;
423 450
424 my $busy = 1; 451 my $busy = 1;
425 my @res; 452 my @res;
426 453
427 (async { 454 (async {
455 $Coro::current->desc ("sync job coro");
428 @res = eval { $job->() }; 456 @res = eval { $job->() };
429 warn $@ if $@; 457 warn $@ if $@;
430 undef $busy; 458 undef $busy;
431 })->prio (Coro::PRIO_MAX); 459 })->prio (Coro::PRIO_MAX);
432 460
433 while ($busy) { 461 while ($busy) {
434 Coro::cede or Event::one_event; 462 if (Coro::nready) {
463 Coro::cede_notself;
464 } else {
465 EV::loop EV::LOOP_ONESHOT;
435 } 466 }
467 }
436 468
437 $time = Event::time - $time; 469 $time = EV::time - $time;
438 470
439 LOG llevError | logBacktrace, Carp::longmess "long sync job" 471 LOG llevError | logBacktrace, Carp::longmess "long sync job"
440 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active; 472 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
441 473
442 $tick_start += $time; # do not account sync jobs to server load 474 $tick_start += $time; # do not account sync jobs to server load
… …
472=item fork_call { }, $args 504=item fork_call { }, $args
473 505
474Executes the given code block with the given arguments in a seperate 506Executes the given code block with the given arguments in a seperate
475process, returning the results. Everything must be serialisable with 507process, returning the results. Everything must be serialisable with
476Coro::Storable. May, of course, block. Note that the executed sub may 508Coro::Storable. May, of course, block. Note that the executed sub may
477never block itself or use any form of Event handling. 509never block itself or use any form of event handling.
478 510
479=cut 511=cut
480 512
481sub fork_call(&@) { 513sub fork_call(&@) {
482 my ($cb, @args) = @_; 514 my ($cb, @args) = @_;
483 515
484 # we seemingly have to make a local copy of the whole thing, 516 # we seemingly have to make a local copy of the whole thing,
485 # otherwise perl prematurely frees the stuff :/ 517 # otherwise perl prematurely frees the stuff :/
486 # TODO: investigate and fix (liekly this will be rather laborious) 518 # TODO: investigate and fix (likely this will be rather laborious)
487 519
488 my @res = Coro::Util::fork_eval { 520 my @res = Coro::Util::fork_eval {
489 reset_signals; 521 reset_signals;
490 &$cb 522 &$cb
491 }, @args; 523 }, @args;
… …
500=item cf::db_put $family => $key => $value 532=item cf::db_put $family => $key => $value
501 533
502Stores the given C<$value> in the family. It can currently store binary 534Stores the given C<$value> in the family. It can currently store binary
503data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 535data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
504 536
537=item $db = cf::db_table "name"
538
539Create and/or open a new database table. The string must not be "db" and must be unique
540within each server.
541
505=cut 542=cut
543
544sub db_table($) {
545 my ($name) = @_;
546 my $db = BDB::db_create $DB_ENV;
547
548 eval {
549 $db->set_flags (BDB::CHKSUM);
550
551 utf8::encode $name;
552 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
553 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
554 cf::cleanup "db_open(db): $!" if $!;
555 };
556 cf::cleanup "db_open(db): $@" if $@;
557
558 $db
559}
506 560
507our $DB; 561our $DB;
508 562
509sub db_init { 563sub db_init {
510 unless ($DB) {
511 $DB = BDB::db_create $DB_ENV;
512
513 cf::sync_job { 564 cf::sync_job {
514 eval { 565 $DB ||= db_table "db";
515 $DB->set_flags (BDB::CHKSUM);
516
517 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
518 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
519 cf::cleanup "db_open(db): $!" if $!;
520 };
521 cf::cleanup "db_open(db): $@" if $@;
522 };
523 } 566 };
524} 567}
525 568
526sub db_get($$) { 569sub db_get($$) {
527 my $key = "$_[0]/$_[1]"; 570 my $key = "$_[0]/$_[1]";
528 571
… …
632attach callbacks/event handlers (a collection of which is called an "attachment") 675attach callbacks/event handlers (a collection of which is called an "attachment")
633to it. All such attachable objects support the following methods. 676to it. All such attachable objects support the following methods.
634 677
635In the following description, CLASS can be any of C<global>, C<object> 678In the following description, CLASS can be any of C<global>, C<object>
636C<player>, C<client> or C<map> (i.e. the attachable objects in 679C<player>, C<client> or C<map> (i.e. the attachable objects in
637Crossfire TRT). 680Deliantra).
638 681
639=over 4 682=over 4
640 683
641=item $attachable->attach ($attachment, key => $value...) 684=item $attachable->attach ($attachment, key => $value...)
642 685
… …
940 983
941=cut 984=cut
942 985
943############################################################################# 986#############################################################################
944# object support 987# object support
945#
946 988
989sub _object_equal($$);
990sub _object_equal($$) {
991 my ($a, $b) = @_;
992
993 return 0 unless (ref $a) eq (ref $b);
994
995 if ("HASH" eq ref $a) {
996 my @ka = keys %$a;
997 my @kb = keys %$b;
998
999 return 0 if @ka != @kb;
1000
1001 for (0 .. $#ka) {
1002 return 0 unless $ka[$_] eq $kb[$_];
1003 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1004 }
1005
1006 } elsif ("ARRAY" eq ref $a) {
1007
1008 return 0 if @$a != @$b;
1009
1010 for (0 .. $#$a) {
1011 return 0 unless _object_equal $a->[$_], $b->[$_];
1012 }
1013
1014 } elsif ($a ne $b) {
1015 return 0;
1016 }
1017
1018 1
1019}
1020
1021our $SLOW_MERGES;#d#
947sub _can_merge { 1022sub _can_merge {
948 my ($ob1, $ob2) = @_; 1023 my ($ob1, $ob2) = @_;
949 1024
950 local $Storable::canonical = 1; 1025 ++$SLOW_MERGES;#d#
951 my $fob1 = Storable::freeze $ob1;
952 my $fob2 = Storable::freeze $ob2;
953 1026
954 $fob1 eq $fob2 1027 # we do the slow way here
1028 return _object_equal $ob1, $ob2
955} 1029}
956 1030
957sub reattach { 1031sub reattach {
958 # basically do the same as instantiate, without calling instantiate 1032 # basically do the same as instantiate, without calling instantiate
959 my ($obj) = @_; 1033 my ($obj) = @_;
… …
981cf::attachable->attach ( 1055cf::attachable->attach (
982 prio => -1000000, 1056 prio => -1000000,
983 on_instantiate => sub { 1057 on_instantiate => sub {
984 my ($obj, $data) = @_; 1058 my ($obj, $data) = @_;
985 1059
986 $data = from_json $data; 1060 $data = decode_json $data;
987 1061
988 for (@$data) { 1062 for (@$data) {
989 my ($name, $args) = @$_; 1063 my ($name, $args) = @$_;
990 1064
991 $obj->attach ($name, %{$args || {} }); 1065 $obj->attach ($name, %{$args || {} });
… …
1007sub object_freezer_save { 1081sub object_freezer_save {
1008 my ($filename, $rdata, $objs) = @_; 1082 my ($filename, $rdata, $objs) = @_;
1009 1083
1010 sync_job { 1084 sync_job {
1011 if (length $$rdata) { 1085 if (length $$rdata) {
1086 utf8::decode (my $decname = $filename);
1012 warn sprintf "saving %s (%d,%d)\n", 1087 warn sprintf "saving %s (%d,%d)\n",
1013 $filename, length $$rdata, scalar @$objs; 1088 $decname, length $$rdata, scalar @$objs;
1014 1089
1015 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1090 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1016 chmod SAVE_MODE, $fh; 1091 chmod SAVE_MODE, $fh;
1017 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1092 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1018 aio_fsync $fh if $cf::USE_FSYNC; 1093 aio_fsync $fh if $cf::USE_FSYNC;
1019 close $fh; 1094 close $fh;
1020 1095
1021 if (@$objs) { 1096 if (@$objs) {
1022 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1097 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1023 chmod SAVE_MODE, $fh; 1098 chmod SAVE_MODE, $fh;
1024 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1099 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1025 aio_write $fh, 0, (length $data), $data, 0; 1100 aio_write $fh, 0, (length $data), $data, 0;
1026 aio_fsync $fh if $cf::USE_FSYNC; 1101 aio_fsync $fh if $cf::USE_FSYNC;
1027 close $fh; 1102 close $fh;
1028 aio_rename "$filename.pst~", "$filename.pst"; 1103 aio_rename "$filename.pst~", "$filename.pst";
1029 } 1104 }
… …
1037 } 1112 }
1038 } else { 1113 } else {
1039 aio_unlink $filename; 1114 aio_unlink $filename;
1040 aio_unlink "$filename.pst"; 1115 aio_unlink "$filename.pst";
1041 } 1116 }
1042 } 1117 };
1043} 1118}
1044 1119
1045sub object_freezer_as_string { 1120sub object_freezer_as_string {
1046 my ($rdata, $objs) = @_; 1121 my ($rdata, $objs) = @_;
1047 1122
… …
1059 or return; 1134 or return;
1060 1135
1061 unless (aio_stat "$filename.pst") { 1136 unless (aio_stat "$filename.pst") {
1062 (aio_load "$filename.pst", $av) >= 0 1137 (aio_load "$filename.pst", $av) >= 0
1063 or return; 1138 or return;
1139
1064 $av = eval { (Storable::thaw $av)->{objs} }; 1140 my $st = eval { Coro::Storable::thaw $av };
1141 $av = $st->{objs};
1065 } 1142 }
1066 1143
1144 utf8::decode (my $decname = $filename);
1067 warn sprintf "loading %s (%d)\n", 1145 warn sprintf "loading %s (%d,%d)\n",
1068 $filename, length $data, scalar @{$av || []}; 1146 $decname, length $data, scalar @{$av || []};
1147
1069 return ($data, $av); 1148 ($data, $av)
1070} 1149}
1071 1150
1072=head2 COMMAND CALLBACKS 1151=head2 COMMAND CALLBACKS
1073 1152
1074=over 4 1153=over 4
… …
1260 1339
1261=head3 cf::player 1340=head3 cf::player
1262 1341
1263=over 4 1342=over 4
1264 1343
1344=item cf::player::num_playing
1345
1346Returns the official number of playing players, as per the Crossfire metaserver rules.
1347
1348=cut
1349
1350sub num_playing {
1351 scalar grep
1352 $_->ob->map
1353 && !$_->hidden
1354 && !$_->ob->flag (cf::FLAG_WIZ),
1355 cf::player::list
1356}
1357
1265=item cf::player::find $login 1358=item cf::player::find $login
1266 1359
1267Returns the given player object, loading it if necessary (might block). 1360Returns the given player object, loading it if necessary (might block).
1268 1361
1269=cut 1362=cut
… …
1304 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1397 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1305 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1398 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1306 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1399 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1307 aio_unlink +(playerdir $login) . "/$login.pl"; 1400 aio_unlink +(playerdir $login) . "/$login.pl";
1308 1401
1309 my $pl = load_pl path $login 1402 my $f = new_from_file cf::object::thawer path $login
1310 or return; 1403 or return;
1404
1405 my $pl = cf::player::load_pl $f
1406 or return;
1407 local $cf::PLAYER_LOADING{$login} = $pl;
1408 $f->resolve_delayed_derefs;
1311 $cf::PLAYER{$login} = $pl 1409 $cf::PLAYER{$login} = $pl
1312 } 1410 }
1313 } 1411 }
1314} 1412}
1315 1413
… …
1413 or return []; 1511 or return [];
1414 1512
1415 my @logins; 1513 my @logins;
1416 1514
1417 for my $login (@$dirs) { 1515 for my $login (@$dirs) {
1516 my $path = path $login;
1517
1518 # a .pst is a dead give-away for a valid player
1519 unless (-e "$path.pst") {
1418 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1520 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1419 aio_read $fh, 0, 512, my $buf, 0 or next; 1521 aio_read $fh, 0, 512, my $buf, 0 or next;
1420 $buf !~ /^password -------------$/m or next; # official not-valid tag 1522 $buf !~ /^password -------------$/m or next; # official not-valid tag
1523 }
1421 1524
1422 utf8::decode $login; 1525 utf8::decode $login;
1423 push @logins, $login; 1526 push @logins, $login;
1424 } 1527 }
1425 1528
… …
1458 1561
1459Expand crossfire pod fragments into protocol xml. 1562Expand crossfire pod fragments into protocol xml.
1460 1563
1461=cut 1564=cut
1462 1565
1566use re 'eval';
1567
1568my $group;
1569my $interior; $interior = qr{
1570 # match a pod interior sequence sans C<< >>
1571 (?:
1572 \ (.*?)\ (?{ $group = $^N })
1573 | < (??{$interior}) >
1574 )
1575}x;
1576
1463sub expand_cfpod { 1577sub expand_cfpod {
1464 ((my $self), (local $_)) = @_; 1578 my ($self, $pod) = @_;
1465 1579
1466 # escape & and < 1580 my $xml;
1467 s/&/&amp;/g;
1468 s/(?<![BIUGH])</&lt;/g;
1469 1581
1470 # this is buggy, it needs to properly take care of nested <'s 1582 while () {
1583 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1584 $group = $1;
1471 1585
1472 1 while 1586 $group =~ s/&/&amp;/g;
1473 # replace B<>, I<>, U<> etc. 1587 $group =~ s/</&lt;/g;
1474 s/B<([^\>]*)>/<b>$1<\/b>/ 1588
1475 || s/I<([^\>]*)>/<i>$1<\/i>/ 1589 $xml .= $group;
1476 || s/U<([^\>]*)>/<u>$1<\/u>/ 1590 } elsif ($pod =~ m%\G
1477 # replace G<male|female> tags 1591 ([BCGHITU])
1478 || s{G<([^>|]*)\|([^>]*)>}{ 1592 <
1479 $self->gender ? $2 : $1 1593 (?:
1480 }ge 1594 ([^<>]*) (?{ $group = $^N })
1481 # replace H<hint text> 1595 | < $interior >
1482 || s{H<([^\>]*)>} 1596 )
1597 >
1598 %gcsx
1483 { 1599 ) {
1600 my ($code, $data) = ($1, $group);
1601
1602 if ($code eq "B") {
1603 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1604 } elsif ($code eq "I") {
1605 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1606 } elsif ($code eq "U") {
1607 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1608 } elsif ($code eq "C") {
1609 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1610 } elsif ($code eq "T") {
1611 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1612 } elsif ($code eq "G") {
1613 my ($male, $female) = split /\|/, $data;
1614 $data = $self->gender ? $female : $male;
1615 $xml .= expand_cfpod ($self, $data);
1616 } elsif ($code eq "H") {
1484 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1617 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1485 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1618 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1486 "") 1619 "")
1487 [$self->{hintmode}] 1620 [$self->{hintmode}];
1621 } else {
1622 $xml .= "error processing '$code($data)' directive";
1488 }ge; 1623 }
1624 } else {
1625 if ($pod =~ /\G(.+)/) {
1626 warn "parse error while expanding $pod (at $1)";
1627 }
1628 last;
1629 }
1630 }
1489 1631
1632 for ($xml) {
1490 # create single paragraphs (very hackish) 1633 # create single paragraphs (very hackish)
1491 s/(?<=\S)\n(?=\w)/ /g; 1634 s/(?<=\S)\n(?=\w)/ /g;
1492 1635
1493 # compress some whitespace 1636 # compress some whitespace
1494 s/\s+\n/\n/g; # ws line-ends 1637 s/\s+\n/\n/g; # ws line-ends
1495 s/\n\n+/\n/g; # double lines 1638 s/\n\n+/\n/g; # double lines
1496 s/^\n+//; # beginning lines 1639 s/^\n+//; # beginning lines
1497 s/\n+$//; # ending lines 1640 s/\n+$//; # ending lines
1641 }
1498 1642
1499 $_ 1643 $xml
1500} 1644}
1645
1646no re 'eval';
1501 1647
1502sub hintmode { 1648sub hintmode {
1503 $_[0]{hintmode} = $_[1] if @_ > 1; 1649 $_[0]{hintmode} = $_[1] if @_ > 1;
1504 $_[0]{hintmode} 1650 $_[0]{hintmode}
1505} 1651}
… …
1749 1895
1750sub load_header_from($) { 1896sub load_header_from($) {
1751 my ($self, $path) = @_; 1897 my ($self, $path) = @_;
1752 1898
1753 utf8::encode $path; 1899 utf8::encode $path;
1754 #aio_open $path, O_RDONLY, 0 1900 my $f = new_from_file cf::object::thawer $path
1755 # or return;
1756
1757 $self->_load_header ($path)
1758 or return; 1901 or return;
1902
1903 $self->_load_header ($f)
1904 or return;
1905
1906 local $MAP_LOADING{$self->{path}} = $self;
1907 $f->resolve_delayed_derefs;
1759 1908
1760 $self->{load_path} = $path; 1909 $self->{load_path} = $path;
1761 1910
1762 1 1911 1
1763} 1912}
… …
1817sub find { 1966sub find {
1818 my ($path, $origin) = @_; 1967 my ($path, $origin) = @_;
1819 1968
1820 $path = normalise $path, $origin && $origin->path; 1969 $path = normalise $path, $origin && $origin->path;
1821 1970
1971 cf::lock_wait "map_data:$path";#d#remove
1822 cf::lock_wait "map_find:$path"; 1972 cf::lock_wait "map_find:$path";
1823 1973
1824 $cf::MAP{$path} || do { 1974 $cf::MAP{$path} || do {
1825 my $guard = cf::lock_acquire "map_find:$path"; 1975 my $guard1 = cf::lock_acquire "map_find:$path";
1976 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1977
1826 my $map = new_from_path cf::map $path 1978 my $map = new_from_path cf::map $path
1827 or return; 1979 or return;
1828 1980
1829 $map->{last_save} = $cf::RUNTIME; 1981 $map->{last_save} = $cf::RUNTIME;
1830 1982
… …
1832 or return; 1984 or return;
1833 1985
1834 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1986 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1835 # doing this can freeze the server in a sync job, obviously 1987 # doing this can freeze the server in a sync job, obviously
1836 #$cf::WAIT_FOR_TICK->wait; 1988 #$cf::WAIT_FOR_TICK->wait;
1989 undef $guard1;
1990 undef $guard2;
1837 $map->reset; 1991 $map->reset;
1838 undef $guard;
1839 return find $path; 1992 return find $path;
1840 } 1993 }
1841 1994
1842 $cf::MAP{$path} = $map 1995 $cf::MAP{$path} = $map
1843 } 1996 }
… …
1852 local $self->{deny_reset} = 1; # loading can take a long time 2005 local $self->{deny_reset} = 1; # loading can take a long time
1853 2006
1854 my $path = $self->{path}; 2007 my $path = $self->{path};
1855 2008
1856 { 2009 {
1857 my $guard1 = cf::lock_acquire "map_data:$path"; 2010 my $guard = cf::lock_acquire "map_data:$path";
1858 my $guard2 = cf::lock_acquire "map_load:$path";
1859 2011
2012 return unless $self->valid;
1860 return if $self->in_memory != cf::MAP_SWAPPED; 2013 return unless $self->in_memory == cf::MAP_SWAPPED;
1861 2014
1862 $self->in_memory (cf::MAP_LOADING); 2015 $self->in_memory (cf::MAP_LOADING);
1863 2016
1864 $self->alloc; 2017 $self->alloc;
1865 2018
1866 $self->pre_load; 2019 $self->pre_load;
1867 cf::cede_to_tick; 2020 cf::cede_to_tick;
1868 2021
2022 my $f = new_from_file cf::object::thawer $self->{load_path};
2023 $f->skip_block;
1869 $self->_load_objects ($self->{load_path}, 1) 2024 $self->_load_objects ($f)
1870 or return; 2025 or return;
1871 2026
1872 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2027 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1873 if delete $self->{load_original}; 2028 if delete $self->{load_original};
1874 2029
1875 if (my $uniq = $self->uniq_path) { 2030 if (my $uniq = $self->uniq_path) {
1876 utf8::encode $uniq; 2031 utf8::encode $uniq;
1877 if (aio_open $uniq, O_RDONLY, 0) { 2032 unless (aio_stat $uniq) {
2033 if (my $f = new_from_file cf::object::thawer $uniq) {
1878 $self->clear_unique_items; 2034 $self->clear_unique_items;
1879 $self->_load_objects ($uniq, 0); 2035 $self->_load_objects ($f);
2036 $f->resolve_delayed_derefs;
2037 }
1880 } 2038 }
1881 } 2039 }
2040
2041 $f->resolve_delayed_derefs;
1882 2042
1883 cf::cede_to_tick; 2043 cf::cede_to_tick;
1884 # now do the right thing for maps 2044 # now do the right thing for maps
1885 $self->link_multipart_objects; 2045 $self->link_multipart_objects;
1886 $self->difficulty ($self->estimate_difficulty) 2046 $self->difficulty ($self->estimate_difficulty)
… …
1972 } 2132 }
1973 2133
1974 $MAP_PREFETCH{$path} |= $load; 2134 $MAP_PREFETCH{$path} |= $load;
1975 2135
1976 $MAP_PREFETCHER ||= cf::async { 2136 $MAP_PREFETCHER ||= cf::async {
2137 $Coro::current->{desc} = "map prefetcher";
2138
1977 while (%MAP_PREFETCH) { 2139 while (%MAP_PREFETCH) {
1978 while (my ($k, $v) = each %MAP_PREFETCH) { 2140 while (my ($k, $v) = each %MAP_PREFETCH) {
1979 if (my $map = find $k) { 2141 if (my $map = find $k) {
1980 $map->load if $v; 2142 $map->load if $v;
1981 } 2143 }
… …
2007 return if $self->{deny_save}; 2169 return if $self->{deny_save};
2008 2170
2009 local $self->{last_access} = $self->last_access;#d# 2171 local $self->{last_access} = $self->last_access;#d#
2010 2172
2011 cf::async { 2173 cf::async {
2174 $Coro::current->{desc} = "map player save";
2012 $_->contr->save for $self->players; 2175 $_->contr->save for $self->players;
2013 }; 2176 };
2014 2177
2015 if ($uniq) { 2178 if ($uniq) {
2016 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2179 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
2030 2193
2031 return if $self->players; 2194 return if $self->players;
2032 return if $self->in_memory != cf::MAP_IN_MEMORY; 2195 return if $self->in_memory != cf::MAP_IN_MEMORY;
2033 return if $self->{deny_save}; 2196 return if $self->{deny_save};
2034 2197
2198 $self->in_memory (cf::MAP_SWAPPED);
2199
2200 $self->deactivate;
2201 $_->clear_links_to ($self) for values %cf::MAP;
2035 $self->clear; 2202 $self->clear;
2036 $self->in_memory (cf::MAP_SWAPPED);
2037} 2203}
2038 2204
2039sub reset_at { 2205sub reset_at {
2040 my ($self) = @_; 2206 my ($self) = @_;
2041 2207
… …
2073 if $uniq; 2239 if $uniq;
2074 } 2240 }
2075 2241
2076 delete $cf::MAP{$self->path}; 2242 delete $cf::MAP{$self->path};
2077 2243
2244 $self->deactivate;
2245 $_->clear_links_to ($self) for values %cf::MAP;
2078 $self->clear; 2246 $self->clear;
2079
2080 $_->clear_links_to ($self) for values %cf::MAP;
2081 2247
2082 $self->unlink_save; 2248 $self->unlink_save;
2083 $self->destroy; 2249 $self->destroy;
2084} 2250}
2085 2251
… …
2090 2256
2091 { 2257 {
2092 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2258 my $lock = cf::lock_acquire "map_data:$self->{path}";
2093 2259
2094 delete $cf::MAP{$self->path}; 2260 delete $cf::MAP{$self->path};
2261
2262 $self->unlink_save;
2095 2263
2096 bless $self, "cf::map"; 2264 bless $self, "cf::map";
2097 delete $self->{deny_reset}; 2265 delete $self->{deny_reset};
2098 $self->{deny_save} = 1; 2266 $self->{deny_save} = 1;
2099 $self->reset_timeout (1); 2267 $self->reset_timeout (1);
2100 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2268 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2101
2102 $self->unlink_save;
2103 2269
2104 $cf::MAP{$self->path} = $self; 2270 $cf::MAP{$self->path} = $self;
2105 } 2271 }
2106 2272
2107 $self->reset; # polite request, might not happen 2273 $self->reset; # polite request, might not happen
… …
2186 2352
2187sub inv_recursive { 2353sub inv_recursive {
2188 inv_recursive_ inv $_[0] 2354 inv_recursive_ inv $_[0]
2189} 2355}
2190 2356
2357=item $ref = $ob->ref
2358
2359creates and returns a persistent reference to an objetc that can be stored as a string.
2360
2361=item $ob = cf::object::deref ($refstring)
2362
2363returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2364even if the object actually exists. May block.
2365
2366=cut
2367
2368sub deref {
2369 my ($ref) = @_;
2370
2371 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2372 my ($uuid, $name) = ($1, $2);
2373 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2374 or return;
2375 $pl->ob->uuid eq $uuid
2376 or return;
2377
2378 $pl->ob
2379 } else {
2380 warn "$ref: cannot resolve object reference\n";
2381 undef
2382 }
2383}
2384
2191package cf; 2385package cf;
2192 2386
2193=back 2387=back
2194 2388
2195=head3 cf::object::player 2389=head3 cf::object::player
… …
2353 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2547 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2354 2548
2355 $self->enter_link; 2549 $self->enter_link;
2356 2550
2357 (async { 2551 (async {
2552 $Coro::current->{desc} = "player::goto $path $x $y";
2553
2554 # *tag paths override both path and x|y
2555 if ($path =~ /^\*(.*)$/) {
2556 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2557 my $ob = $obs[rand @obs];
2558
2559 # see if we actually can go there
2560 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2561 $ob = $obs[rand @obs];
2562 } else {
2563 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2564 }
2565 # else put us there anyways for now #d#
2566
2567 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2568 } else {
2569 ($path, $x, $y) = (undef, undef, undef);
2570 }
2571 }
2572
2358 my $map = eval { 2573 my $map = eval {
2359 my $map = cf::map::find $path; 2574 my $map = defined $path ? cf::map::find $path : undef;
2360 2575
2361 if ($map) { 2576 if ($map) {
2362 $map = $map->customise_for ($self); 2577 $map = $map->customise_for ($self);
2363 $map = $check->($map) if $check && $map; 2578 $map = $check->($map) if $check && $map;
2364 } else { 2579 } else {
2365 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2580 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2366 } 2581 }
2367 2582
2368 $map 2583 $map
2369 }; 2584 };
2370 2585
… …
2423 $rmp->{origin_y} = $exit->y; 2638 $rmp->{origin_y} = $exit->y;
2424 } 2639 }
2425 2640
2426 $rmp->{random_seed} ||= $exit->random_seed; 2641 $rmp->{random_seed} ||= $exit->random_seed;
2427 2642
2428 my $data = cf::to_json $rmp; 2643 my $data = cf::encode_json $rmp;
2429 my $md5 = Digest::MD5::md5_hex $data; 2644 my $md5 = Digest::MD5::md5_hex $data;
2430 my $meta = "$RANDOMDIR/$md5.meta"; 2645 my $meta = "$RANDOMDIR/$md5.meta";
2431 2646
2432 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2647 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2433 aio_write $fh, 0, (length $data), $data, 0; 2648 aio_write $fh, 0, (length $data), $data, 0;
… …
2460 # if exit is damned, update players death & WoR home-position 2675 # if exit is damned, update players death & WoR home-position
2461 $self->contr->savebed ($slaying, $hp, $sp) 2676 $self->contr->savebed ($slaying, $hp, $sp)
2462 if $exit->flag (FLAG_DAMNED); 2677 if $exit->flag (FLAG_DAMNED);
2463 2678
2464 (async { 2679 (async {
2680 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2681
2465 $self->deactivate_recursive; # just to be sure 2682 $self->deactivate_recursive; # just to be sure
2466 unless (eval { 2683 unless (eval {
2467 $self->goto ($slaying, $hp, $sp); 2684 $self->goto ($slaying, $hp, $sp);
2468 2685
2469 1; 2686 1;
… …
2504the message, with C<log> being the default. If C<$color> is negative, suppress 2721the message, with C<log> being the default. If C<$color> is negative, suppress
2505the message unless the client supports the msg packet. 2722the message unless the client supports the msg packet.
2506 2723
2507=cut 2724=cut
2508 2725
2726# non-persistent channels (usually the info channel)
2727our %CHANNEL = (
2728 "c/identify" => {
2729 id => "infobox",
2730 title => "Identify",
2731 reply => undef,
2732 tooltip => "Items recently identified",
2733 },
2734 "c/examine" => {
2735 id => "infobox",
2736 title => "Examine",
2737 reply => undef,
2738 tooltip => "Signs and other items you examined",
2739 },
2740 "c/book" => {
2741 id => "infobox",
2742 title => "Book",
2743 reply => undef,
2744 tooltip => "The contents of a note or book",
2745 },
2746 "c/lookat" => {
2747 id => "infobox",
2748 title => "Look",
2749 reply => undef,
2750 tooltip => "What you saw there",
2751 },
2752 "c/who" => {
2753 id => "infobox",
2754 title => "Players",
2755 reply => undef,
2756 tooltip => "Shows players who are currently online",
2757 },
2758 "c/body" => {
2759 id => "infobox",
2760 title => "Body Parts",
2761 reply => undef,
2762 tooltip => "Shows which body parts you posess and are available",
2763 },
2764 "c/uptime" => {
2765 id => "infobox",
2766 title => "Uptime",
2767 reply => undef,
2768 tooltip => "How long the server has been running since last restart",
2769 },
2770 "c/mapinfo" => {
2771 id => "infobox",
2772 title => "Map Info",
2773 reply => undef,
2774 tooltip => "Information related to the maps",
2775 },
2776);
2777
2509sub cf::client::send_msg { 2778sub cf::client::send_msg {
2510 my ($self, $channel, $msg, $color, @extra) = @_; 2779 my ($self, $channel, $msg, $color, @extra) = @_;
2511 2780
2512 $msg = $self->pl->expand_cfpod ($msg); 2781 $msg = $self->pl->expand_cfpod ($msg);
2513 2782
2514 $color &= cf::NDI_CLIENT_MASK; # just in case... 2783 $color &= cf::NDI_CLIENT_MASK; # just in case...
2515 2784
2785 # check predefined channels, for the benefit of C
2786 if ($CHANNEL{$channel}) {
2787 $channel = $CHANNEL{$channel};
2788
2789 $self->ext_msg (channel_info => $channel)
2790 if $self->can_msg;
2791
2792 $channel = $channel->{id};
2793
2516 if (ref $channel) { 2794 } elsif (ref $channel) {
2517 # send meta info to client, if not yet sent 2795 # send meta info to client, if not yet sent
2518 unless (exists $self->{channel}{$channel->{id}}) { 2796 unless (exists $self->{channel}{$channel->{id}}) {
2519 $self->{channel}{$channel->{id}} = $channel; 2797 $self->{channel}{$channel->{id}} = $channel;
2520 $self->ext_msg (channel_info => $channel); 2798 $self->ext_msg (channel_info => $channel)
2799 if $self->can_msg;
2521 } 2800 }
2522 2801
2523 $channel = $channel->{id}; 2802 $channel = $channel->{id};
2524 } 2803 }
2525 2804
… …
2737=pod 3016=pod
2738 3017
2739The following functions and methods are available within a safe environment: 3018The following functions and methods are available within a safe environment:
2740 3019
2741 cf::object 3020 cf::object
2742 contr pay_amount pay_player map x y force_find force_add 3021 contr pay_amount pay_player map x y force_find force_add destroy
2743 insert remove name archname title slaying race decrease_ob_nr 3022 insert remove name archname title slaying race decrease_ob_nr
2744 3023
2745 cf::object::player 3024 cf::object::player
2746 player 3025 player
2747 3026
… …
2754=cut 3033=cut
2755 3034
2756for ( 3035for (
2757 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3036 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2758 insert remove inv name archname title slaying race 3037 insert remove inv name archname title slaying race
2759 decrease_ob_nr)], 3038 decrease_ob_nr destroy)],
2760 ["cf::object::player" => qw(player)], 3039 ["cf::object::player" => qw(player)],
2761 ["cf::player" => qw(peaceful)], 3040 ["cf::player" => qw(peaceful)],
2762 ["cf::map" => qw(trigger)], 3041 ["cf::map" => qw(trigger)],
2763) { 3042) {
2764 no strict 'refs'; 3043 no strict 'refs';
… …
3039sub main { 3318sub main {
3040 # we must not ever block the main coroutine 3319 # we must not ever block the main coroutine
3041 local $Coro::idle = sub { 3320 local $Coro::idle = sub {
3042 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3321 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3043 (async { 3322 (async {
3044 Event::one_event; 3323 $Coro::current->{desc} = "IDLE BUG HANDLER";
3324 EV::loop EV::LOOP_ONESHOT;
3045 })->prio (Coro::PRIO_MAX); 3325 })->prio (Coro::PRIO_MAX);
3046 }; 3326 };
3047 3327
3048 reload_config; 3328 reload_config;
3049 db_init; 3329 db_init;
3050 load_extensions; 3330 load_extensions;
3051 3331
3052 $TICK_WATCHER->start; 3332 $TICK_WATCHER->start;
3333 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3053 Event::loop; 3334 EV::loop;
3054} 3335}
3055 3336
3056############################################################################# 3337#############################################################################
3057# initialisation and cleanup 3338# initialisation and cleanup
3058 3339
3059# install some emergency cleanup handlers 3340# install some emergency cleanup handlers
3060BEGIN { 3341BEGIN {
3342 our %SIGWATCHER = ();
3061 for my $signal (qw(INT HUP TERM)) { 3343 for my $signal (qw(INT HUP TERM)) {
3062 Event->signal ( 3344 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3063 reentrant => 0,
3064 data => WF_AUTOCANCEL,
3065 signal => $signal,
3066 prio => 0,
3067 cb => sub {
3068 cf::cleanup "SIG$signal"; 3345 cf::cleanup "SIG$signal";
3069 },
3070 ); 3346 };
3071 } 3347 }
3072} 3348}
3073 3349
3074sub write_runtime { 3350sub write_runtime {
3075 my $runtime = "$LOCALDIR/runtime"; 3351 my $runtime = "$LOCALDIR/runtime";
… …
3120 # and maps saved/destroyed asynchronously. 3396 # and maps saved/destroyed asynchronously.
3121 warn "begin emergency player save\n"; 3397 warn "begin emergency player save\n";
3122 for my $login (keys %cf::PLAYER) { 3398 for my $login (keys %cf::PLAYER) {
3123 my $pl = $cf::PLAYER{$login} or next; 3399 my $pl = $cf::PLAYER{$login} or next;
3124 $pl->valid or next; 3400 $pl->valid or next;
3401 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3125 $pl->save; 3402 $pl->save;
3126 } 3403 }
3127 warn "end emergency player save\n"; 3404 warn "end emergency player save\n";
3128 3405
3129 warn "begin emergency map save\n"; 3406 warn "begin emergency map save\n";
… …
3168 warn "syncing database to disk"; 3445 warn "syncing database to disk";
3169 BDB::db_env_txn_checkpoint $DB_ENV; 3446 BDB::db_env_txn_checkpoint $DB_ENV;
3170 3447
3171 # if anything goes wrong in here, we should simply crash as we already saved 3448 # if anything goes wrong in here, we should simply crash as we already saved
3172 3449
3173 warn "cancelling all WF_AUTOCANCEL watchers";
3174 for (Event::all_watchers) {
3175 $_->cancel if $_->data & WF_AUTOCANCEL;
3176 }
3177
3178 warn "flushing outstanding aio requests"; 3450 warn "flushing outstanding aio requests";
3179 for (;;) { 3451 for (;;) {
3180 BDB::flush; 3452 BDB::flush;
3181 IO::AIO::flush; 3453 IO::AIO::flush;
3182 Coro::cede; 3454 Coro::cede_notself;
3183 last unless IO::AIO::nreqs || BDB::nreqs; 3455 last unless IO::AIO::nreqs || BDB::nreqs;
3184 warn "iterate..."; 3456 warn "iterate...";
3185 } 3457 }
3186 3458
3187 ++$RELOAD; 3459 ++$RELOAD;
… …
3276 3548
3277sub reload_perl() { 3549sub reload_perl() {
3278 # doing reload synchronously and two reloads happen back-to-back, 3550 # doing reload synchronously and two reloads happen back-to-back,
3279 # coro crashes during coro_state_free->destroy here. 3551 # coro crashes during coro_state_free->destroy here.
3280 3552
3281 $RELOAD_WATCHER ||= Event->timer ( 3553 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3282 reentrant => 0,
3283 after => 0,
3284 data => WF_AUTOCANCEL,
3285 cb => sub {
3286 do_reload_perl;
3287 undef $RELOAD_WATCHER; 3554 undef $RELOAD_WATCHER;
3288 }, 3555 do_reload_perl;
3289 ); 3556 };
3290} 3557}
3291 3558
3292register_command "reload" => sub { 3559register_command "reload" => sub {
3293 my ($who, $arg) = @_; 3560 my ($who, $arg) = @_;
3294 3561
3295 if ($who->flag (FLAG_WIZ)) { 3562 if ($who->flag (FLAG_WIZ)) {
3296 $who->message ("reloading server."); 3563 $who->message ("reloading server.");
3564 async {
3565 $Coro::current->{desc} = "perl_reload";
3297 async { reload_perl }; 3566 reload_perl;
3567 };
3298 } 3568 }
3299}; 3569};
3300 3570
3301unshift @INC, $LIBDIR; 3571unshift @INC, $LIBDIR;
3302 3572
… …
3321 my $signal = new Coro::Signal; 3591 my $signal = new Coro::Signal;
3322 push @WAIT_FOR_TICK_BEGIN, $signal; 3592 push @WAIT_FOR_TICK_BEGIN, $signal;
3323 $signal->wait; 3593 $signal->wait;
3324} 3594}
3325 3595
3326 my $min = 1e6;#d# 3596$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3327 my $avg = 10;
3328$TICK_WATCHER = Event->timer (
3329 reentrant => 0,
3330 parked => 1,
3331 prio => 0,
3332 at => $NEXT_TICK || $TICK,
3333 data => WF_AUTOCANCEL,
3334 cb => sub {
3335 if ($Coro::current != $Coro::main) { 3597 if ($Coro::current != $Coro::main) {
3336 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3598 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3337 unless ++$bug_warning > 10; 3599 unless ++$bug_warning > 10;
3338 return; 3600 return;
3339 } 3601 }
3340 3602
3341 $NOW = $tick_start = Event::time; 3603 $NOW = $tick_start = EV::now;
3342 3604
3343 cf::server_tick; # one server iteration 3605 cf::server_tick; # one server iteration
3344 3606
3345 0 && sync_job {#d# 3607 $RUNTIME += $TICK;
3346 for(1..10) { 3608 $NEXT_TICK += $TICK;
3347 my $t = Event::time;
3348 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3349 or die;
3350 3609
3351 $map->width (50); 3610 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3352 $map->height (50); 3611 $NEXT_RUNTIME_WRITE = $NOW + 10;
3353 $map->alloc; 3612 Coro::async_pool {
3354 $map->_load_objects ("/tmp/x.map", 1); 3613 $Coro::current->{desc} = "runtime saver";
3355 my $t = Event::time - $t; 3614 write_runtime
3356 3615 or warn "ERROR: unable to write runtime file: $!";
3357 #next unless $t < 0.0013;#d#
3358 if ($t < $min) {
3359 $min = $t;
3360 }
3361 $avg = $avg * 0.99 + $t * 0.01;
3362 }
3363 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3364 exit 0;
3365 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3366 }; 3616 };
3617 }
3367 3618
3368 $RUNTIME += $TICK;
3369 $NEXT_TICK += $TICK;
3370
3371 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3372 $NEXT_RUNTIME_WRITE = $NOW + 10;
3373 Coro::async_pool {
3374 write_runtime
3375 or warn "ERROR: unable to write runtime file: $!";
3376 };
3377 }
3378
3379# my $AFTER = Event::time;
3380# warn $AFTER - $NOW;#d#
3381
3382 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3619 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3383 $sig->send; 3620 $sig->send;
3384 } 3621 }
3385 while (my $sig = shift @WAIT_FOR_TICK) { 3622 while (my $sig = shift @WAIT_FOR_TICK) {
3386 $sig->send; 3623 $sig->send;
3387 } 3624 }
3388 3625
3389 $NOW = Event::time;
3390
3391 # if we are delayed by four ticks or more, skip them all
3392 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3393
3394 $TICK_WATCHER->at ($NEXT_TICK);
3395 $TICK_WATCHER->start;
3396
3397 $LOAD = ($NOW - $tick_start) / $TICK; 3626 $LOAD = ($NOW - $tick_start) / $TICK;
3398 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3627 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3399 3628
3400 _post_tick; 3629 _post_tick;
3401 3630};
3402 3631$TICK_WATCHER->priority (EV::MAXPRI);
3403 },
3404);
3405 3632
3406{ 3633{
3634 BDB::min_parallel 8;
3407 BDB::max_poll_time $TICK * 0.1; 3635 BDB::max_poll_time $TICK * 0.1;
3408 $BDB_POLL_WATCHER = Event->io ( 3636 $BDB_POLL_WATCHER = EV::io BDB::poll_fileno, EV::READ, \&BDB::poll_cb;
3409 reentrant => 0,
3410 fd => BDB::poll_fileno,
3411 poll => 'r',
3412 prio => 0,
3413 data => WF_AUTOCANCEL,
3414 cb => \&BDB::poll_cb,
3415 );
3416 BDB::min_parallel 8;
3417 3637
3418 BDB::set_sync_prepare { 3638 BDB::set_sync_prepare {
3419 my $status; 3639 my $status;
3420 my $current = $Coro::current; 3640 my $current = $Coro::current;
3421 ( 3641 (
… …
3430 ) 3650 )
3431 }; 3651 };
3432 3652
3433 unless ($DB_ENV) { 3653 unless ($DB_ENV) {
3434 $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);
3435 3659
3436 cf::sync_job { 3660 cf::sync_job {
3437 eval { 3661 eval {
3438 BDB::db_env_open 3662 BDB::db_env_open
3439 $DB_ENV, 3663 $DB_ENV,
… …
3441 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
3442 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3666 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3443 0666; 3667 0666;
3444 3668
3445 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3669 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3446
3447 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3448 $DB_ENV->set_lk_detect;
3449 }; 3670 };
3450 3671
3451 cf::cleanup "db_env_open(db): $@" if $@; 3672 cf::cleanup "db_env_open(db): $@" if $@;
3452 }; 3673 };
3453 } 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 };
3454} 3685}
3455 3686
3456{ 3687{
3457 IO::AIO::min_parallel 8; 3688 IO::AIO::min_parallel 8;
3458 3689
3459 undef $Coro::AIO::WATCHER; 3690 undef $Coro::AIO::WATCHER;
3460 IO::AIO::max_poll_time $TICK * 0.1; 3691 IO::AIO::max_poll_time $TICK * 0.1;
3461 $AIO_POLL_WATCHER = Event->io ( 3692 $AIO_POLL_WATCHER = EV::io IO::AIO::poll_fileno, EV::READ, \&IO::AIO::poll_cb;
3462 reentrant => 0,
3463 data => WF_AUTOCANCEL,
3464 fd => IO::AIO::poll_fileno,
3465 poll => 'r',
3466 prio => 6,
3467 cb => \&IO::AIO::poll_cb,
3468 );
3469} 3693}
3470 3694
3471my $_log_backtrace; 3695my $_log_backtrace;
3472 3696
3473sub _log_backtrace { 3697sub _log_backtrace {
… …
3477 3701
3478 # limit the # of concurrent backtraces 3702 # limit the # of concurrent backtraces
3479 if ($_log_backtrace < 2) { 3703 if ($_log_backtrace < 2) {
3480 ++$_log_backtrace; 3704 ++$_log_backtrace;
3481 async { 3705 async {
3706 $Coro::current->{desc} = "abt $msg";
3707
3482 my @bt = fork_call { 3708 my @bt = fork_call {
3483 @addr = map { sprintf "%x", $_ } @addr; 3709 @addr = map { sprintf "%x", $_ } @addr;
3484 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3710 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3485 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 |"
3486 or die "addr2line: $!"; 3712 or die "addr2line: $!";

Diff Legend

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