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.346 by root, Tue Aug 28 19:38:40 2007 UTC vs.
Revision 1.396 by root, Wed Nov 14 08:09:46 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;
… …
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
… …
272Wait until the given lock is available and then acquires it and returns 272Wait until the given lock is available and then acquires it and returns
273a Coro::guard object. If the guard object gets destroyed (goes out of scope, 273a Coro::guard object. If the guard object gets destroyed (goes out of scope,
274for example when the coroutine gets canceled), the lock is automatically 274for example when the coroutine gets canceled), the lock is automatically
275returned. 275returned.
276 276
277Locks are *not* recursive, locking from the same coro twice results in a
278deadlocked coro.
279
277Lock names should begin with a unique identifier (for example, cf::map::find 280Lock names should begin with a unique identifier (for example, cf::map::find
278uses map_find and cf::map::load uses map_load). 281uses map_find and cf::map::load uses map_load).
279 282
280=item $locked = cf::lock_active $string 283=item $locked = cf::lock_active $string
281 284
282Return 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.
283 286
284=cut 287=cut
285 288
286our %LOCK; 289our %LOCK;
290our %LOCKER;#d#
287 291
288sub lock_wait($) { 292sub lock_wait($) {
289 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#
290 299
291 # wait for lock, if any 300 # wait for lock, if any
292 while ($LOCK{$key}) { 301 while ($LOCK{$key}) {
293 push @{ $LOCK{$key} }, $Coro::current; 302 push @{ $LOCK{$key} }, $Coro::current;
294 Coro::schedule; 303 Coro::schedule;
… …
300 309
301 # wait, to be sure we are not locked 310 # wait, to be sure we are not locked
302 lock_wait $key; 311 lock_wait $key;
303 312
304 $LOCK{$key} = []; 313 $LOCK{$key} = [];
314 $LOCKER{$key} = $Coro::current;#d#
305 315
306 Coro::guard { 316 Coro::guard {
317 delete $LOCKER{$key};#d#
307 # wake up all waiters, to be on the safe side 318 # wake up all waiters, to be on the safe side
308 $_->ready for @{ delete $LOCK{$key} }; 319 $_->ready for @{ delete $LOCK{$key} };
309 } 320 }
310} 321}
311 322
… …
323 }; 334 };
324 $TICK_WATCHER->stop; 335 $TICK_WATCHER->stop;
325 $guard 336 $guard
326} 337}
327 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
328=item cf::get_slot $time[, $priority[, $name]] 354=item cf::get_slot $time[, $priority[, $name]]
329 355
330Allocate $time seconds of blocking CPU time at priority C<$priority>: 356Allocate $time seconds of blocking CPU time at priority C<$priority>:
331This 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
332of 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.
… …
341our @SLOT_QUEUE; 367our @SLOT_QUEUE;
342our $SLOT_QUEUE; 368our $SLOT_QUEUE;
343 369
344$SLOT_QUEUE->cancel if $SLOT_QUEUE; 370$SLOT_QUEUE->cancel if $SLOT_QUEUE;
345$SLOT_QUEUE = Coro::async { 371$SLOT_QUEUE = Coro::async {
372 $Coro::current->desc ("timeslot manager");
373
346 my $signal = new Coro::Signal; 374 my $signal = new Coro::Signal;
347 375
348 while () { 376 while () {
349 next_job: 377 next_job:
350 my $avail = cf::till_tick; 378 my $avail = cf::till_tick;
… …
358 } 386 }
359 } 387 }
360 } 388 }
361 389
362 if (@SLOT_QUEUE) { 390 if (@SLOT_QUEUE) {
363 # 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
364 push @cf::WAIT_FOR_TICK, $signal; 392 push @cf::WAIT_FOR_TICK, $signal;
365 $signal->wait; 393 $signal->wait;
366 } else { 394 } else {
367 Coro::schedule; 395 Coro::schedule;
368 } 396 }
… …
391 419
392BEGIN { *async = \&Coro::async_pool } 420BEGIN { *async = \&Coro::async_pool }
393 421
394=item cf::sync_job { BLOCK } 422=item cf::sync_job { BLOCK }
395 423
396The design of Crossfire TRT requires that the main coroutine ($Coro::main) 424The design of Deliantra requires that the main coroutine ($Coro::main)
397is always able to handle events or runnable, as Crossfire TRT is only 425is always able to handle events or runnable, as Deliantra is only
398partly 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
399acceptable. 427acceptable.
400 428
401If 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
402the given BLOCK in another coroutine while waiting for the result. The 430the given BLOCK in another coroutine while waiting for the result. The
… …
407 435
408sub sync_job(&) { 436sub sync_job(&) {
409 my ($job) = @_; 437 my ($job) = @_;
410 438
411 if ($Coro::current == $Coro::main) { 439 if ($Coro::current == $Coro::main) {
412 my $time = Event::time; 440 my $time = EV::time;
413 441
414 # this is the main coro, too bad, we have to block 442 # this is the main coro, too bad, we have to block
415 # till the operation succeeds, freezing the server :/ 443 # till the operation succeeds, freezing the server :/
416 444
445 LOG llevError, Carp::longmess "sync job";#d#
446
417 # TODO: use suspend/resume instead 447 # TODO: use suspend/resume instead
418 # (but this is cancel-safe) 448 # (but this is cancel-safe)
419 my $freeze_guard = freeze_mainloop; 449 my $freeze_guard = freeze_mainloop;
420 450
421 my $busy = 1; 451 my $busy = 1;
422 my @res; 452 my @res;
423 453
424 (async { 454 (async {
455 $Coro::current->desc ("sync job coro");
425 @res = eval { $job->() }; 456 @res = eval { $job->() };
426 warn $@ if $@; 457 warn $@ if $@;
427 undef $busy; 458 undef $busy;
428 })->prio (Coro::PRIO_MAX); 459 })->prio (Coro::PRIO_MAX);
429 460
430 while ($busy) { 461 while ($busy) {
431 Coro::cede or Event::one_event; 462 if (Coro::nready) {
463 Coro::cede_notself;
464 } else {
465 EV::loop EV::LOOP_ONESHOT;
432 } 466 }
467 }
433 468
434 $time = Event::time - $time; 469 $time = EV::time - $time;
435 470
436 LOG llevError | logBacktrace, Carp::longmess "long sync job" 471 LOG llevError | logBacktrace, Carp::longmess "long sync job"
437 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active; 472 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
438 473
439 $tick_start += $time; # do not account sync jobs to server load 474 $tick_start += $time; # do not account sync jobs to server load
… …
469=item fork_call { }, $args 504=item fork_call { }, $args
470 505
471Executes the given code block with the given arguments in a seperate 506Executes the given code block with the given arguments in a seperate
472process, returning the results. Everything must be serialisable with 507process, returning the results. Everything must be serialisable with
473Coro::Storable. May, of course, block. Note that the executed sub may 508Coro::Storable. May, of course, block. Note that the executed sub may
474never block itself or use any form of Event handling. 509never block itself or use any form of event handling.
475 510
476=cut 511=cut
477 512
478sub fork_call(&@) { 513sub fork_call(&@) {
479 my ($cb, @args) = @_; 514 my ($cb, @args) = @_;
480 515
481 # 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,
482 # otherwise perl prematurely frees the stuff :/ 517 # otherwise perl prematurely frees the stuff :/
483 # TODO: investigate and fix (liekly this will be rather laborious) 518 # TODO: investigate and fix (likely this will be rather laborious)
484 519
485 my @res = Coro::Util::fork_eval { 520 my @res = Coro::Util::fork_eval {
486 reset_signals; 521 reset_signals;
487 &$cb 522 &$cb
488 }, @args; 523 }, @args;
… …
497=item cf::db_put $family => $key => $value 532=item cf::db_put $family => $key => $value
498 533
499Stores 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
500data 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).
501 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
502=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}
503 560
504our $DB; 561our $DB;
505 562
506sub db_init { 563sub db_init {
507 unless ($DB) {
508 $DB = BDB::db_create $DB_ENV;
509
510 cf::sync_job { 564 cf::sync_job {
511 eval { 565 $DB ||= db_table "db";
512 $DB->set_flags (BDB::CHKSUM);
513
514 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
515 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
516 cf::cleanup "db_open(db): $!" if $!;
517 };
518 cf::cleanup "db_open(db): $@" if $@;
519 };
520 } 566 };
521} 567}
522 568
523sub db_get($$) { 569sub db_get($$) {
524 my $key = "$_[0]/$_[1]"; 570 my $key = "$_[0]/$_[1]";
525 571
… …
629attach callbacks/event handlers (a collection of which is called an "attachment") 675attach callbacks/event handlers (a collection of which is called an "attachment")
630to it. All such attachable objects support the following methods. 676to it. All such attachable objects support the following methods.
631 677
632In 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>
633C<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
634Crossfire TRT). 680Deliantra).
635 681
636=over 4 682=over 4
637 683
638=item $attachable->attach ($attachment, key => $value...) 684=item $attachable->attach ($attachment, key => $value...)
639 685
… …
937 983
938=cut 984=cut
939 985
940############################################################################# 986#############################################################################
941# object support 987# object support
942#
943 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#
944sub _can_merge { 1022sub _can_merge {
945 my ($ob1, $ob2) = @_; 1023 my ($ob1, $ob2) = @_;
946 1024
947 local $Storable::canonical = 1; 1025 ++$SLOW_MERGES;#d#
948 my $fob1 = Storable::freeze $ob1;
949 my $fob2 = Storable::freeze $ob2;
950 1026
951 $fob1 eq $fob2 1027 # we do the slow way here
1028 return _object_equal $ob1, $ob2
952} 1029}
953 1030
954sub reattach { 1031sub reattach {
955 # basically do the same as instantiate, without calling instantiate 1032 # basically do the same as instantiate, without calling instantiate
956 my ($obj) = @_; 1033 my ($obj) = @_;
… …
1004sub object_freezer_save { 1081sub object_freezer_save {
1005 my ($filename, $rdata, $objs) = @_; 1082 my ($filename, $rdata, $objs) = @_;
1006 1083
1007 sync_job { 1084 sync_job {
1008 if (length $$rdata) { 1085 if (length $$rdata) {
1086 utf8::decode (my $decname = $filename);
1009 warn sprintf "saving %s (%d,%d)\n", 1087 warn sprintf "saving %s (%d,%d)\n",
1010 $filename, length $$rdata, scalar @$objs; 1088 $decname, length $$rdata, scalar @$objs;
1011 1089
1012 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1090 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1013 chmod SAVE_MODE, $fh; 1091 chmod SAVE_MODE, $fh;
1014 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1092 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1015 aio_fsync $fh if $cf::USE_FSYNC; 1093 aio_fsync $fh if $cf::USE_FSYNC;
1016 close $fh; 1094 close $fh;
1017 1095
1018 if (@$objs) { 1096 if (@$objs) {
1019 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) {
1020 chmod SAVE_MODE, $fh; 1098 chmod SAVE_MODE, $fh;
1021 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1099 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1022 aio_write $fh, 0, (length $data), $data, 0; 1100 aio_write $fh, 0, (length $data), $data, 0;
1023 aio_fsync $fh if $cf::USE_FSYNC; 1101 aio_fsync $fh if $cf::USE_FSYNC;
1024 close $fh; 1102 close $fh;
1025 aio_rename "$filename.pst~", "$filename.pst"; 1103 aio_rename "$filename.pst~", "$filename.pst";
1026 } 1104 }
… …
1034 } 1112 }
1035 } else { 1113 } else {
1036 aio_unlink $filename; 1114 aio_unlink $filename;
1037 aio_unlink "$filename.pst"; 1115 aio_unlink "$filename.pst";
1038 } 1116 }
1039 } 1117 };
1040} 1118}
1041 1119
1042sub object_freezer_as_string { 1120sub object_freezer_as_string {
1043 my ($rdata, $objs) = @_; 1121 my ($rdata, $objs) = @_;
1044 1122
… …
1056 or return; 1134 or return;
1057 1135
1058 unless (aio_stat "$filename.pst") { 1136 unless (aio_stat "$filename.pst") {
1059 (aio_load "$filename.pst", $av) >= 0 1137 (aio_load "$filename.pst", $av) >= 0
1060 or return; 1138 or return;
1139
1061 $av = eval { (Storable::thaw $av)->{objs} }; 1140 my $st = eval { Coro::Storable::thaw $av };
1141 $av = $st->{objs};
1062 } 1142 }
1063 1143
1144 utf8::decode (my $decname = $filename);
1064 warn sprintf "loading %s (%d)\n", 1145 warn sprintf "loading %s (%d,%d)\n",
1065 $filename, length $data, scalar @{$av || []}; 1146 $decname, length $data, scalar @{$av || []};
1147
1066 return ($data, $av); 1148 ($data, $av)
1067} 1149}
1068 1150
1069=head2 COMMAND CALLBACKS 1151=head2 COMMAND CALLBACKS
1070 1152
1071=over 4 1153=over 4
… …
1257 1339
1258=head3 cf::player 1340=head3 cf::player
1259 1341
1260=over 4 1342=over 4
1261 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
1262=item cf::player::find $login 1358=item cf::player::find $login
1263 1359
1264Returns the given player object, loading it if necessary (might block). 1360Returns the given player object, loading it if necessary (might block).
1265 1361
1266=cut 1362=cut
… …
1301 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1397 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1302 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1398 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1303 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1399 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1304 aio_unlink +(playerdir $login) . "/$login.pl"; 1400 aio_unlink +(playerdir $login) . "/$login.pl";
1305 1401
1306 my $pl = load_pl path $login 1402 my $f = new_from_file cf::object::thawer path $login
1307 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;
1308 $cf::PLAYER{$login} = $pl 1409 $cf::PLAYER{$login} = $pl
1309 } 1410 }
1310 } 1411 }
1311} 1412}
1312 1413
… …
1410 or return []; 1511 or return [];
1411 1512
1412 my @logins; 1513 my @logins;
1413 1514
1414 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") {
1415 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1520 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1416 aio_read $fh, 0, 512, my $buf, 0 or next; 1521 aio_read $fh, 0, 512, my $buf, 0 or next;
1417 $buf !~ /^password -------------$/m or next; # official not-valid tag 1522 $buf !~ /^password -------------$/m or next; # official not-valid tag
1523 }
1418 1524
1419 utf8::decode $login; 1525 utf8::decode $login;
1420 push @logins, $login; 1526 push @logins, $login;
1421 } 1527 }
1422 1528
… …
1455 1561
1456Expand crossfire pod fragments into protocol xml. 1562Expand crossfire pod fragments into protocol xml.
1457 1563
1458=cut 1564=cut
1459 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
1460sub expand_cfpod { 1577sub expand_cfpod {
1461 ((my $self), (local $_)) = @_; 1578 my ($self, $pod) = @_;
1462 1579
1463 # escape & and < 1580 my $xml;
1464 s/&/&amp;/g;
1465 s/(?<![BIUGH])</&lt;/g;
1466 1581
1467 # this is buggy, it needs to properly take care of nested <'s 1582 while () {
1583 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1584 $group = $1;
1468 1585
1469 1 while 1586 $group =~ s/&/&amp;/g;
1470 # replace B<>, I<>, U<> etc. 1587 $group =~ s/</&lt;/g;
1471 s/B<([^\>]*)>/<b>$1<\/b>/ 1588
1472 || s/I<([^\>]*)>/<i>$1<\/i>/ 1589 $xml .= $group;
1473 || s/U<([^\>]*)>/<u>$1<\/u>/ 1590 } elsif ($pod =~ m%\G
1474 # replace G<male|female> tags 1591 ([BCGHITU])
1475 || s{G<([^>|]*)\|([^>]*)>}{ 1592 <
1476 $self->gender ? $2 : $1 1593 (?:
1477 }ge 1594 ([^<>]*) (?{ $group = $^N })
1478 # replace H<hint text> 1595 | < $interior >
1479 || s{H<([^\>]*)>} 1596 )
1597 >
1598 %gcsx
1480 { 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") {
1481 ("<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>",
1482 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1618 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1483 "") 1619 "")
1484 [$self->{hintmode}] 1620 [$self->{hintmode}];
1621 } else {
1622 $xml .= "error processing '$code($data)' directive";
1485 }ge; 1623 }
1624 } else {
1625 if ($pod =~ /\G(.+)/) {
1626 warn "parse error while expanding $pod (at $1)";
1627 }
1628 last;
1629 }
1630 }
1486 1631
1632 for ($xml) {
1487 # create single paragraphs (very hackish) 1633 # create single paragraphs (very hackish)
1488 s/(?<=\S)\n(?=\w)/ /g; 1634 s/(?<=\S)\n(?=\w)/ /g;
1489 1635
1490 # compress some whitespace 1636 # compress some whitespace
1491 s/\s+\n/\n/g; # ws line-ends 1637 s/\s+\n/\n/g; # ws line-ends
1492 s/\n\n+/\n/g; # double lines 1638 s/\n\n+/\n/g; # double lines
1493 s/^\n+//; # beginning lines 1639 s/^\n+//; # beginning lines
1494 s/\n+$//; # ending lines 1640 s/\n+$//; # ending lines
1641 }
1495 1642
1496 $_ 1643 $xml
1497} 1644}
1645
1646no re 'eval';
1498 1647
1499sub hintmode { 1648sub hintmode {
1500 $_[0]{hintmode} = $_[1] if @_ > 1; 1649 $_[0]{hintmode} = $_[1] if @_ > 1;
1501 $_[0]{hintmode} 1650 $_[0]{hintmode}
1502} 1651}
… …
1746 1895
1747sub load_header_from($) { 1896sub load_header_from($) {
1748 my ($self, $path) = @_; 1897 my ($self, $path) = @_;
1749 1898
1750 utf8::encode $path; 1899 utf8::encode $path;
1751 #aio_open $path, O_RDONLY, 0 1900 my $f = new_from_file cf::object::thawer $path
1752 # or return;
1753
1754 $self->_load_header ($path)
1755 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;
1756 1908
1757 $self->{load_path} = $path; 1909 $self->{load_path} = $path;
1758 1910
1759 1 1911 1
1760} 1912}
… …
1814sub find { 1966sub find {
1815 my ($path, $origin) = @_; 1967 my ($path, $origin) = @_;
1816 1968
1817 $path = normalise $path, $origin && $origin->path; 1969 $path = normalise $path, $origin && $origin->path;
1818 1970
1971 cf::lock_wait "map_data:$path";#d#remove
1819 cf::lock_wait "map_find:$path"; 1972 cf::lock_wait "map_find:$path";
1820 1973
1821 $cf::MAP{$path} || do { 1974 $cf::MAP{$path} || do {
1822 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
1823 my $map = new_from_path cf::map $path 1978 my $map = new_from_path cf::map $path
1824 or return; 1979 or return;
1825 1980
1826 $map->{last_save} = $cf::RUNTIME; 1981 $map->{last_save} = $cf::RUNTIME;
1827 1982
… …
1829 or return; 1984 or return;
1830 1985
1831 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1986 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1832 # doing this can freeze the server in a sync job, obviously 1987 # doing this can freeze the server in a sync job, obviously
1833 #$cf::WAIT_FOR_TICK->wait; 1988 #$cf::WAIT_FOR_TICK->wait;
1989 undef $guard1;
1990 undef $guard2;
1834 $map->reset; 1991 $map->reset;
1835 undef $guard;
1836 return find $path; 1992 return find $path;
1837 } 1993 }
1838 1994
1839 $cf::MAP{$path} = $map 1995 $cf::MAP{$path} = $map
1840 } 1996 }
… …
1849 local $self->{deny_reset} = 1; # loading can take a long time 2005 local $self->{deny_reset} = 1; # loading can take a long time
1850 2006
1851 my $path = $self->{path}; 2007 my $path = $self->{path};
1852 2008
1853 { 2009 {
1854 my $guard1 = cf::lock_acquire "map_data:$path"; 2010 my $guard = cf::lock_acquire "map_data:$path";
1855 my $guard2 = cf::lock_acquire "map_load:$path";
1856 2011
2012 return unless $self->valid;
1857 return if $self->in_memory != cf::MAP_SWAPPED; 2013 return unless $self->in_memory == cf::MAP_SWAPPED;
1858 2014
1859 $self->in_memory (cf::MAP_LOADING); 2015 $self->in_memory (cf::MAP_LOADING);
1860 2016
1861 $self->alloc; 2017 $self->alloc;
1862 2018
1863 $self->pre_load; 2019 $self->pre_load;
1864 cf::cede_to_tick; 2020 cf::cede_to_tick;
1865 2021
2022 my $f = new_from_file cf::object::thawer $self->{load_path};
2023 $f->skip_block;
1866 $self->_load_objects ($self->{load_path}, 1) 2024 $self->_load_objects ($f)
1867 or return; 2025 or return;
1868 2026
1869 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2027 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1870 if delete $self->{load_original}; 2028 if delete $self->{load_original};
1871 2029
1872 if (my $uniq = $self->uniq_path) { 2030 if (my $uniq = $self->uniq_path) {
1873 utf8::encode $uniq; 2031 utf8::encode $uniq;
1874 if (aio_open $uniq, O_RDONLY, 0) { 2032 unless (aio_stat $uniq) {
2033 if (my $f = new_from_file cf::object::thawer $uniq) {
1875 $self->clear_unique_items; 2034 $self->clear_unique_items;
1876 $self->_load_objects ($uniq, 0); 2035 $self->_load_objects ($f);
2036 $f->resolve_delayed_derefs;
2037 }
1877 } 2038 }
1878 } 2039 }
2040
2041 $f->resolve_delayed_derefs;
1879 2042
1880 cf::cede_to_tick; 2043 cf::cede_to_tick;
1881 # now do the right thing for maps 2044 # now do the right thing for maps
1882 $self->link_multipart_objects; 2045 $self->link_multipart_objects;
1883 $self->difficulty ($self->estimate_difficulty) 2046 $self->difficulty ($self->estimate_difficulty)
… …
1969 } 2132 }
1970 2133
1971 $MAP_PREFETCH{$path} |= $load; 2134 $MAP_PREFETCH{$path} |= $load;
1972 2135
1973 $MAP_PREFETCHER ||= cf::async { 2136 $MAP_PREFETCHER ||= cf::async {
2137 $Coro::current->{desc} = "map prefetcher";
2138
1974 while (%MAP_PREFETCH) { 2139 while (%MAP_PREFETCH) {
1975 while (my ($k, $v) = each %MAP_PREFETCH) { 2140 while (my ($k, $v) = each %MAP_PREFETCH) {
1976 if (my $map = find $k) { 2141 if (my $map = find $k) {
1977 $map->load if $v; 2142 $map->load if $v;
1978 } 2143 }
… …
2004 return if $self->{deny_save}; 2169 return if $self->{deny_save};
2005 2170
2006 local $self->{last_access} = $self->last_access;#d# 2171 local $self->{last_access} = $self->last_access;#d#
2007 2172
2008 cf::async { 2173 cf::async {
2174 $Coro::current->{desc} = "map player save";
2009 $_->contr->save for $self->players; 2175 $_->contr->save for $self->players;
2010 }; 2176 };
2011 2177
2012 if ($uniq) { 2178 if ($uniq) {
2013 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2179 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
2027 2193
2028 return if $self->players; 2194 return if $self->players;
2029 return if $self->in_memory != cf::MAP_IN_MEMORY; 2195 return if $self->in_memory != cf::MAP_IN_MEMORY;
2030 return if $self->{deny_save}; 2196 return if $self->{deny_save};
2031 2197
2198 $self->in_memory (cf::MAP_SWAPPED);
2199
2200 $self->deactivate;
2201 $_->clear_links_to ($self) for values %cf::MAP;
2032 $self->clear; 2202 $self->clear;
2033 $self->in_memory (cf::MAP_SWAPPED);
2034} 2203}
2035 2204
2036sub reset_at { 2205sub reset_at {
2037 my ($self) = @_; 2206 my ($self) = @_;
2038 2207
… …
2070 if $uniq; 2239 if $uniq;
2071 } 2240 }
2072 2241
2073 delete $cf::MAP{$self->path}; 2242 delete $cf::MAP{$self->path};
2074 2243
2244 $self->deactivate;
2245 $_->clear_links_to ($self) for values %cf::MAP;
2075 $self->clear; 2246 $self->clear;
2076
2077 $_->clear_links_to ($self) for values %cf::MAP;
2078 2247
2079 $self->unlink_save; 2248 $self->unlink_save;
2080 $self->destroy; 2249 $self->destroy;
2081} 2250}
2082 2251
2083my $nuke_counter = "aaaa"; 2252my $nuke_counter = "aaaa";
2084 2253
2085sub nuke { 2254sub nuke {
2086 my ($self) = @_; 2255 my ($self) = @_;
2087 2256
2257 {
2258 my $lock = cf::lock_acquire "map_data:$self->{path}";
2259
2088 delete $cf::MAP{$self->path}; 2260 delete $cf::MAP{$self->path};
2089 2261
2090 $self->unlink_save; 2262 $self->unlink_save;
2091 2263
2092 bless $self, "cf::map"; 2264 bless $self, "cf::map";
2093 delete $self->{deny_reset}; 2265 delete $self->{deny_reset};
2094 $self->{deny_save} = 1; 2266 $self->{deny_save} = 1;
2095 $self->reset_timeout (1); 2267 $self->reset_timeout (1);
2096 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2268 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2097 2269
2098 $cf::MAP{$self->path} = $self; 2270 $cf::MAP{$self->path} = $self;
2271 }
2099 2272
2100 $self->reset; # polite request, might not happen 2273 $self->reset; # polite request, might not happen
2101} 2274}
2102 2275
2103=item $maps = cf::map::tmp_maps 2276=item $maps = cf::map::tmp_maps
… …
2179 2352
2180sub inv_recursive { 2353sub inv_recursive {
2181 inv_recursive_ inv $_[0] 2354 inv_recursive_ inv $_[0]
2182} 2355}
2183 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
2184package cf; 2385package cf;
2185 2386
2186=back 2387=back
2187 2388
2188=head3 cf::object::player 2389=head3 cf::object::player
… …
2346 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2547 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2347 2548
2348 $self->enter_link; 2549 $self->enter_link;
2349 2550
2350 (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
2351 my $map = eval { 2573 my $map = eval {
2352 my $map = cf::map::find $path; 2574 my $map = defined $path ? cf::map::find $path : undef;
2353 2575
2354 if ($map) { 2576 if ($map) {
2355 $map = $map->customise_for ($self); 2577 $map = $map->customise_for ($self);
2356 $map = $check->($map) if $check && $map; 2578 $map = $check->($map) if $check && $map;
2357 } else { 2579 } else {
2358 $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);
2359 } 2581 }
2360 2582
2361 $map 2583 $map
2362 }; 2584 };
2363 2585
… …
2453 # if exit is damned, update players death & WoR home-position 2675 # if exit is damned, update players death & WoR home-position
2454 $self->contr->savebed ($slaying, $hp, $sp) 2676 $self->contr->savebed ($slaying, $hp, $sp)
2455 if $exit->flag (FLAG_DAMNED); 2677 if $exit->flag (FLAG_DAMNED);
2456 2678
2457 (async { 2679 (async {
2680 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2681
2458 $self->deactivate_recursive; # just to be sure 2682 $self->deactivate_recursive; # just to be sure
2459 unless (eval { 2683 unless (eval {
2460 $self->goto ($slaying, $hp, $sp); 2684 $self->goto ($slaying, $hp, $sp);
2461 2685
2462 1; 2686 1;
… …
2497the 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
2498the message unless the client supports the msg packet. 2722the message unless the client supports the msg packet.
2499 2723
2500=cut 2724=cut
2501 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
2502sub cf::client::send_msg { 2778sub cf::client::send_msg {
2503 my ($self, $channel, $msg, $color, @extra) = @_; 2779 my ($self, $channel, $msg, $color, @extra) = @_;
2504 2780
2505 $msg = $self->pl->expand_cfpod ($msg); 2781 $msg = $self->pl->expand_cfpod ($msg);
2506 2782
2507 $color &= cf::NDI_CLIENT_MASK; # just in case... 2783 $color &= cf::NDI_CLIENT_MASK; # just in case...
2508 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
2509 if (ref $channel) { 2794 } elsif (ref $channel) {
2510 # send meta info to client, if not yet sent 2795 # send meta info to client, if not yet sent
2511 unless (exists $self->{channel}{$channel->{id}}) { 2796 unless (exists $self->{channel}{$channel->{id}}) {
2512 $self->{channel}{$channel->{id}} = $channel; 2797 $self->{channel}{$channel->{id}} = $channel;
2513 $self->ext_msg (channel_info => $channel); 2798 $self->ext_msg (channel_info => $channel)
2799 if $self->can_msg;
2514 } 2800 }
2515 2801
2516 $channel = $channel->{id}; 2802 $channel = $channel->{id};
2517 } 2803 }
2518 2804
… …
2730=pod 3016=pod
2731 3017
2732The following functions and methods are available within a safe environment: 3018The following functions and methods are available within a safe environment:
2733 3019
2734 cf::object 3020 cf::object
2735 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
2736 insert remove name archname title slaying race decrease_ob_nr 3022 insert remove name archname title slaying race decrease_ob_nr
2737 3023
2738 cf::object::player 3024 cf::object::player
2739 player 3025 player
2740 3026
… …
2747=cut 3033=cut
2748 3034
2749for ( 3035for (
2750 ["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
2751 insert remove inv name archname title slaying race 3037 insert remove inv name archname title slaying race
2752 decrease_ob_nr)], 3038 decrease_ob_nr destroy)],
2753 ["cf::object::player" => qw(player)], 3039 ["cf::object::player" => qw(player)],
2754 ["cf::player" => qw(peaceful)], 3040 ["cf::player" => qw(peaceful)],
2755 ["cf::map" => qw(trigger)], 3041 ["cf::map" => qw(trigger)],
2756) { 3042) {
2757 no strict 'refs'; 3043 no strict 'refs';
… …
2832############################################################################# 3118#############################################################################
2833# the server's init and main functions 3119# the server's init and main functions
2834 3120
2835sub load_facedata($) { 3121sub load_facedata($) {
2836 my ($path) = @_; 3122 my ($path) = @_;
3123
3124 # HACK to clear player env face cache, we need some signal framework
3125 # for this (global event?)
3126 %ext::player_env::MUSIC_FACE_CACHE = ();
2837 3127
2838 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3128 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2839 3129
2840 warn "loading facedata from $path\n"; 3130 warn "loading facedata from $path\n";
2841 3131
… …
2953 $ns->fx_want ($k, $v); 3243 $ns->fx_want ($k, $v);
2954 } 3244 }
2955}; 3245};
2956 3246
2957sub reload_regions { 3247sub reload_regions {
3248 # HACK to clear player env face cache, we need some signal framework
3249 # for this (global event?)
3250 %ext::player_env::MUSIC_FACE_CACHE = ();
3251
2958 load_resource_file "$MAPDIR/regions" 3252 load_resource_file "$MAPDIR/regions"
2959 or die "unable to load regions file\n"; 3253 or die "unable to load regions file\n";
2960 3254
2961 for (cf::region::list) { 3255 for (cf::region::list) {
2962 $_->{match} = qr/$_->{match}/ 3256 $_->{match} = qr/$_->{match}/
… …
3024sub main { 3318sub main {
3025 # we must not ever block the main coroutine 3319 # we must not ever block the main coroutine
3026 local $Coro::idle = sub { 3320 local $Coro::idle = sub {
3027 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#
3028 (async { 3322 (async {
3029 Event::one_event; 3323 $Coro::current->{desc} = "IDLE BUG HANDLER";
3324 EV::loop EV::LOOP_ONESHOT;
3030 })->prio (Coro::PRIO_MAX); 3325 })->prio (Coro::PRIO_MAX);
3031 }; 3326 };
3032 3327
3033 reload_config; 3328 reload_config;
3034 db_init; 3329 db_init;
3035 load_extensions; 3330 load_extensions;
3036 3331
3037 $TICK_WATCHER->start; 3332 $TICK_WATCHER->start;
3038 Event::loop; 3333 EV::loop;
3039} 3334}
3040 3335
3041############################################################################# 3336#############################################################################
3042# initialisation and cleanup 3337# initialisation and cleanup
3043 3338
3044# install some emergency cleanup handlers 3339# install some emergency cleanup handlers
3045BEGIN { 3340BEGIN {
3341 our %SIGWATCHER = ();
3046 for my $signal (qw(INT HUP TERM)) { 3342 for my $signal (qw(INT HUP TERM)) {
3047 Event->signal ( 3343 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3048 reentrant => 0,
3049 data => WF_AUTOCANCEL,
3050 signal => $signal,
3051 prio => 0,
3052 cb => sub {
3053 cf::cleanup "SIG$signal"; 3344 cf::cleanup "SIG$signal";
3054 },
3055 ); 3345 };
3056 } 3346 }
3057} 3347}
3058 3348
3059sub write_runtime { 3349sub write_runtime {
3060 my $runtime = "$LOCALDIR/runtime"; 3350 my $runtime = "$LOCALDIR/runtime";
… …
3105 # and maps saved/destroyed asynchronously. 3395 # and maps saved/destroyed asynchronously.
3106 warn "begin emergency player save\n"; 3396 warn "begin emergency player save\n";
3107 for my $login (keys %cf::PLAYER) { 3397 for my $login (keys %cf::PLAYER) {
3108 my $pl = $cf::PLAYER{$login} or next; 3398 my $pl = $cf::PLAYER{$login} or next;
3109 $pl->valid or next; 3399 $pl->valid or next;
3400 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3110 $pl->save; 3401 $pl->save;
3111 } 3402 }
3112 warn "end emergency player save\n"; 3403 warn "end emergency player save\n";
3113 3404
3114 warn "begin emergency map save\n"; 3405 warn "begin emergency map save\n";
… …
3153 warn "syncing database to disk"; 3444 warn "syncing database to disk";
3154 BDB::db_env_txn_checkpoint $DB_ENV; 3445 BDB::db_env_txn_checkpoint $DB_ENV;
3155 3446
3156 # if anything goes wrong in here, we should simply crash as we already saved 3447 # if anything goes wrong in here, we should simply crash as we already saved
3157 3448
3158 warn "cancelling all WF_AUTOCANCEL watchers";
3159 for (Event::all_watchers) {
3160 $_->cancel if $_->data & WF_AUTOCANCEL;
3161 }
3162
3163 warn "flushing outstanding aio requests"; 3449 warn "flushing outstanding aio requests";
3164 for (;;) { 3450 for (;;) {
3165 BDB::flush; 3451 BDB::flush;
3166 IO::AIO::flush; 3452 IO::AIO::flush;
3167 Coro::cede; 3453 Coro::cede_notself;
3168 last unless IO::AIO::nreqs || BDB::nreqs; 3454 last unless IO::AIO::nreqs || BDB::nreqs;
3169 warn "iterate..."; 3455 warn "iterate...";
3170 } 3456 }
3171 3457
3172 ++$RELOAD; 3458 ++$RELOAD;
… …
3261 3547
3262sub reload_perl() { 3548sub reload_perl() {
3263 # doing reload synchronously and two reloads happen back-to-back, 3549 # doing reload synchronously and two reloads happen back-to-back,
3264 # coro crashes during coro_state_free->destroy here. 3550 # coro crashes during coro_state_free->destroy here.
3265 3551
3266 $RELOAD_WATCHER ||= Event->timer ( 3552 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3267 reentrant => 0,
3268 after => 0,
3269 data => WF_AUTOCANCEL,
3270 cb => sub {
3271 do_reload_perl;
3272 undef $RELOAD_WATCHER; 3553 undef $RELOAD_WATCHER;
3273 }, 3554 do_reload_perl;
3274 ); 3555 };
3275} 3556}
3276 3557
3277register_command "reload" => sub { 3558register_command "reload" => sub {
3278 my ($who, $arg) = @_; 3559 my ($who, $arg) = @_;
3279 3560
3280 if ($who->flag (FLAG_WIZ)) { 3561 if ($who->flag (FLAG_WIZ)) {
3281 $who->message ("reloading server."); 3562 $who->message ("reloading server.");
3563 async {
3564 $Coro::current->{desc} = "perl_reload";
3282 async { reload_perl }; 3565 reload_perl;
3566 };
3283 } 3567 }
3284}; 3568};
3285 3569
3286unshift @INC, $LIBDIR; 3570unshift @INC, $LIBDIR;
3287 3571
… …
3306 my $signal = new Coro::Signal; 3590 my $signal = new Coro::Signal;
3307 push @WAIT_FOR_TICK_BEGIN, $signal; 3591 push @WAIT_FOR_TICK_BEGIN, $signal;
3308 $signal->wait; 3592 $signal->wait;
3309} 3593}
3310 3594
3311 my $min = 1e6;#d# 3595$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3312 my $avg = 10;
3313$TICK_WATCHER = Event->timer (
3314 reentrant => 0,
3315 parked => 1,
3316 prio => 0,
3317 at => $NEXT_TICK || $TICK,
3318 data => WF_AUTOCANCEL,
3319 cb => sub {
3320 if ($Coro::current != $Coro::main) { 3596 if ($Coro::current != $Coro::main) {
3321 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3597 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3322 unless ++$bug_warning > 10; 3598 unless ++$bug_warning > 10;
3323 return; 3599 return;
3324 } 3600 }
3325 3601
3326 $NOW = $tick_start = Event::time; 3602 $NOW = $tick_start = EV::now;
3327 3603
3328 cf::server_tick; # one server iteration 3604 cf::server_tick; # one server iteration
3329 3605
3330 0 && sync_job {#d# 3606 $RUNTIME += $TICK;
3331 for(1..10) { 3607 $NEXT_TICK += $TICK;
3332 my $t = Event::time;
3333 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3334 or die;
3335 3608
3336 $map->width (50); 3609 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3337 $map->height (50); 3610 $NEXT_RUNTIME_WRITE = $NOW + 10;
3338 $map->alloc; 3611 Coro::async_pool {
3339 $map->_load_objects ("/tmp/x.map", 1); 3612 $Coro::current->{desc} = "runtime saver";
3340 my $t = Event::time - $t; 3613 write_runtime
3341 3614 or warn "ERROR: unable to write runtime file: $!";
3342 #next unless $t < 0.0013;#d#
3343 if ($t < $min) {
3344 $min = $t;
3345 }
3346 $avg = $avg * 0.99 + $t * 0.01;
3347 }
3348 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3349 exit 0;
3350 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3351 }; 3615 };
3616 }
3352 3617
3353 $RUNTIME += $TICK;
3354 $NEXT_TICK += $TICK;
3355
3356 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3357 $NEXT_RUNTIME_WRITE = $NOW + 10;
3358 Coro::async_pool {
3359 write_runtime
3360 or warn "ERROR: unable to write runtime file: $!";
3361 };
3362 }
3363
3364# my $AFTER = Event::time;
3365# warn $AFTER - $NOW;#d#
3366
3367 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3618 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3368 $sig->send; 3619 $sig->send;
3369 } 3620 }
3370 while (my $sig = shift @WAIT_FOR_TICK) { 3621 while (my $sig = shift @WAIT_FOR_TICK) {
3371 $sig->send; 3622 $sig->send;
3372 } 3623 }
3373 3624
3374 $NOW = Event::time;
3375
3376 # if we are delayed by four ticks or more, skip them all
3377 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3378
3379 $TICK_WATCHER->at ($NEXT_TICK);
3380 $TICK_WATCHER->start;
3381
3382 $LOAD = ($NOW - $tick_start) / $TICK; 3625 $LOAD = ($NOW - $tick_start) / $TICK;
3383 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3626 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3384 3627
3385 _post_tick; 3628 _post_tick;
3386 3629};
3387 3630$TICK_WATCHER->priority (EV::MAXPRI);
3388 },
3389);
3390 3631
3391{ 3632{
3633 BDB::min_parallel 8;
3392 BDB::max_poll_time $TICK * 0.1; 3634 BDB::max_poll_time $TICK * 0.1;
3393 $BDB_POLL_WATCHER = Event->io ( 3635 $BDB_POLL_WATCHER = EV::io BDB::poll_fileno, EV::READ, \&BDB::poll_cb;
3394 reentrant => 0,
3395 fd => BDB::poll_fileno,
3396 poll => 'r',
3397 prio => 0,
3398 data => WF_AUTOCANCEL,
3399 cb => \&BDB::poll_cb,
3400 );
3401 BDB::min_parallel 8;
3402 3636
3403 BDB::set_sync_prepare { 3637 BDB::set_sync_prepare {
3404 my $status; 3638 my $status;
3405 my $current = $Coro::current; 3639 my $current = $Coro::current;
3406 ( 3640 (
… …
3415 ) 3649 )
3416 }; 3650 };
3417 3651
3418 unless ($DB_ENV) { 3652 unless ($DB_ENV) {
3419 $DB_ENV = BDB::db_env_create; 3653 $DB_ENV = BDB::db_env_create;
3654 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3655 | BDB::LOG_AUTOREMOVE, 1);
3656 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3657 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3420 3658
3421 cf::sync_job { 3659 cf::sync_job {
3422 eval { 3660 eval {
3423 BDB::db_env_open 3661 BDB::db_env_open
3424 $DB_ENV, 3662 $DB_ENV,
… …
3426 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3664 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3427 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3665 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3428 0666; 3666 0666;
3429 3667
3430 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3668 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3431
3432 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3433 $DB_ENV->set_lk_detect;
3434 }; 3669 };
3435 3670
3436 cf::cleanup "db_env_open(db): $@" if $@; 3671 cf::cleanup "db_env_open(db): $@" if $@;
3437 }; 3672 };
3438 } 3673 }
3674
3675 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3676 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3677 };
3678 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3679 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3680 };
3681 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3682 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3683 };
3439} 3684}
3440 3685
3441{ 3686{
3442 IO::AIO::min_parallel 8; 3687 IO::AIO::min_parallel 8;
3443 3688
3444 undef $Coro::AIO::WATCHER; 3689 undef $Coro::AIO::WATCHER;
3445 IO::AIO::max_poll_time $TICK * 0.1; 3690 IO::AIO::max_poll_time $TICK * 0.1;
3446 $AIO_POLL_WATCHER = Event->io ( 3691 $AIO_POLL_WATCHER = EV::io IO::AIO::poll_fileno, EV::READ, \&IO::AIO::poll_cb;
3447 reentrant => 0,
3448 data => WF_AUTOCANCEL,
3449 fd => IO::AIO::poll_fileno,
3450 poll => 'r',
3451 prio => 6,
3452 cb => \&IO::AIO::poll_cb,
3453 );
3454} 3692}
3455 3693
3456my $_log_backtrace; 3694my $_log_backtrace;
3457 3695
3458sub _log_backtrace { 3696sub _log_backtrace {
… …
3462 3700
3463 # limit the # of concurrent backtraces 3701 # limit the # of concurrent backtraces
3464 if ($_log_backtrace < 2) { 3702 if ($_log_backtrace < 2) {
3465 ++$_log_backtrace; 3703 ++$_log_backtrace;
3466 async { 3704 async {
3705 $Coro::current->{desc} = "abt $msg";
3706
3467 my @bt = fork_call { 3707 my @bt = fork_call {
3468 @addr = map { sprintf "%x", $_ } @addr; 3708 @addr = map { sprintf "%x", $_ } @addr;
3469 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3709 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3470 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3710 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3471 or die "addr2line: $!"; 3711 or die "addr2line: $!";

Diff Legend

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