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.329 by root, Fri Aug 10 05:38:16 2007 UTC vs.
Revision 1.386 by root, Mon Oct 15 17:50:27 2007 UTC

… …
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket; 8use Socket;
9use Storable;
10use Event; 9use Event;
11use Opcode; 10use Opcode;
12use Safe; 11use Safe;
13use Safe::Hole; 12use Safe::Hole;
13use Storable ();
14 14
15use Coro 3.61 (); 15use Coro 4.1 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::Event;
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 ();
24 25
25use JSON::XS 1.4 (); 26use JSON::XS ();
26use BDB (); 27use BDB ();
27use Data::Dumper; 28use Data::Dumper;
28use Digest::MD5; 29use Digest::MD5;
29use Fcntl; 30use Fcntl;
30use YAML::Syck (); 31use YAML::Syck ();
31use IO::AIO 2.32 (); 32use IO::AIO 2.51 ();
32use Time::HiRes; 33use Time::HiRes;
33use Compress::LZF; 34use Compress::LZF;
34use Digest::MD5 (); 35use Digest::MD5 ();
35 36
36# configure various modules to our taste 37# configure various modules to our taste
… …
79our $NEXT_TICK; 80our $NEXT_TICK;
80our $NOW; 81our $NOW;
81our $USE_FSYNC = 1; # use fsync to write maps - default off 82our $USE_FSYNC = 1; # use fsync to write maps - default off
82 83
83our $BDB_POLL_WATCHER; 84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER;
84our $DB_ENV; 88our $DB_ENV;
85 89
86our %CFG; 90our %CFG;
87 91
88our $UPTIME; $UPTIME ||= time; 92our $UPTIME; $UPTIME ||= time;
89our $RUNTIME; 93our $RUNTIME;
90 94
91our %PLAYER; # all users 95our (%PLAYER, %PLAYER_LOADING); # all users
92our %MAP; # all maps 96our (%MAP, %MAP_LOADING ); # all maps
93our $LINK_MAP; # the special {link} map, which is always available 97our $LINK_MAP; # the special {link} map, which is always available
94 98
95# used to convert map paths into valid unix filenames by replacing / by ∕ 99# used to convert map paths into valid unix filenames by replacing / by ∕
96our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
97 101
… …
186 $msg .= "\n" 190 $msg .= "\n"
187 unless $msg =~ /\n$/; 191 unless $msg =~ /\n$/;
188 192
189 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
190 194
191 utf8::encode $msg;
192 LOG llevError, $msg; 195 LOG llevError, $msg;
193 }; 196 };
194} 197}
195 198
196@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
271Wait until the given lock is available and then acquires it and returns 274Wait until the given lock is available and then acquires it and returns
272a Coro::guard object. If the guard object gets destroyed (goes out of scope, 275a Coro::guard object. If the guard object gets destroyed (goes out of scope,
273for example when the coroutine gets canceled), the lock is automatically 276for example when the coroutine gets canceled), the lock is automatically
274returned. 277returned.
275 278
279Locks are *not* recursive, locking from the same coro twice results in a
280deadlocked coro.
281
276Lock names should begin with a unique identifier (for example, cf::map::find 282Lock names should begin with a unique identifier (for example, cf::map::find
277uses map_find and cf::map::load uses map_load). 283uses map_find and cf::map::load uses map_load).
278 284
279=item $locked = cf::lock_active $string 285=item $locked = cf::lock_active $string
280 286
281Return true if the lock is currently active, i.e. somebody has locked it. 287Return true if the lock is currently active, i.e. somebody has locked it.
282 288
283=cut 289=cut
284 290
285our %LOCK; 291our %LOCK;
292our %LOCKER;#d#
286 293
287sub lock_wait($) { 294sub lock_wait($) {
288 my ($key) = @_; 295 my ($key) = @_;
296
297 if ($LOCKER{$key} == $Coro::current) {#d#
298 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
299 return;#d#
300 }#d#
289 301
290 # wait for lock, if any 302 # wait for lock, if any
291 while ($LOCK{$key}) { 303 while ($LOCK{$key}) {
292 push @{ $LOCK{$key} }, $Coro::current; 304 push @{ $LOCK{$key} }, $Coro::current;
293 Coro::schedule; 305 Coro::schedule;
… …
299 311
300 # wait, to be sure we are not locked 312 # wait, to be sure we are not locked
301 lock_wait $key; 313 lock_wait $key;
302 314
303 $LOCK{$key} = []; 315 $LOCK{$key} = [];
316 $LOCKER{$key} = $Coro::current;#d#
304 317
305 Coro::guard { 318 Coro::guard {
319 delete $LOCKER{$key};#d#
306 # wake up all waiters, to be on the safe side 320 # wake up all waiters, to be on the safe side
307 $_->ready for @{ delete $LOCK{$key} }; 321 $_->ready for @{ delete $LOCK{$key} };
308 } 322 }
309} 323}
310 324
… …
340our @SLOT_QUEUE; 354our @SLOT_QUEUE;
341our $SLOT_QUEUE; 355our $SLOT_QUEUE;
342 356
343$SLOT_QUEUE->cancel if $SLOT_QUEUE; 357$SLOT_QUEUE->cancel if $SLOT_QUEUE;
344$SLOT_QUEUE = Coro::async { 358$SLOT_QUEUE = Coro::async {
359 $Coro::current->desc ("timeslot manager");
360
345 my $signal = new Coro::Signal; 361 my $signal = new Coro::Signal;
346 362
347 while () { 363 while () {
348 next_job: 364 next_job:
349 my $avail = cf::till_tick; 365 my $avail = cf::till_tick;
… …
357 } 373 }
358 } 374 }
359 } 375 }
360 376
361 if (@SLOT_QUEUE) { 377 if (@SLOT_QUEUE) {
362 # we do not use wait_For_tick() as it returns immediately when tick is inactive 378 # we do not use wait_for_tick() as it returns immediately when tick is inactive
363 push @cf::WAIT_FOR_TICK, $signal; 379 push @cf::WAIT_FOR_TICK, $signal;
364 $signal->wait; 380 $signal->wait;
365 } else { 381 } else {
366 Coro::schedule; 382 Coro::schedule;
367 } 383 }
… …
411 my $time = Event::time; 427 my $time = Event::time;
412 428
413 # this is the main coro, too bad, we have to block 429 # this is the main coro, too bad, we have to block
414 # till the operation succeeds, freezing the server :/ 430 # till the operation succeeds, freezing the server :/
415 431
432 LOG llevError, Carp::longmess "sync job";#d#
433
416 # TODO: use suspend/resume instead 434 # TODO: use suspend/resume instead
417 # (but this is cancel-safe) 435 # (but this is cancel-safe)
418 my $freeze_guard = freeze_mainloop; 436 my $freeze_guard = freeze_mainloop;
419 437
420 my $busy = 1; 438 my $busy = 1;
421 my @res; 439 my @res;
422 440
423 (async { 441 (async {
442 $Coro::current->desc ("sync job coro");
424 @res = eval { $job->() }; 443 @res = eval { $job->() };
425 warn $@ if $@; 444 warn $@ if $@;
426 undef $busy; 445 undef $busy;
427 })->prio (Coro::PRIO_MAX); 446 })->prio (Coro::PRIO_MAX);
428 447
… …
472Coro::Storable. May, of course, block. Note that the executed sub may 491Coro::Storable. May, of course, block. Note that the executed sub may
473never block itself or use any form of Event handling. 492never block itself or use any form of Event handling.
474 493
475=cut 494=cut
476 495
477sub _store_scalar {
478 open my $fh, ">", \my $buf
479 or die "fork_call: cannot open fh-to-buf in child : $!";
480 Storable::store_fd $_[0], $fh;
481 close $fh;
482
483 $buf
484}
485
486sub fork_call(&@) { 496sub fork_call(&@) {
487 my ($cb, @args) = @_; 497 my ($cb, @args) = @_;
488 498
489# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 499 # we seemingly have to make a local copy of the whole thing,
490# or die "socketpair: $!"; 500 # otherwise perl prematurely frees the stuff :/
491 pipe my $fh1, my $fh2 501 # TODO: investigate and fix (likely this will be rather laborious)
492 or die "pipe: $!";
493 502
494 if (my $pid = fork) { 503 my @res = Coro::Util::fork_eval {
495 close $fh2;
496
497 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
498 warn "pst<$res>" unless $res =~ /^pst/;
499 $res = Coro::Storable::thaw $res;
500
501 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
502
503 Carp::confess $$res unless "ARRAY" eq ref $res;
504
505 return wantarray ? @$res : $res->[-1];
506 } else {
507 reset_signals; 504 reset_signals;
508 local $SIG{__WARN__}; 505 &$cb
509 local $SIG{__DIE__}; 506 }, @args;
510 # just in case, this hack effectively disables event
511 # in the child. cleaner and slower would be canceling all watchers,
512 # but this works for the time being.
513 local $Coro::idle;
514 $Coro::current->prio (Coro::PRIO_MAX);
515 507
516 eval { 508 wantarray ? @res : $res[-1]
517 close $fh1;
518
519 my @res = eval { $cb->(@args) };
520
521 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
522 close $fh2;
523 };
524
525 warn $@ if $@;
526 _exit 0;
527 }
528} 509}
529 510
530=item $value = cf::db_get $family => $key 511=item $value = cf::db_get $family => $key
531 512
532Returns a single value from the environment database. 513Returns a single value from the environment database.
… …
534=item cf::db_put $family => $key => $value 515=item cf::db_put $family => $key => $value
535 516
536Stores the given C<$value> in the family. It can currently store binary 517Stores the given C<$value> in the family. It can currently store binary
537data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 518data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
538 519
520=item $db = cf::db_table "name"
521
522Create and/or open a new database table. The string must not be "db" and must be unique
523within each server.
524
539=cut 525=cut
526
527sub db_table($) {
528 my ($name) = @_;
529 my $db = BDB::db_create $DB_ENV;
530
531 eval {
532 $db->set_flags (BDB::CHKSUM);
533
534 utf8::encode $name;
535 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
536 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
537 cf::cleanup "db_open(db): $!" if $!;
538 };
539 cf::cleanup "db_open(db): $@" if $@;
540
541 $db
542}
540 543
541our $DB; 544our $DB;
542 545
543sub db_init { 546sub db_init {
544 unless ($DB) {
545 $DB = BDB::db_create $DB_ENV;
546
547 cf::sync_job { 547 cf::sync_job {
548 eval { 548 $DB ||= db_table "db";
549 $DB->set_flags (BDB::CHKSUM);
550
551 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
552 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
553 cf::cleanup "db_open(db): $!" if $!;
554 };
555 cf::cleanup "db_open(db): $@" if $@;
556 };
557 } 549 };
558} 550}
559 551
560sub db_get($$) { 552sub db_get($$) {
561 my $key = "$_[0]/$_[1]"; 553 my $key = "$_[0]/$_[1]";
562 554
… …
612 if (1) { 604 if (1) {
613 $md5 = 605 $md5 =
614 join "\x00", 606 join "\x00",
615 $processversion, 607 $processversion,
616 map { 608 map {
617 Coro::cede; 609 cf::cede_to_tick;
618 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 610 ($src->[$_], Digest::MD5::md5_hex $data[$_])
619 } 0.. $#$src; 611 } 0.. $#$src;
620 612
621 613
622 my $dbmd5 = db_get cache => "$id/md5"; 614 my $dbmd5 = db_get cache => "$id/md5";
… …
974 966
975=cut 967=cut
976 968
977############################################################################# 969#############################################################################
978# object support 970# object support
979#
980 971
972sub _object_equal($$);
973sub _object_equal($$) {
974 my ($a, $b) = @_;
975
976 return 0 unless (ref $a) eq (ref $b);
977
978 if ("HASH" eq ref $a) {
979 my @ka = keys %$a;
980 my @kb = keys %$b;
981
982 return 0 if @ka != @kb;
983
984 for (0 .. $#ka) {
985 return 0 unless $ka[$_] eq $kb[$_];
986 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
987 }
988
989 } elsif ("ARRAY" eq ref $a) {
990
991 return 0 if @$a != @$b;
992
993 for (0 .. $#$a) {
994 return 0 unless _object_equal $a->[$_], $b->[$_];
995 }
996
997 } elsif ($a ne $b) {
998 return 0;
999 }
1000
1001 1
1002}
1003
1004our $SLOW_MERGES;#d#
981sub _can_merge { 1005sub _can_merge {
982 my ($ob1, $ob2) = @_; 1006 my ($ob1, $ob2) = @_;
983 1007
984 local $Storable::canonical = 1; 1008 ++$SLOW_MERGES;#d#
985 my $fob1 = Storable::freeze $ob1;
986 my $fob2 = Storable::freeze $ob2;
987 1009
988 $fob1 eq $fob2 1010 # we do the slow way here
1011 return _object_equal $ob1, $ob2
989} 1012}
990 1013
991sub reattach { 1014sub reattach {
992 # basically do the same as instantiate, without calling instantiate 1015 # basically do the same as instantiate, without calling instantiate
993 my ($obj) = @_; 1016 my ($obj) = @_;
… …
1041sub object_freezer_save { 1064sub object_freezer_save {
1042 my ($filename, $rdata, $objs) = @_; 1065 my ($filename, $rdata, $objs) = @_;
1043 1066
1044 sync_job { 1067 sync_job {
1045 if (length $$rdata) { 1068 if (length $$rdata) {
1069 utf8::decode (my $decname = $filename);
1046 warn sprintf "saving %s (%d,%d)\n", 1070 warn sprintf "saving %s (%d,%d)\n",
1047 $filename, length $$rdata, scalar @$objs; 1071 $decname, length $$rdata, scalar @$objs;
1048 1072
1049 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1073 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1050 chmod SAVE_MODE, $fh; 1074 chmod SAVE_MODE, $fh;
1051 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1075 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1052 aio_fsync $fh if $cf::USE_FSYNC; 1076 aio_fsync $fh if $cf::USE_FSYNC;
1053 close $fh; 1077 close $fh;
1054 1078
1055 if (@$objs) { 1079 if (@$objs) {
1056 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1080 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1057 chmod SAVE_MODE, $fh; 1081 chmod SAVE_MODE, $fh;
1058 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1082 my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs };
1059 aio_write $fh, 0, (length $data), $data, 0; 1083 aio_write $fh, 0, (length $data), $data, 0;
1060 aio_fsync $fh if $cf::USE_FSYNC; 1084 aio_fsync $fh if $cf::USE_FSYNC;
1061 close $fh; 1085 close $fh;
1062 aio_rename "$filename.pst~", "$filename.pst"; 1086 aio_rename "$filename.pst~", "$filename.pst";
1063 } 1087 }
… …
1071 } 1095 }
1072 } else { 1096 } else {
1073 aio_unlink $filename; 1097 aio_unlink $filename;
1074 aio_unlink "$filename.pst"; 1098 aio_unlink "$filename.pst";
1075 } 1099 }
1076 } 1100 };
1077} 1101}
1078 1102
1079sub object_freezer_as_string { 1103sub object_freezer_as_string {
1080 my ($rdata, $objs) = @_; 1104 my ($rdata, $objs) = @_;
1081 1105
… …
1093 or return; 1117 or return;
1094 1118
1095 unless (aio_stat "$filename.pst") { 1119 unless (aio_stat "$filename.pst") {
1096 (aio_load "$filename.pst", $av) >= 0 1120 (aio_load "$filename.pst", $av) >= 0
1097 or return; 1121 or return;
1098 $av = eval { (Storable::thaw $av)->{objs} };
1099 }
1100 1122
1123 my $st = eval { Coro::Storable::thaw $av }
1124 || eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1125 $av = $st->{objs};
1126 }
1127
1128 utf8::decode (my $decname = $filename);
1101 warn sprintf "loading %s (%d)\n", 1129 warn sprintf "loading %s (%d,%d)\n",
1102 $filename, length $data, scalar @{$av || []}; 1130 $decname, length $data, scalar @{$av || []};
1131
1103 return ($data, $av); 1132 ($data, $av)
1104} 1133}
1105 1134
1106=head2 COMMAND CALLBACKS 1135=head2 COMMAND CALLBACKS
1107 1136
1108=over 4 1137=over 4
… …
1186 my ($type, $reply, @payload) = 1215 my ($type, $reply, @payload) =
1187 "ARRAY" eq ref $msg 1216 "ARRAY" eq ref $msg
1188 ? @$msg 1217 ? @$msg
1189 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove 1218 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1190 1219
1220 my @reply;
1221
1191 if (my $cb = $EXTCMD{$type}) { 1222 if (my $cb = $EXTCMD{$type}) {
1192 my @reply = $cb->($pl, @payload); 1223 @reply = $cb->($pl, @payload);
1193
1194 $pl->ext_reply ($reply, @reply)
1195 if $reply;
1196 } 1224 }
1225
1226 $pl->ext_reply ($reply, @reply)
1227 if $reply;
1228
1197 } else { 1229 } else {
1198 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1230 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1199 } 1231 }
1200 1232
1201 cf::override; 1233 cf::override;
… …
1291 1323
1292=head3 cf::player 1324=head3 cf::player
1293 1325
1294=over 4 1326=over 4
1295 1327
1328=item cf::player::num_playing
1329
1330Returns the official number of playing players, as per the Crossfire metaserver rules.
1331
1332=cut
1333
1334sub num_playing {
1335 scalar grep
1336 $_->ob->map
1337 && !$_->hidden
1338 && !$_->ob->flag (cf::FLAG_WIZ),
1339 cf::player::list
1340}
1341
1296=item cf::player::find $login 1342=item cf::player::find $login
1297 1343
1298Returns the given player object, loading it if necessary (might block). 1344Returns the given player object, loading it if necessary (might block).
1299 1345
1300=cut 1346=cut
… …
1335 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1381 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1336 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1382 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1337 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1383 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1338 aio_unlink +(playerdir $login) . "/$login.pl"; 1384 aio_unlink +(playerdir $login) . "/$login.pl";
1339 1385
1340 my $pl = load_pl path $login 1386 my $f = new_from_file cf::object::thawer path $login
1341 or return; 1387 or return;
1388
1389 my $pl = cf::player::load_pl $f
1390 or return;
1391 local $cf::PLAYER_LOADING{$login} = $pl;
1392 $f->resolve_delayed_derefs;
1342 $cf::PLAYER{$login} = $pl 1393 $cf::PLAYER{$login} = $pl
1343 } 1394 }
1344 } 1395 }
1345} 1396}
1346 1397
… …
1356 1407
1357 aio_mkdir playerdir $pl, 0770; 1408 aio_mkdir playerdir $pl, 0770;
1358 $pl->{last_save} = $cf::RUNTIME; 1409 $pl->{last_save} = $cf::RUNTIME;
1359 1410
1360 $pl->save_pl ($path); 1411 $pl->save_pl ($path);
1361 Coro::cede; 1412 cf::cede_to_tick;
1362} 1413}
1363 1414
1364sub new($) { 1415sub new($) {
1365 my ($login) = @_; 1416 my ($login) = @_;
1366 1417
… …
1444 or return []; 1495 or return [];
1445 1496
1446 my @logins; 1497 my @logins;
1447 1498
1448 for my $login (@$dirs) { 1499 for my $login (@$dirs) {
1500 my $path = path $login;
1501
1502 # a .pst is a dead give-away for a valid player
1503 unless (-e "$path.pst") {
1449 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1504 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1450 aio_read $fh, 0, 512, my $buf, 0 or next; 1505 aio_read $fh, 0, 512, my $buf, 0 or next;
1451 $buf !~ /^password -------------$/m or next; # official not-valid tag 1506 $buf !~ /^password -------------$/m or next; # official not-valid tag
1507 }
1452 1508
1453 utf8::decode $login; 1509 utf8::decode $login;
1454 push @logins, $login; 1510 push @logins, $login;
1455 } 1511 }
1456 1512
… …
1494sub expand_cfpod { 1550sub expand_cfpod {
1495 ((my $self), (local $_)) = @_; 1551 ((my $self), (local $_)) = @_;
1496 1552
1497 # escape & and < 1553 # escape & and <
1498 s/&/&amp;/g; 1554 s/&/&amp;/g;
1499 s/(?<![BIUGH])</&lt;/g; 1555 s/(?<![BIUGHT])</&lt;/g;
1500 1556
1501 # this is buggy, it needs to properly take care of nested <'s 1557 # this is buggy, it needs to properly take care of nested <'s
1502 1558
1503 1 while 1559 1 while
1504 # replace B<>, I<>, U<> etc. 1560 # replace B<>, I<>, U<> etc.
1505 s/B<([^\>]*)>/<b>$1<\/b>/ 1561 s/B<([^\>]*)>/<b>$1<\/b>/
1506 || s/I<([^\>]*)>/<i>$1<\/i>/ 1562 || s/I<([^\>]*)>/<i>$1<\/i>/
1507 || s/U<([^\>]*)>/<u>$1<\/u>/ 1563 || s/U<([^\>]*)>/<u>$1<\/u>/
1564 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1508 # replace G<male|female> tags 1565 # replace G<male|female> tags
1509 || s{G<([^>|]*)\|([^>]*)>}{ 1566 || s{G<([^>|]*)\|([^>]*)>}{
1510 $self->gender ? $2 : $1 1567 $self->gender ? $2 : $1
1511 }ge 1568 }ge
1512 # replace H<hint text> 1569 # replace H<hint text>
… …
1542=cut 1599=cut
1543 1600
1544sub ext_reply($$@) { 1601sub ext_reply($$@) {
1545 my ($self, $id, @msg) = @_; 1602 my ($self, $id, @msg) = @_;
1546 1603
1547 if ($self->ns->extcmd == 2) { 1604 $self->ns->ext_reply ($id, @msg)
1548 $self->send ("ext " . $self->ns->{json_coder}->encode (["reply-$id", @msg]));
1549 } elsif ($self->ns->extcmd == 1) {
1550 #TODO: version 1, remove
1551 unshift @msg, msgtype => "reply", msgid => $id;
1552 $self->send ("ext " . $self->ns->{json_coder}->encode ({@msg}));
1553 }
1554} 1605}
1555 1606
1556=item $player->ext_msg ($type, @msg) 1607=item $player->ext_msg ($type, @msg)
1557 1608
1558Sends an ext event to the client. 1609Sends an ext event to the client.
… …
1786 1837
1787sub load_header_from($) { 1838sub load_header_from($) {
1788 my ($self, $path) = @_; 1839 my ($self, $path) = @_;
1789 1840
1790 utf8::encode $path; 1841 utf8::encode $path;
1791 #aio_open $path, O_RDONLY, 0 1842 my $f = new_from_file cf::object::thawer $path
1792 # or return;
1793
1794 $self->_load_header ($path)
1795 or return; 1843 or return;
1844
1845 $self->_load_header ($f)
1846 or return;
1847
1848 local $MAP_LOADING{$self->{path}} = $self;
1849 $f->resolve_delayed_derefs;
1796 1850
1797 $self->{load_path} = $path; 1851 $self->{load_path} = $path;
1798 1852
1799 1 1853 1
1800} 1854}
… …
1854sub find { 1908sub find {
1855 my ($path, $origin) = @_; 1909 my ($path, $origin) = @_;
1856 1910
1857 $path = normalise $path, $origin && $origin->path; 1911 $path = normalise $path, $origin && $origin->path;
1858 1912
1913 cf::lock_wait "map_data:$path";#d#remove
1859 cf::lock_wait "map_find:$path"; 1914 cf::lock_wait "map_find:$path";
1860 1915
1861 $cf::MAP{$path} || do { 1916 $cf::MAP{$path} || do {
1862 my $guard = cf::lock_acquire "map_find:$path"; 1917 my $guard1 = cf::lock_acquire "map_find:$path";
1918 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1919
1863 my $map = new_from_path cf::map $path 1920 my $map = new_from_path cf::map $path
1864 or return; 1921 or return;
1865 1922
1866 $map->{last_save} = $cf::RUNTIME; 1923 $map->{last_save} = $cf::RUNTIME;
1867 1924
… …
1869 or return; 1926 or return;
1870 1927
1871 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1928 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1872 # doing this can freeze the server in a sync job, obviously 1929 # doing this can freeze the server in a sync job, obviously
1873 #$cf::WAIT_FOR_TICK->wait; 1930 #$cf::WAIT_FOR_TICK->wait;
1931 undef $guard1;
1932 undef $guard2;
1874 $map->reset; 1933 $map->reset;
1875 undef $guard;
1876 return find $path; 1934 return find $path;
1877 } 1935 }
1878 1936
1879 $cf::MAP{$path} = $map 1937 $cf::MAP{$path} = $map
1880 } 1938 }
… …
1889 local $self->{deny_reset} = 1; # loading can take a long time 1947 local $self->{deny_reset} = 1; # loading can take a long time
1890 1948
1891 my $path = $self->{path}; 1949 my $path = $self->{path};
1892 1950
1893 { 1951 {
1894 my $guard = cf::lock_acquire "map_load:$path"; 1952 my $guard = cf::lock_acquire "map_data:$path";
1895 1953
1954 return unless $self->valid;
1896 return if $self->in_memory != cf::MAP_SWAPPED; 1955 return unless $self->in_memory == cf::MAP_SWAPPED;
1897 1956
1898 $self->in_memory (cf::MAP_LOADING); 1957 $self->in_memory (cf::MAP_LOADING);
1899 1958
1900 $self->alloc; 1959 $self->alloc;
1901 1960
1902 $self->pre_load; 1961 $self->pre_load;
1903 Coro::cede; 1962 cf::cede_to_tick;
1904 1963
1964 my $f = new_from_file cf::object::thawer $self->{load_path};
1965 $f->skip_block;
1905 $self->_load_objects ($self->{load_path}, 1) 1966 $self->_load_objects ($f)
1906 or return; 1967 or return;
1907 1968
1908 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1969 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1909 if delete $self->{load_original}; 1970 if delete $self->{load_original};
1910 1971
1911 if (my $uniq = $self->uniq_path) { 1972 if (my $uniq = $self->uniq_path) {
1912 utf8::encode $uniq; 1973 utf8::encode $uniq;
1913 if (aio_open $uniq, O_RDONLY, 0) { 1974 unless (aio_stat $uniq) {
1975 if (my $f = new_from_file cf::object::thawer $uniq) {
1914 $self->clear_unique_items; 1976 $self->clear_unique_items;
1915 $self->_load_objects ($uniq, 0); 1977 $self->_load_objects ($f);
1978 $f->resolve_delayed_derefs;
1979 }
1916 } 1980 }
1917 } 1981 }
1918 1982
1919 Coro::cede; 1983 $f->resolve_delayed_derefs;
1984
1985 cf::cede_to_tick;
1920 # now do the right thing for maps 1986 # now do the right thing for maps
1921 $self->link_multipart_objects; 1987 $self->link_multipart_objects;
1922 $self->difficulty ($self->estimate_difficulty) 1988 $self->difficulty ($self->estimate_difficulty)
1923 unless $self->difficulty; 1989 unless $self->difficulty;
1924 Coro::cede; 1990 cf::cede_to_tick;
1925 1991
1926 unless ($self->{deny_activate}) { 1992 unless ($self->{deny_activate}) {
1927 $self->decay_objects; 1993 $self->decay_objects;
1928 $self->fix_auto_apply; 1994 $self->fix_auto_apply;
1929 $self->update_buttons; 1995 $self->update_buttons;
1930 Coro::cede; 1996 cf::cede_to_tick;
1931 $self->set_darkness_map; 1997 $self->set_darkness_map;
1932 Coro::cede; 1998 cf::cede_to_tick;
1933 $self->activate; 1999 $self->activate;
1934 } 2000 }
1935 2001
1936 $self->{last_save} = $cf::RUNTIME; 2002 $self->{last_save} = $cf::RUNTIME;
1937 $self->last_access ($cf::RUNTIME); 2003 $self->last_access ($cf::RUNTIME);
… …
1953 2019
1954 $self 2020 $self
1955} 2021}
1956 2022
1957# find and load all maps in the 3x3 area around a map 2023# find and load all maps in the 3x3 area around a map
1958sub load_diag { 2024sub load_neighbours {
1959 my ($map) = @_; 2025 my ($map) = @_;
1960 2026
1961 my @diag; # diagonal neighbours 2027 my @neigh; # diagonal neighbours
1962 2028
1963 for (0 .. 3) { 2029 for (0 .. 3) {
1964 my $neigh = $map->tile_path ($_) 2030 my $neigh = $map->tile_path ($_)
1965 or next; 2031 or next;
1966 $neigh = find $neigh, $map 2032 $neigh = find $neigh, $map
1967 or next; 2033 or next;
1968 $neigh->load; 2034 $neigh->load;
1969 2035
2036 push @neigh,
1970 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2037 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1971 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2038 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1972 } 2039 }
1973 2040
1974 for (@diag) { 2041 for (grep defined $_->[0], @neigh) {
2042 my ($path, $origin) = @$_;
1975 my $neigh = find @$_ 2043 my $neigh = find $path, $origin
1976 or next; 2044 or next;
1977 $neigh->load; 2045 $neigh->load;
1978 } 2046 }
1979} 2047}
1980 2048
… …
1985} 2053}
1986 2054
1987sub do_load_sync { 2055sub do_load_sync {
1988 my ($map) = @_; 2056 my ($map) = @_;
1989 2057
2058 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2059 if $Coro::current == $Coro::main;
2060
1990 cf::sync_job { $map->load }; 2061 cf::sync_job { $map->load };
1991} 2062}
1992 2063
1993our %MAP_PREFETCH; 2064our %MAP_PREFETCH;
1994our $MAP_PREFETCHER = undef; 2065our $MAP_PREFETCHER = undef;
1995 2066
1996sub find_async { 2067sub find_async {
1997 my ($path, $origin) = @_; 2068 my ($path, $origin, $load) = @_;
1998 2069
1999 $path = normalise $path, $origin && $origin->{path}; 2070 $path = normalise $path, $origin && $origin->{path};
2000 2071
2001 if (my $map = $cf::MAP{$path}) { 2072 if (my $map = $cf::MAP{$path}) {
2002 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2073 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
2003 } 2074 }
2004 2075
2005 undef $MAP_PREFETCH{$path}; 2076 $MAP_PREFETCH{$path} |= $load;
2077
2006 $MAP_PREFETCHER ||= cf::async { 2078 $MAP_PREFETCHER ||= cf::async {
2079 $Coro::current->{desc} = "map prefetcher";
2080
2007 while (%MAP_PREFETCH) { 2081 while (%MAP_PREFETCH) {
2008 for my $path (keys %MAP_PREFETCH) { 2082 while (my ($k, $v) = each %MAP_PREFETCH) {
2009 if (my $map = find $path) { 2083 if (my $map = find $k) {
2010 $map->load; 2084 $map->load if $v;
2011 } 2085 }
2012 2086
2013 delete $MAP_PREFETCH{$path}; 2087 delete $MAP_PREFETCH{$k};
2014 } 2088 }
2015 } 2089 }
2016 undef $MAP_PREFETCHER; 2090 undef $MAP_PREFETCHER;
2017 }; 2091 };
2018 $MAP_PREFETCHER->prio (6); 2092 $MAP_PREFETCHER->prio (6);
… …
2021} 2095}
2022 2096
2023sub save { 2097sub save {
2024 my ($self) = @_; 2098 my ($self) = @_;
2025 2099
2026 my $lock = cf::lock_acquire "map_data:" . $self->path; 2100 my $lock = cf::lock_acquire "map_data:$self->{path}";
2027 2101
2028 $self->{last_save} = $cf::RUNTIME; 2102 $self->{last_save} = $cf::RUNTIME;
2029 2103
2030 return unless $self->dirty; 2104 return unless $self->dirty;
2031 2105
… …
2037 return if $self->{deny_save}; 2111 return if $self->{deny_save};
2038 2112
2039 local $self->{last_access} = $self->last_access;#d# 2113 local $self->{last_access} = $self->last_access;#d#
2040 2114
2041 cf::async { 2115 cf::async {
2116 $Coro::current->{desc} = "map player save";
2042 $_->contr->save for $self->players; 2117 $_->contr->save for $self->players;
2043 }; 2118 };
2044 2119
2045 if ($uniq) { 2120 if ($uniq) {
2046 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2121 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
2054 my ($self) = @_; 2129 my ($self) = @_;
2055 2130
2056 # save first because save cedes 2131 # save first because save cedes
2057 $self->save; 2132 $self->save;
2058 2133
2059 my $lock = cf::lock_acquire "map_data:" . $self->path; 2134 my $lock = cf::lock_acquire "map_data:$self->{path}";
2060 2135
2061 return if $self->players; 2136 return if $self->players;
2062 return if $self->in_memory != cf::MAP_IN_MEMORY; 2137 return if $self->in_memory != cf::MAP_IN_MEMORY;
2063 return if $self->{deny_save}; 2138 return if $self->{deny_save};
2064 2139
2140 $self->in_memory (cf::MAP_SWAPPED);
2141
2142 $self->deactivate;
2143 $_->clear_links_to ($self) for values %cf::MAP;
2065 $self->clear; 2144 $self->clear;
2066 $self->in_memory (cf::MAP_SWAPPED);
2067} 2145}
2068 2146
2069sub reset_at { 2147sub reset_at {
2070 my ($self) = @_; 2148 my ($self) = @_;
2071 2149
… …
2103 if $uniq; 2181 if $uniq;
2104 } 2182 }
2105 2183
2106 delete $cf::MAP{$self->path}; 2184 delete $cf::MAP{$self->path};
2107 2185
2186 $self->deactivate;
2187 $_->clear_links_to ($self) for values %cf::MAP;
2108 $self->clear; 2188 $self->clear;
2109
2110 $_->clear_links_to ($self) for values %cf::MAP;
2111 2189
2112 $self->unlink_save; 2190 $self->unlink_save;
2113 $self->destroy; 2191 $self->destroy;
2114} 2192}
2115 2193
2116my $nuke_counter = "aaaa"; 2194my $nuke_counter = "aaaa";
2117 2195
2118sub nuke { 2196sub nuke {
2119 my ($self) = @_; 2197 my ($self) = @_;
2120 2198
2199 {
2200 my $lock = cf::lock_acquire "map_data:$self->{path}";
2201
2121 delete $cf::MAP{$self->path}; 2202 delete $cf::MAP{$self->path};
2122 2203
2123 $self->unlink_save; 2204 $self->unlink_save;
2124 2205
2125 bless $self, "cf::map"; 2206 bless $self, "cf::map";
2126 delete $self->{deny_reset}; 2207 delete $self->{deny_reset};
2127 $self->{deny_save} = 1; 2208 $self->{deny_save} = 1;
2128 $self->reset_timeout (1); 2209 $self->reset_timeout (1);
2129 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2210 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2130 2211
2131 $cf::MAP{$self->path} = $self; 2212 $cf::MAP{$self->path} = $self;
2213 }
2132 2214
2133 $self->reset; # polite request, might not happen 2215 $self->reset; # polite request, might not happen
2134} 2216}
2135 2217
2136=item $maps = cf::map::tmp_maps 2218=item $maps = cf::map::tmp_maps
… …
2212 2294
2213sub inv_recursive { 2295sub inv_recursive {
2214 inv_recursive_ inv $_[0] 2296 inv_recursive_ inv $_[0]
2215} 2297}
2216 2298
2299=item $ref = $ob->ref
2300
2301creates and returns a persistent reference to an objetc that can be stored as a string.
2302
2303=item $ob = cf::object::deref ($refstring)
2304
2305returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2306even if the object actually exists. May block.
2307
2308=cut
2309
2310sub deref {
2311 my ($ref) = @_;
2312
2313 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2314 my ($uuid, $name) = ($1, $2);
2315 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2316 or return;
2317 $pl->ob->uuid eq $uuid
2318 or return;
2319
2320 $pl->ob
2321 } else {
2322 warn "$ref: cannot resolve object reference\n";
2323 undef
2324 }
2325}
2326
2217package cf; 2327package cf;
2218 2328
2219=back 2329=back
2220 2330
2221=head3 cf::object::player 2331=head3 cf::object::player
… …
2349 # use -1 or undef as default coordinates, not 0, 0 2459 # use -1 or undef as default coordinates, not 0, 0
2350 ($x, $y) = ($map->enter_x, $map->enter_y) 2460 ($x, $y) = ($map->enter_x, $map->enter_y)
2351 if $x <=0 && $y <= 0; 2461 if $x <=0 && $y <= 0;
2352 2462
2353 $map->load; 2463 $map->load;
2354 $map->load_diag; 2464 $map->load_neighbours;
2355 2465
2356 return unless $self->contr->active; 2466 return unless $self->contr->active;
2357 $self->activate_recursive; 2467 $self->activate_recursive;
2358 2468
2359 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2469 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
… …
2379 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2489 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2380 2490
2381 $self->enter_link; 2491 $self->enter_link;
2382 2492
2383 (async { 2493 (async {
2494 $Coro::current->{desc} = "player::goto $path $x $y";
2495
2496 # *tag paths override both path and x|y
2497 if ($path =~ /^\*(.*)$/) {
2498 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2499 my $ob = $obs[rand @obs];
2500
2501 # see if we actually can go there
2502 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2503 $ob = $obs[rand @obs];
2504 } else {
2505 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2506 }
2507 # else put us there anyways for now #d#
2508
2509 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2510 } else {
2511 ($path, $x, $y) = (undef, undef, undef);
2512 }
2513 }
2514
2384 my $map = eval { 2515 my $map = eval {
2385 my $map = cf::map::find $path; 2516 my $map = defined $path ? cf::map::find $path : undef;
2386 2517
2387 if ($map) { 2518 if ($map) {
2388 $map = $map->customise_for ($self); 2519 $map = $map->customise_for ($self);
2389 $map = $check->($map) if $check && $map; 2520 $map = $check->($map) if $check && $map;
2390 } else { 2521 } else {
2391 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2522 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2392 } 2523 }
2393 2524
2394 $map 2525 $map
2395 }; 2526 };
2396 2527
… …
2486 # if exit is damned, update players death & WoR home-position 2617 # if exit is damned, update players death & WoR home-position
2487 $self->contr->savebed ($slaying, $hp, $sp) 2618 $self->contr->savebed ($slaying, $hp, $sp)
2488 if $exit->flag (FLAG_DAMNED); 2619 if $exit->flag (FLAG_DAMNED);
2489 2620
2490 (async { 2621 (async {
2622 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2623
2491 $self->deactivate_recursive; # just to be sure 2624 $self->deactivate_recursive; # just to be sure
2492 unless (eval { 2625 unless (eval {
2493 $self->goto ($slaying, $hp, $sp); 2626 $self->goto ($slaying, $hp, $sp);
2494 2627
2495 1; 2628 1;
… …
2530the message, with C<log> being the default. If C<$color> is negative, suppress 2663the message, with C<log> being the default. If C<$color> is negative, suppress
2531the message unless the client supports the msg packet. 2664the message unless the client supports the msg packet.
2532 2665
2533=cut 2666=cut
2534 2667
2668our %CHANNEL = (
2669 "c/identify" => {
2670 id => "infobox",
2671 title => "Identify",
2672 reply => undef,
2673 tooltip => "Items recently identified",
2674 },
2675 "c/examine" => {
2676 id => "infobox",
2677 title => "Examine",
2678 reply => undef,
2679 tooltip => "Signs and other items you examined",
2680 },
2681 "c/lookat" => {
2682 id => "infobox",
2683 title => "Look",
2684 reply => undef,
2685 tooltip => "What you saw there",
2686 },
2687);
2688
2535sub cf::client::send_msg { 2689sub cf::client::send_msg {
2536 my ($self, $channel, $msg, $color, @extra) = @_; 2690 my ($self, $channel, $msg, $color, @extra) = @_;
2537 2691
2538 $msg = $self->pl->expand_cfpod ($msg); 2692 $msg = $self->pl->expand_cfpod ($msg);
2539 2693
2540 $color &= cf::NDI_CLIENT_MASK; # just in case... 2694 $color &= cf::NDI_CLIENT_MASK; # just in case...
2541 2695
2696 # check predefined channels, for the benefit of C
2697 if ($CHANNEL{$channel}) {
2698 $channel = $CHANNEL{$channel};
2699
2700 $self->ext_msg (channel_info => $channel)
2701 if $self->can_msg;
2702
2703 $channel = $channel->{id};
2704
2542 if (ref $channel) { 2705 } elsif (ref $channel) {
2543 # send meta info to client, if not yet sent 2706 # send meta info to client, if not yet sent
2544 unless (exists $self->{channel}{$channel->{id}}) { 2707 unless (exists $self->{channel}{$channel->{id}}) {
2545 $self->{channel}{$channel->{id}} = $channel; 2708 $self->{channel}{$channel->{id}} = $channel;
2546 $self->ext_msg (channel_info => $channel); 2709 $self->ext_msg (channel_info => $channel)
2710 if $self->can_msg;
2547 } 2711 }
2548 2712
2549 $channel = $channel->{id}; 2713 $channel = $channel->{id};
2550 } 2714 }
2551 2715
… …
2573 $color &= cf::NDI_COLOR_MASK; 2737 $color &= cf::NDI_COLOR_MASK;
2574 2738
2575 utf8::encode $msg; 2739 utf8::encode $msg;
2576 2740
2577 if (0 && $msg =~ /\[/) { 2741 if (0 && $msg =~ /\[/) {
2742 # COMMAND/INFO
2578 $self->send_packet ("drawextinfo $color 4 0 $msg") 2743 $self->send_packet ("drawextinfo $color 10 8 $msg")
2579 } else { 2744 } else {
2580 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; 2745 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2581 $self->send_packet ("drawinfo $color $msg") 2746 $self->send_packet ("drawinfo $color $msg")
2582 } 2747 }
2583 } 2748 }
… …
2591=cut 2756=cut
2592 2757
2593sub cf::client::ext_msg($$@) { 2758sub cf::client::ext_msg($$@) {
2594 my ($self, $type, @msg) = @_; 2759 my ($self, $type, @msg) = @_;
2595 2760
2596 my $extcmd = $self->extcmd;
2597
2598 if ($extcmd == 2) { 2761 if ($self->extcmd == 2) {
2599 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 2762 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2600 } elsif ($extcmd == 1) { # TODO: remove 2763 } elsif ($self->extcmd == 1) { # TODO: remove
2601 push @msg, msgtype => "event_$type"; 2764 push @msg, msgtype => "event_$type";
2765 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2766 }
2767}
2768
2769=item $client->ext_reply ($msgid, @msg)
2770
2771Sends an ext reply to the client.
2772
2773=cut
2774
2775sub cf::client::ext_reply($$@) {
2776 my ($self, $id, @msg) = @_;
2777
2778 if ($self->extcmd == 2) {
2779 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2780 } elsif ($self->extcmd == 1) {
2781 #TODO: version 1, remove
2782 unshift @msg, msgtype => "reply", msgid => $id;
2602 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 2783 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2603 } 2784 }
2604} 2785}
2605 2786
2606=item $success = $client->query ($flags, "text", \&cb) 2787=item $success = $client->query ($flags, "text", \&cb)
… …
2668 my ($type, $reply, @payload) = 2849 my ($type, $reply, @payload) =
2669 "ARRAY" eq ref $msg 2850 "ARRAY" eq ref $msg
2670 ? @$msg 2851 ? @$msg
2671 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove 2852 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2672 2853
2854 my @reply;
2855
2673 if (my $cb = $EXTICMD{$type}) { 2856 if (my $cb = $EXTICMD{$type}) {
2674 my @reply = $cb->($ns, @payload); 2857 @reply = $cb->($ns, @payload);
2675
2676 $ns->ext_reply ($reply, @reply)
2677 if $reply;
2678 } 2858 }
2859
2860 $ns->ext_reply ($reply, @reply)
2861 if $reply;
2862
2679 } else { 2863 } else {
2680 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 2864 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2681 } 2865 }
2682 2866
2683 cf::override; 2867 cf::override;
… …
2743=pod 2927=pod
2744 2928
2745The following functions and methods are available within a safe environment: 2929The following functions and methods are available within a safe environment:
2746 2930
2747 cf::object 2931 cf::object
2748 contr pay_amount pay_player map x y force_find force_add 2932 contr pay_amount pay_player map x y force_find force_add destroy
2749 insert remove 2933 insert remove name archname title slaying race decrease_ob_nr
2750 2934
2751 cf::object::player 2935 cf::object::player
2752 player 2936 player
2753 2937
2754 cf::player 2938 cf::player
… …
2759 2943
2760=cut 2944=cut
2761 2945
2762for ( 2946for (
2763 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 2947 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2764 insert remove inv)], 2948 insert remove inv name archname title slaying race
2949 decrease_ob_nr destroy)],
2765 ["cf::object::player" => qw(player)], 2950 ["cf::object::player" => qw(player)],
2766 ["cf::player" => qw(peaceful)], 2951 ["cf::player" => qw(peaceful)],
2767 ["cf::map" => qw(trigger)], 2952 ["cf::map" => qw(trigger)],
2768) { 2953) {
2769 no strict 'refs'; 2954 no strict 'refs';
… …
2845# the server's init and main functions 3030# the server's init and main functions
2846 3031
2847sub load_facedata($) { 3032sub load_facedata($) {
2848 my ($path) = @_; 3033 my ($path) = @_;
2849 3034
3035 # HACK to clear player env face cache, we need some signal framework
3036 # for this (global event?)
3037 %ext::player_env::MUSIC_FACE_CACHE = ();
3038
3039 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3040
2850 warn "loading facedata from $path\n"; 3041 warn "loading facedata from $path\n";
2851 3042
2852 my $facedata; 3043 my $facedata;
2853 0 < aio_load $path, $facedata 3044 0 < aio_load $path, $facedata
2854 or die "$path: $!"; 3045 or die "$path: $!";
2855 3046
2856 $facedata = Coro::Storable::thaw $facedata; 3047 $facedata = Coro::Storable::thaw $facedata;
2857 3048
2858 $facedata->{version} == 2 3049 $facedata->{version} == 2
2859 or cf::cleanup "$path: version mismatch, cannot proceed."; 3050 or cf::cleanup "$path: version mismatch, cannot proceed.";
3051
3052 # patch in the exptable
3053 $facedata->{resource}{"res/exp_table"} = {
3054 type => FT_RSRC,
3055 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3056 };
3057 cf::cede_to_tick;
2860 3058
2861 { 3059 {
2862 my $faces = $facedata->{faceinfo}; 3060 my $faces = $facedata->{faceinfo};
2863 3061
2864 while (my ($face, $info) = each %$faces) { 3062 while (my ($face, $info) = each %$faces) {
2865 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3063 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2866 cf::face::set_visibility $idx, $info->{visibility}; 3064 cf::face::set_visibility $idx, $info->{visibility};
2867 cf::face::set_magicmap $idx, $info->{magicmap}; 3065 cf::face::set_magicmap $idx, $info->{magicmap};
2868 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3066 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2869 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3067 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2870 3068
2871 cf::cede_to_tick; 3069 cf::cede_to_tick;
2872 } 3070 }
2873 3071
2874 while (my ($face, $info) = each %$faces) { 3072 while (my ($face, $info) = each %$faces) {
… …
2899 3097
2900 { 3098 {
2901 # TODO: for gcfclient pleasure, we should give resources 3099 # TODO: for gcfclient pleasure, we should give resources
2902 # that gcfclient doesn't grok a >10000 face index. 3100 # that gcfclient doesn't grok a >10000 face index.
2903 my $res = $facedata->{resource}; 3101 my $res = $facedata->{resource};
2904 my $enc = JSON::XS->new->utf8->canonical;
2905 3102
2906 my $soundconf = delete $res->{"res/sound.conf"}; 3103 my $soundconf = delete $res->{"res/sound.conf"};
2907 3104
2908 while (my ($name, $info) = each %$res) { 3105 while (my ($name, $info) = each %$res) {
2909 my $meta = $enc->encode ({
2910 name => $name,
2911 %{ $info->{meta} || {} },
2912 });
2913
2914 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3106 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3107 my $data;
2915 3108
2916 if ($info->{type} & 1) { 3109 if ($info->{type} & 1) {
2917 # prepend meta info 3110 # prepend meta info
2918 3111
3112 my $meta = $enc->encode ({
3113 name => $name,
3114 %{ $info->{meta} || {} },
3115 });
3116
2919 my $data = pack "(w/a*)*", $meta, $info->{data}; 3117 $data = pack "(w/a*)*", $meta, $info->{data};
2920 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2921
2922 cf::face::set_data $idx, 0, $data, $chk;
2923 } else { 3118 } else {
2924 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum}; 3119 $data = $info->{data};
2925 } 3120 }
2926 3121
3122 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2927 cf::face::set_type $idx, $info->{type}; 3123 cf::face::set_type $idx, $info->{type};
2928 3124
2929 cf::cede_to_tick; 3125 cf::cede_to_tick;
2930 } 3126 }
2931 3127
… …
2958 $ns->fx_want ($k, $v); 3154 $ns->fx_want ($k, $v);
2959 } 3155 }
2960}; 3156};
2961 3157
2962sub reload_regions { 3158sub reload_regions {
3159 # HACK to clear player env face cache, we need some signal framework
3160 # for this (global event?)
3161 %ext::player_env::MUSIC_FACE_CACHE = ();
3162
2963 load_resource_file "$MAPDIR/regions" 3163 load_resource_file "$MAPDIR/regions"
2964 or die "unable to load regions file\n"; 3164 or die "unable to load regions file\n";
2965 3165
2966 for (cf::region::list) { 3166 for (cf::region::list) {
2967 $_->{match} = qr/$_->{match}/ 3167 $_->{match} = qr/$_->{match}/
… …
3003 3203
3004sub init { 3204sub init {
3005 reload_resources; 3205 reload_resources;
3006} 3206}
3007 3207
3008sub cfg_load { 3208sub reload_config {
3009 open my $fh, "<:utf8", "$CONFDIR/config" 3209 open my $fh, "<:utf8", "$CONFDIR/config"
3010 or return; 3210 or return;
3011 3211
3012 local $/; 3212 local $/;
3013 *CFG = YAML::Syck::Load <$fh>; 3213 *CFG = YAML::Syck::Load <$fh>;
… …
3029sub main { 3229sub main {
3030 # we must not ever block the main coroutine 3230 # we must not ever block the main coroutine
3031 local $Coro::idle = sub { 3231 local $Coro::idle = sub {
3032 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3232 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3033 (async { 3233 (async {
3234 $Coro::current->{desc} = "IDLE BUG HANDLER";
3034 Event::one_event; 3235 Event::one_event;
3035 })->prio (Coro::PRIO_MAX); 3236 })->prio (Coro::PRIO_MAX);
3036 }; 3237 };
3037 3238
3038 cfg_load; 3239 reload_config;
3039 db_init; 3240 db_init;
3040 load_extensions; 3241 load_extensions;
3041 3242
3042 $TICK_WATCHER->start; 3243 $TICK_WATCHER->start;
3043 Event::loop; 3244 Event::loop;
… …
3110 # and maps saved/destroyed asynchronously. 3311 # and maps saved/destroyed asynchronously.
3111 warn "begin emergency player save\n"; 3312 warn "begin emergency player save\n";
3112 for my $login (keys %cf::PLAYER) { 3313 for my $login (keys %cf::PLAYER) {
3113 my $pl = $cf::PLAYER{$login} or next; 3314 my $pl = $cf::PLAYER{$login} or next;
3114 $pl->valid or next; 3315 $pl->valid or next;
3316 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3115 $pl->save; 3317 $pl->save;
3116 } 3318 }
3117 warn "end emergency player save\n"; 3319 warn "end emergency player save\n";
3118 3320
3119 warn "begin emergency map save\n"; 3321 warn "begin emergency map save\n";
… …
3236 warn "reloading cf.pm"; 3438 warn "reloading cf.pm";
3237 require cf; 3439 require cf;
3238 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3440 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3239 3441
3240 warn "loading config and database again"; 3442 warn "loading config and database again";
3241 cf::cfg_load; 3443 cf::reload_config;
3242 3444
3243 warn "loading extensions"; 3445 warn "loading extensions";
3244 cf::load_extensions; 3446 cf::load_extensions;
3245 3447
3246 warn "reattaching attachments to objects/players"; 3448 warn "reattaching attachments to objects/players";
… …
3282register_command "reload" => sub { 3484register_command "reload" => sub {
3283 my ($who, $arg) = @_; 3485 my ($who, $arg) = @_;
3284 3486
3285 if ($who->flag (FLAG_WIZ)) { 3487 if ($who->flag (FLAG_WIZ)) {
3286 $who->message ("reloading server."); 3488 $who->message ("reloading server.");
3489 async {
3490 $Coro::current->{desc} = "perl_reload";
3287 async { reload_perl }; 3491 reload_perl;
3492 };
3288 } 3493 }
3289}; 3494};
3290 3495
3291unshift @INC, $LIBDIR; 3496unshift @INC, $LIBDIR;
3292 3497
… …
3311 my $signal = new Coro::Signal; 3516 my $signal = new Coro::Signal;
3312 push @WAIT_FOR_TICK_BEGIN, $signal; 3517 push @WAIT_FOR_TICK_BEGIN, $signal;
3313 $signal->wait; 3518 $signal->wait;
3314} 3519}
3315 3520
3316 my $min = 1e6;#d#
3317 my $avg = 10;
3318$TICK_WATCHER = Event->timer ( 3521$TICK_WATCHER = Event->timer (
3319 reentrant => 0, 3522 reentrant => 0,
3320 parked => 1, 3523 parked => 1,
3321 prio => 0, 3524 prio => 0,
3322 at => $NEXT_TICK || $TICK, 3525 at => $NEXT_TICK || $TICK,
… …
3330 3533
3331 $NOW = $tick_start = Event::time; 3534 $NOW = $tick_start = Event::time;
3332 3535
3333 cf::server_tick; # one server iteration 3536 cf::server_tick; # one server iteration
3334 3537
3335 0 && sync_job {#d#
3336 for(1..10) {
3337 my $t = Event::time;
3338 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3339 or die;
3340
3341 $map->width (50);
3342 $map->height (50);
3343 $map->alloc;
3344 $map->_load_objects ("/tmp/x.map", 1);
3345 my $t = Event::time - $t;
3346
3347 #next unless $t < 0.0013;#d#
3348 if ($t < $min) {
3349 $min = $t;
3350 }
3351 $avg = $avg * 0.99 + $t * 0.01;
3352 }
3353 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3354 exit 0;
3355 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3356 };
3357
3358 $RUNTIME += $TICK; 3538 $RUNTIME += $TICK;
3359 $NEXT_TICK += $TICK; 3539 $NEXT_TICK += $TICK;
3360 3540
3361 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3541 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3362 $NEXT_RUNTIME_WRITE = $NOW + 10; 3542 $NEXT_RUNTIME_WRITE = $NOW + 10;
3363 Coro::async_pool { 3543 Coro::async_pool {
3544 $Coro::current->{desc} = "runtime saver";
3364 write_runtime 3545 write_runtime
3365 or warn "ERROR: unable to write runtime file: $!"; 3546 or warn "ERROR: unable to write runtime file: $!";
3366 }; 3547 };
3367 } 3548 }
3368 3549
3369# my $AFTER = Event::time;
3370# warn $AFTER - $NOW;#d#
3371
3372 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3550 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3373 $sig->send; 3551 $sig->send;
3374 } 3552 }
3375 while (my $sig = shift @WAIT_FOR_TICK) { 3553 while (my $sig = shift @WAIT_FOR_TICK) {
3376 $sig->send; 3554 $sig->send;
… …
3386 3564
3387 $LOAD = ($NOW - $tick_start) / $TICK; 3565 $LOAD = ($NOW - $tick_start) / $TICK;
3388 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3566 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3389 3567
3390 _post_tick; 3568 _post_tick;
3391
3392
3393 }, 3569 },
3394); 3570);
3395 3571
3396{ 3572{
3573 BDB::min_parallel 8;
3397 BDB::max_poll_time $TICK * 0.1; 3574 BDB::max_poll_time $TICK * 0.1;
3398 $BDB_POLL_WATCHER = Event->io ( 3575 $BDB_POLL_WATCHER = Event->io (
3399 reentrant => 0, 3576 reentrant => 0,
3400 fd => BDB::poll_fileno, 3577 fd => BDB::poll_fileno,
3401 poll => 'r', 3578 poll => 'r',
3402 prio => 0, 3579 prio => 0,
3403 data => WF_AUTOCANCEL, 3580 data => WF_AUTOCANCEL,
3404 cb => \&BDB::poll_cb, 3581 cb => \&BDB::poll_cb,
3405 ); 3582 );
3406 BDB::min_parallel 8;
3407 3583
3408 BDB::set_sync_prepare { 3584 BDB::set_sync_prepare {
3409 my $status; 3585 my $status;
3410 my $current = $Coro::current; 3586 my $current = $Coro::current;
3411 ( 3587 (
… …
3420 ) 3596 )
3421 }; 3597 };
3422 3598
3423 unless ($DB_ENV) { 3599 unless ($DB_ENV) {
3424 $DB_ENV = BDB::db_env_create; 3600 $DB_ENV = BDB::db_env_create;
3601 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3602 | BDB::LOG_AUTOREMOVE, 1);
3603 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3604 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3425 3605
3426 cf::sync_job { 3606 cf::sync_job {
3427 eval { 3607 eval {
3428 BDB::db_env_open 3608 BDB::db_env_open
3429 $DB_ENV, 3609 $DB_ENV,
… …
3431 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3611 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3432 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3612 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3433 0666; 3613 0666;
3434 3614
3435 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3615 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3436
3437 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3438 $DB_ENV->set_lk_detect;
3439 }; 3616 };
3440 3617
3441 cf::cleanup "db_env_open(db): $@" if $@; 3618 cf::cleanup "db_env_open(db): $@" if $@;
3442 }; 3619 };
3443 } 3620 }
3621
3622 $BDB_DEADLOCK_WATCHER = Event->timer (
3623 after => 3,
3624 interval => 1,
3625 hard => 1,
3626 prio => 0,
3627 data => WF_AUTOCANCEL,
3628 cb => sub {
3629 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3630 },
3631 );
3632 $BDB_CHECKPOINT_WATCHER = Event->timer (
3633 after => 11,
3634 interval => 60,
3635 hard => 1,
3636 prio => 0,
3637 data => WF_AUTOCANCEL,
3638 cb => sub {
3639 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3640 },
3641 );
3642 $BDB_TRICKLE_WATCHER = Event->timer (
3643 after => 5,
3644 interval => 10,
3645 hard => 1,
3646 prio => 0,
3647 data => WF_AUTOCANCEL,
3648 cb => sub {
3649 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3650 },
3651 );
3444} 3652}
3445 3653
3446{ 3654{
3447 IO::AIO::min_parallel 8; 3655 IO::AIO::min_parallel 8;
3448 3656
… …
3451 $AIO_POLL_WATCHER = Event->io ( 3659 $AIO_POLL_WATCHER = Event->io (
3452 reentrant => 0, 3660 reentrant => 0,
3453 data => WF_AUTOCANCEL, 3661 data => WF_AUTOCANCEL,
3454 fd => IO::AIO::poll_fileno, 3662 fd => IO::AIO::poll_fileno,
3455 poll => 'r', 3663 poll => 'r',
3456 prio => 6, 3664 prio => 0,
3457 cb => \&IO::AIO::poll_cb, 3665 cb => \&IO::AIO::poll_cb,
3458 ); 3666 );
3459} 3667}
3460 3668
3461my $_log_backtrace; 3669my $_log_backtrace;
… …
3467 3675
3468 # limit the # of concurrent backtraces 3676 # limit the # of concurrent backtraces
3469 if ($_log_backtrace < 2) { 3677 if ($_log_backtrace < 2) {
3470 ++$_log_backtrace; 3678 ++$_log_backtrace;
3471 async { 3679 async {
3680 $Coro::current->{desc} = "abt $msg";
3681
3472 my @bt = fork_call { 3682 my @bt = fork_call {
3473 @addr = map { sprintf "%x", $_ } @addr; 3683 @addr = map { sprintf "%x", $_ } @addr;
3474 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3684 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3475 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3685 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3476 or die "addr2line: $!"; 3686 or die "addr2line: $!";

Diff Legend

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