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.313 by root, Sun Jul 22 14:17:58 2007 UTC vs.
Revision 1.373 by root, Sat Sep 15 15:58:06 2007 UTC

… …
10use Event; 10use Event;
11use Opcode; 11use Opcode;
12use Safe; 12use Safe;
13use Safe::Hole; 13use Safe::Hole;
14 14
15use Coro 3.61 (); 15use Coro 3.64 ();
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 ();
… …
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
… …
320 my $guard = Coro::guard { 334 my $guard = Coro::guard {
321 $TICK_WATCHER->start; 335 $TICK_WATCHER->start;
322 }; 336 };
323 $TICK_WATCHER->stop; 337 $TICK_WATCHER->stop;
324 $guard 338 $guard
339}
340
341=item cf::get_slot $time[, $priority[, $name]]
342
343Allocate $time seconds of blocking CPU time at priority C<$priority>:
344This call blocks and returns only when you have at least C<$time> seconds
345of cpu time till the next tick. The slot is only valid till the next cede.
346
347The optional C<$name> can be used to identify the job to run. It might be
348used for statistical purposes and should identify the same time-class.
349
350Useful for short background jobs.
351
352=cut
353
354our @SLOT_QUEUE;
355our $SLOT_QUEUE;
356
357$SLOT_QUEUE->cancel if $SLOT_QUEUE;
358$SLOT_QUEUE = Coro::async {
359 my $signal = new Coro::Signal;
360
361 while () {
362 next_job:
363 my $avail = cf::till_tick;
364 if ($avail > 0.01) {
365 for (0 .. $#SLOT_QUEUE) {
366 if ($SLOT_QUEUE[$_][0] < $avail) {
367 my $job = splice @SLOT_QUEUE, $_, 1, ();
368 $job->[2]->send;
369 Coro::cede;
370 goto next_job;
371 }
372 }
373 }
374
375 if (@SLOT_QUEUE) {
376 # we do not use wait_For_tick() as it returns immediately when tick is inactive
377 push @cf::WAIT_FOR_TICK, $signal;
378 $signal->wait;
379 } else {
380 Coro::schedule;
381 }
382 }
383};
384
385sub get_slot($;$$) {
386 my ($time, $pri, $name) = @_;
387
388 $time = $TICK * .6 if $time > $TICK * .6;
389 my $sig = new Coro::Signal;
390
391 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
392 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
393 $SLOT_QUEUE->ready;
394 $sig->wait;
325} 395}
326 396
327=item cf::async { BLOCK } 397=item cf::async { BLOCK }
328 398
329Currently the same as Coro::async_pool, meaning you cannot use 399Currently the same as Coro::async_pool, meaning you cannot use
… …
416Coro::Storable. May, of course, block. Note that the executed sub may 486Coro::Storable. May, of course, block. Note that the executed sub may
417never block itself or use any form of Event handling. 487never block itself or use any form of Event handling.
418 488
419=cut 489=cut
420 490
421sub _store_scalar {
422 open my $fh, ">", \my $buf
423 or die "fork_call: cannot open fh-to-buf in child : $!";
424 Storable::store_fd $_[0], $fh;
425 close $fh;
426
427 $buf
428}
429
430sub fork_call(&@) { 491sub fork_call(&@) {
431 my ($cb, @args) = @_; 492 my ($cb, @args) = @_;
432 493
433# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 494 # we seemingly have to make a local copy of the whole thing,
434# or die "socketpair: $!"; 495 # otherwise perl prematurely frees the stuff :/
435 pipe my $fh1, my $fh2 496 # TODO: investigate and fix (likely this will be rather laborious)
436 or die "pipe: $!";
437 497
438 if (my $pid = fork) { 498 my @res = Coro::Util::fork_eval {
439 close $fh2;
440
441 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
442 warn "pst<$res>" unless $res =~ /^pst/;
443 $res = Coro::Storable::thaw $res;
444
445 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
446
447 Carp::confess $$res unless "ARRAY" eq ref $res;
448
449 return wantarray ? @$res : $res->[-1];
450 } else {
451 reset_signals; 499 reset_signals;
452 local $SIG{__WARN__}; 500 &$cb
453 local $SIG{__DIE__}; 501 }, @args;
454 # just in case, this hack effectively disables event
455 # in the child. cleaner and slower would be canceling all watchers,
456 # but this works for the time being.
457 local $Coro::idle;
458 $Coro::current->prio (Coro::PRIO_MAX);
459 502
460 eval { 503 wantarray ? @res : $res[-1]
461 close $fh1;
462
463 my @res = eval { $cb->(@args) };
464
465 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
466 close $fh2;
467 };
468
469 warn $@ if $@;
470 _exit 0;
471 }
472} 504}
473 505
474=item $value = cf::db_get $family => $key 506=item $value = cf::db_get $family => $key
475 507
476Returns a single value from the environment database. 508Returns a single value from the environment database.
… …
478=item cf::db_put $family => $key => $value 510=item cf::db_put $family => $key => $value
479 511
480Stores the given C<$value> in the family. It can currently store binary 512Stores the given C<$value> in the family. It can currently store binary
481data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 513data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
482 514
515=item $db = cf::db_table "name"
516
517Create and/or open a new database table. The string must not be "db" and must be unique
518within each server.
519
483=cut 520=cut
521
522sub db_table($) {
523 my ($name) = @_;
524 my $db = BDB::db_create $DB_ENV;
525
526 eval {
527 $db->set_flags (BDB::CHKSUM);
528
529 utf8::encode $name;
530 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
531 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
532 cf::cleanup "db_open(db): $!" if $!;
533 };
534 cf::cleanup "db_open(db): $@" if $@;
535
536 $db
537}
484 538
485our $DB; 539our $DB;
486 540
487sub db_init { 541sub db_init {
488 unless ($DB) {
489 $DB = BDB::db_create $DB_ENV;
490
491 cf::sync_job { 542 cf::sync_job {
492 eval { 543 $DB ||= db_table "db";
493 $DB->set_flags (BDB::CHKSUM);
494
495 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
496 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
497 cf::cleanup "db_open(db): $!" if $!;
498 };
499 cf::cleanup "db_open(db): $@" if $@;
500 };
501 } 544 };
502} 545}
503 546
504sub db_get($$) { 547sub db_get($$) {
505 my $key = "$_[0]/$_[1]"; 548 my $key = "$_[0]/$_[1]";
506 549
… …
556 if (1) { 599 if (1) {
557 $md5 = 600 $md5 =
558 join "\x00", 601 join "\x00",
559 $processversion, 602 $processversion,
560 map { 603 map {
561 Coro::cede; 604 cf::cede_to_tick;
562 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 605 ($src->[$_], Digest::MD5::md5_hex $data[$_])
563 } 0.. $#$src; 606 } 0.. $#$src;
564 607
565 608
566 my $dbmd5 = db_get cache => "$id/md5"; 609 my $dbmd5 = db_get cache => "$id/md5";
… …
985sub object_freezer_save { 1028sub object_freezer_save {
986 my ($filename, $rdata, $objs) = @_; 1029 my ($filename, $rdata, $objs) = @_;
987 1030
988 sync_job { 1031 sync_job {
989 if (length $$rdata) { 1032 if (length $$rdata) {
1033 utf8::decode (my $decname = $filename);
990 warn sprintf "saving %s (%d,%d)\n", 1034 warn sprintf "saving %s (%d,%d)\n",
991 $filename, length $$rdata, scalar @$objs; 1035 $decname, length $$rdata, scalar @$objs;
992 1036
993 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1037 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
994 chmod SAVE_MODE, $fh; 1038 chmod SAVE_MODE, $fh;
995 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1039 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
996 aio_fsync $fh if $cf::USE_FSYNC; 1040 aio_fsync $fh if $cf::USE_FSYNC;
… …
1015 } 1059 }
1016 } else { 1060 } else {
1017 aio_unlink $filename; 1061 aio_unlink $filename;
1018 aio_unlink "$filename.pst"; 1062 aio_unlink "$filename.pst";
1019 } 1063 }
1020 } 1064 };
1021} 1065}
1022 1066
1023sub object_freezer_as_string { 1067sub object_freezer_as_string {
1024 my ($rdata, $objs) = @_; 1068 my ($rdata, $objs) = @_;
1025 1069
… …
1037 or return; 1081 or return;
1038 1082
1039 unless (aio_stat "$filename.pst") { 1083 unless (aio_stat "$filename.pst") {
1040 (aio_load "$filename.pst", $av) >= 0 1084 (aio_load "$filename.pst", $av) >= 0
1041 or return; 1085 or return;
1086
1042 $av = eval { (Storable::thaw $av)->{objs} }; 1087 $av = eval { (Storable::thaw $av)->{objs} };
1043 } 1088 }
1044 1089
1090 utf8::decode (my $decname = $filename);
1045 warn sprintf "loading %s (%d)\n", 1091 warn sprintf "loading %s (%d,%d)\n",
1046 $filename, length $data, scalar @{$av || []}; 1092 $decname, length $data, scalar @{$av || []};
1093
1047 return ($data, $av); 1094 ($data, $av)
1048} 1095}
1049 1096
1050=head2 COMMAND CALLBACKS 1097=head2 COMMAND CALLBACKS
1051 1098
1052=over 4 1099=over 4
… …
1125 my ($pl, $buf) = @_; 1172 my ($pl, $buf) = @_;
1126 1173
1127 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1174 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1128 1175
1129 if (ref $msg) { 1176 if (ref $msg) {
1177 my ($type, $reply, @payload) =
1178 "ARRAY" eq ref $msg
1179 ? @$msg
1180 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1181
1182 my @reply;
1183
1130 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1184 if (my $cb = $EXTCMD{$type}) {
1131 if (my %reply = $cb->($pl, $msg)) { 1185 @reply = $cb->($pl, @payload);
1132 $pl->ext_reply ($msg->{msgid}, %reply);
1133 }
1134 } 1186 }
1187
1188 $pl->ext_reply ($reply, @reply)
1189 if $reply;
1190
1135 } else { 1191 } else {
1136 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1192 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1137 } 1193 }
1138 1194
1139 cf::override; 1195 cf::override;
… …
1229 1285
1230=head3 cf::player 1286=head3 cf::player
1231 1287
1232=over 4 1288=over 4
1233 1289
1290=item cf::player::num_playing
1291
1292Returns the official number of playing players, as per the Crossfire metaserver rules.
1293
1294=cut
1295
1296sub num_playing {
1297 scalar grep
1298 $_->ob->map
1299 && !$_->hidden
1300 && !$_->ob->flag (cf::FLAG_WIZ),
1301 cf::player::list
1302}
1303
1234=item cf::player::find $login 1304=item cf::player::find $login
1235 1305
1236Returns the given player object, loading it if necessary (might block). 1306Returns the given player object, loading it if necessary (might block).
1237 1307
1238=cut 1308=cut
… …
1273 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1343 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1274 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1344 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1275 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1345 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1276 aio_unlink +(playerdir $login) . "/$login.pl"; 1346 aio_unlink +(playerdir $login) . "/$login.pl";
1277 1347
1278 my $pl = load_pl path $login 1348 my $f = new_from_file cf::object::thawer path $login
1279 or return; 1349 or return;
1350
1351 my $pl = cf::player::load_pl $f
1352 or return;
1353 local $cf::PLAYER_LOADING{$login} = $pl;
1354 $f->resolve_delayed_derefs;
1280 $cf::PLAYER{$login} = $pl 1355 $cf::PLAYER{$login} = $pl
1281 } 1356 }
1282 } 1357 }
1283} 1358}
1284 1359
… …
1294 1369
1295 aio_mkdir playerdir $pl, 0770; 1370 aio_mkdir playerdir $pl, 0770;
1296 $pl->{last_save} = $cf::RUNTIME; 1371 $pl->{last_save} = $cf::RUNTIME;
1297 1372
1298 $pl->save_pl ($path); 1373 $pl->save_pl ($path);
1299 Coro::cede; 1374 cf::cede_to_tick;
1300} 1375}
1301 1376
1302sub new($) { 1377sub new($) {
1303 my ($login) = @_; 1378 my ($login) = @_;
1304 1379
… …
1308 $self->{deny_save} = 1; 1383 $self->{deny_save} = 1;
1309 1384
1310 $cf::PLAYER{$login} = $self; 1385 $cf::PLAYER{$login} = $self;
1311 1386
1312 $self 1387 $self
1388}
1389
1390=item $player->send_msg ($channel, $msg, $color, [extra...])
1391
1392=cut
1393
1394sub send_msg {
1395 my $ns = shift->ns
1396 or return;
1397 $ns->send_msg (@_);
1313} 1398}
1314 1399
1315=item $pl->quit_character 1400=item $pl->quit_character
1316 1401
1317Nukes the player without looking back. If logged in, the connection will 1402Nukes the player without looking back. If logged in, the connection will
… …
1372 or return []; 1457 or return [];
1373 1458
1374 my @logins; 1459 my @logins;
1375 1460
1376 for my $login (@$dirs) { 1461 for my $login (@$dirs) {
1462 my $path = path $login;
1463
1464 # a .pst is a dead give-away for a valid player
1465 unless (-e "$path.pst") {
1377 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1466 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1378 aio_read $fh, 0, 512, my $buf, 0 or next; 1467 aio_read $fh, 0, 512, my $buf, 0 or next;
1379 $buf !~ /^password -------------$/m or next; # official not-valid tag 1468 $buf !~ /^password -------------$/m or next; # official not-valid tag
1469 }
1380 1470
1381 utf8::decode $login; 1471 utf8::decode $login;
1382 push @logins, $login; 1472 push @logins, $login;
1383 } 1473 }
1384 1474
… …
1422sub expand_cfpod { 1512sub expand_cfpod {
1423 ((my $self), (local $_)) = @_; 1513 ((my $self), (local $_)) = @_;
1424 1514
1425 # escape & and < 1515 # escape & and <
1426 s/&/&amp;/g; 1516 s/&/&amp;/g;
1427 s/(?<![BIUGH])</&lt;/g; 1517 s/(?<![BIUGHT])</&lt;/g;
1428 1518
1429 # this is buggy, it needs to properly take care of nested <'s 1519 # this is buggy, it needs to properly take care of nested <'s
1430 1520
1431 1 while 1521 1 while
1432 # replace B<>, I<>, U<> etc. 1522 # replace B<>, I<>, U<> etc.
1433 s/B<([^\>]*)>/<b>$1<\/b>/ 1523 s/B<([^\>]*)>/<b>$1<\/b>/
1434 || s/I<([^\>]*)>/<i>$1<\/i>/ 1524 || s/I<([^\>]*)>/<i>$1<\/i>/
1435 || s/U<([^\>]*)>/<u>$1<\/u>/ 1525 || s/U<([^\>]*)>/<u>$1<\/u>/
1526 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1436 # replace G<male|female> tags 1527 # replace G<male|female> tags
1437 || s{G<([^>|]*)\|([^>]*)>}{ 1528 || s{G<([^>|]*)\|([^>]*)>}{
1438 $self->gender ? $2 : $1 1529 $self->gender ? $2 : $1
1439 }ge 1530 }ge
1440 # replace H<hint text> 1531 # replace H<hint text>
… …
1461sub hintmode { 1552sub hintmode {
1462 $_[0]{hintmode} = $_[1] if @_ > 1; 1553 $_[0]{hintmode} = $_[1] if @_ > 1;
1463 $_[0]{hintmode} 1554 $_[0]{hintmode}
1464} 1555}
1465 1556
1466=item $player->ext_reply ($msgid, %msg) 1557=item $player->ext_reply ($msgid, @msg)
1467 1558
1468Sends an ext reply to the player. 1559Sends an ext reply to the player.
1469 1560
1470=cut 1561=cut
1471 1562
1472sub ext_reply($$%) { 1563sub ext_reply($$@) {
1473 my ($self, $id, %msg) = @_; 1564 my ($self, $id, @msg) = @_;
1474 1565
1475 $msg{msgid} = $id; 1566 $self->ns->ext_reply ($id, @msg)
1476 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1477} 1567}
1478 1568
1479=item $player->ext_event ($type, %msg) 1569=item $player->ext_msg ($type, @msg)
1480 1570
1481Sends an ext event to the client. 1571Sends an ext event to the client.
1482 1572
1483=cut 1573=cut
1484 1574
1485sub ext_event($$%) { 1575sub ext_msg($$@) {
1486 my ($self, $type, %msg) = @_; 1576 my ($self, $type, @msg) = @_;
1487 1577
1488 $self->ns->ext_event ($type, %msg); 1578 $self->ns->ext_msg ($type, @msg);
1489} 1579}
1490 1580
1491=head3 cf::region 1581=head3 cf::region
1492 1582
1493=over 4 1583=over 4
… …
1709 1799
1710sub load_header_from($) { 1800sub load_header_from($) {
1711 my ($self, $path) = @_; 1801 my ($self, $path) = @_;
1712 1802
1713 utf8::encode $path; 1803 utf8::encode $path;
1714 #aio_open $path, O_RDONLY, 0 1804 my $f = new_from_file cf::object::thawer $path
1715 # or return;
1716
1717 $self->_load_header ($path)
1718 or return; 1805 or return;
1806
1807 $self->_load_header ($f)
1808 or return;
1809
1810 local $MAP_LOADING{$self->{path}} = $self;
1811 $f->resolve_delayed_derefs;
1719 1812
1720 $self->{load_path} = $path; 1813 $self->{load_path} = $path;
1721 1814
1722 1 1815 1
1723} 1816}
… …
1777sub find { 1870sub find {
1778 my ($path, $origin) = @_; 1871 my ($path, $origin) = @_;
1779 1872
1780 $path = normalise $path, $origin && $origin->path; 1873 $path = normalise $path, $origin && $origin->path;
1781 1874
1875 cf::lock_wait "map_data:$path";#d#remove
1782 cf::lock_wait "map_find:$path"; 1876 cf::lock_wait "map_find:$path";
1783 1877
1784 $cf::MAP{$path} || do { 1878 $cf::MAP{$path} || do {
1785 my $guard = cf::lock_acquire "map_find:$path"; 1879 my $guard1 = cf::lock_acquire "map_find:$path";
1880 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1881
1786 my $map = new_from_path cf::map $path 1882 my $map = new_from_path cf::map $path
1787 or return; 1883 or return;
1788 1884
1789 $map->{last_save} = $cf::RUNTIME; 1885 $map->{last_save} = $cf::RUNTIME;
1790 1886
… …
1792 or return; 1888 or return;
1793 1889
1794 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1890 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1795 # doing this can freeze the server in a sync job, obviously 1891 # doing this can freeze the server in a sync job, obviously
1796 #$cf::WAIT_FOR_TICK->wait; 1892 #$cf::WAIT_FOR_TICK->wait;
1893 undef $guard1;
1894 undef $guard2;
1797 $map->reset; 1895 $map->reset;
1798 undef $guard;
1799 return find $path; 1896 return find $path;
1800 } 1897 }
1801 1898
1802 $cf::MAP{$path} = $map 1899 $cf::MAP{$path} = $map
1803 } 1900 }
… …
1812 local $self->{deny_reset} = 1; # loading can take a long time 1909 local $self->{deny_reset} = 1; # loading can take a long time
1813 1910
1814 my $path = $self->{path}; 1911 my $path = $self->{path};
1815 1912
1816 { 1913 {
1817 my $guard = cf::lock_acquire "map_load:$path"; 1914 my $guard = cf::lock_acquire "map_data:$path";
1818 1915
1916 return unless $self->valid;
1819 return if $self->in_memory != cf::MAP_SWAPPED; 1917 return unless $self->in_memory == cf::MAP_SWAPPED;
1820 1918
1821 $self->in_memory (cf::MAP_LOADING); 1919 $self->in_memory (cf::MAP_LOADING);
1822 1920
1823 $self->alloc; 1921 $self->alloc;
1824 1922
1825 $self->pre_load; 1923 $self->pre_load;
1826 Coro::cede; 1924 cf::cede_to_tick;
1827 1925
1926 my $f = new_from_file cf::object::thawer $self->{load_path};
1927 $f->skip_block;
1828 $self->_load_objects ($self->{load_path}, 1) 1928 $self->_load_objects ($f)
1829 or return; 1929 or return;
1830 1930
1831 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1931 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1832 if delete $self->{load_original}; 1932 if delete $self->{load_original};
1833 1933
1834 if (my $uniq = $self->uniq_path) { 1934 if (my $uniq = $self->uniq_path) {
1835 utf8::encode $uniq; 1935 utf8::encode $uniq;
1836 if (aio_open $uniq, O_RDONLY, 0) { 1936 unless (aio_stat $uniq) {
1937 if (my $f = new_from_file cf::object::thawer $uniq) {
1837 $self->clear_unique_items; 1938 $self->clear_unique_items;
1838 $self->_load_objects ($uniq, 0); 1939 $self->_load_objects ($f);
1940 $f->resolve_delayed_derefs;
1941 }
1839 } 1942 }
1840 } 1943 }
1841 1944
1842 Coro::cede; 1945 $f->resolve_delayed_derefs;
1946
1947 cf::cede_to_tick;
1843 # now do the right thing for maps 1948 # now do the right thing for maps
1844 $self->link_multipart_objects; 1949 $self->link_multipart_objects;
1845 $self->difficulty ($self->estimate_difficulty) 1950 $self->difficulty ($self->estimate_difficulty)
1846 unless $self->difficulty; 1951 unless $self->difficulty;
1847 Coro::cede; 1952 cf::cede_to_tick;
1848 1953
1849 unless ($self->{deny_activate}) { 1954 unless ($self->{deny_activate}) {
1850 $self->decay_objects; 1955 $self->decay_objects;
1851 $self->fix_auto_apply; 1956 $self->fix_auto_apply;
1852 $self->update_buttons; 1957 $self->update_buttons;
1853 Coro::cede; 1958 cf::cede_to_tick;
1854 $self->set_darkness_map; 1959 $self->set_darkness_map;
1855 Coro::cede; 1960 cf::cede_to_tick;
1856 $self->activate; 1961 $self->activate;
1857 } 1962 }
1963
1964 $self->{last_save} = $cf::RUNTIME;
1965 $self->last_access ($cf::RUNTIME);
1858 1966
1859 $self->in_memory (cf::MAP_IN_MEMORY); 1967 $self->in_memory (cf::MAP_IN_MEMORY);
1860 } 1968 }
1861 1969
1862 $self->post_load; 1970 $self->post_load;
… …
1873 1981
1874 $self 1982 $self
1875} 1983}
1876 1984
1877# find and load all maps in the 3x3 area around a map 1985# find and load all maps in the 3x3 area around a map
1878sub load_diag { 1986sub load_neighbours {
1879 my ($map) = @_; 1987 my ($map) = @_;
1880 1988
1881 my @diag; # diagonal neighbours 1989 my @neigh; # diagonal neighbours
1882 1990
1883 for (0 .. 3) { 1991 for (0 .. 3) {
1884 my $neigh = $map->tile_path ($_) 1992 my $neigh = $map->tile_path ($_)
1885 or next; 1993 or next;
1886 $neigh = find $neigh, $map 1994 $neigh = find $neigh, $map
1887 or next; 1995 or next;
1888 $neigh->load; 1996 $neigh->load;
1889 1997
1998 push @neigh,
1890 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 1999 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1891 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2000 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1892 } 2001 }
1893 2002
1894 for (@diag) { 2003 for (grep defined $_->[0], @neigh) {
2004 my ($path, $origin) = @$_;
1895 my $neigh = find @$_ 2005 my $neigh = find $path, $origin
1896 or next; 2006 or next;
1897 $neigh->load; 2007 $neigh->load;
1898 } 2008 }
1899} 2009}
1900 2010
… …
1905} 2015}
1906 2016
1907sub do_load_sync { 2017sub do_load_sync {
1908 my ($map) = @_; 2018 my ($map) = @_;
1909 2019
2020 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2021 if $Coro::current == $Coro::main;
2022
1910 cf::sync_job { $map->load }; 2023 cf::sync_job { $map->load };
1911} 2024}
1912 2025
1913our %MAP_PREFETCH; 2026our %MAP_PREFETCH;
1914our $MAP_PREFETCHER = undef; 2027our $MAP_PREFETCHER = undef;
1915 2028
1916sub find_async { 2029sub find_async {
1917 my ($path, $origin) = @_; 2030 my ($path, $origin, $load) = @_;
1918 2031
1919 $path = normalise $path, $origin && $origin->{path}; 2032 $path = normalise $path, $origin && $origin->{path};
1920 2033
1921 if (my $map = $cf::MAP{$path}) { 2034 if (my $map = $cf::MAP{$path}) {
1922 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2035 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1923 } 2036 }
1924 2037
1925 undef $MAP_PREFETCH{$path}; 2038 $MAP_PREFETCH{$path} |= $load;
2039
1926 $MAP_PREFETCHER ||= cf::async { 2040 $MAP_PREFETCHER ||= cf::async {
1927 while (%MAP_PREFETCH) { 2041 while (%MAP_PREFETCH) {
1928 for my $path (keys %MAP_PREFETCH) { 2042 while (my ($k, $v) = each %MAP_PREFETCH) {
1929 if (my $map = find $path) { 2043 if (my $map = find $k) {
1930 $map->load; 2044 $map->load if $v;
1931 } 2045 }
1932 2046
1933 delete $MAP_PREFETCH{$path}; 2047 delete $MAP_PREFETCH{$k};
1934 } 2048 }
1935 } 2049 }
1936 undef $MAP_PREFETCHER; 2050 undef $MAP_PREFETCHER;
1937 }; 2051 };
1938 $MAP_PREFETCHER->prio (6); 2052 $MAP_PREFETCHER->prio (6);
… …
1941} 2055}
1942 2056
1943sub save { 2057sub save {
1944 my ($self) = @_; 2058 my ($self) = @_;
1945 2059
1946 my $lock = cf::lock_acquire "map_data:" . $self->path; 2060 my $lock = cf::lock_acquire "map_data:$self->{path}";
1947 2061
1948 $self->{last_save} = $cf::RUNTIME; 2062 $self->{last_save} = $cf::RUNTIME;
1949 2063
1950 return unless $self->dirty; 2064 return unless $self->dirty;
1951 2065
… …
1974 my ($self) = @_; 2088 my ($self) = @_;
1975 2089
1976 # save first because save cedes 2090 # save first because save cedes
1977 $self->save; 2091 $self->save;
1978 2092
1979 my $lock = cf::lock_acquire "map_data:" . $self->path; 2093 my $lock = cf::lock_acquire "map_data:$self->{path}";
1980 2094
1981 return if $self->players; 2095 return if $self->players;
1982 return if $self->in_memory != cf::MAP_IN_MEMORY; 2096 return if $self->in_memory != cf::MAP_IN_MEMORY;
1983 return if $self->{deny_save}; 2097 return if $self->{deny_save};
1984 2098
2099 $self->in_memory (cf::MAP_SWAPPED);
2100
2101 $self->deactivate;
2102 $_->clear_links_to ($self) for values %cf::MAP;
1985 $self->clear; 2103 $self->clear;
1986 $self->in_memory (cf::MAP_SWAPPED);
1987} 2104}
1988 2105
1989sub reset_at { 2106sub reset_at {
1990 my ($self) = @_; 2107 my ($self) = @_;
1991 2108
… …
2023 if $uniq; 2140 if $uniq;
2024 } 2141 }
2025 2142
2026 delete $cf::MAP{$self->path}; 2143 delete $cf::MAP{$self->path};
2027 2144
2145 $self->deactivate;
2146 $_->clear_links_to ($self) for values %cf::MAP;
2028 $self->clear; 2147 $self->clear;
2029
2030 $_->clear_links_to ($self) for values %cf::MAP;
2031 2148
2032 $self->unlink_save; 2149 $self->unlink_save;
2033 $self->destroy; 2150 $self->destroy;
2034} 2151}
2035 2152
2036my $nuke_counter = "aaaa"; 2153my $nuke_counter = "aaaa";
2037 2154
2038sub nuke { 2155sub nuke {
2039 my ($self) = @_; 2156 my ($self) = @_;
2040 2157
2158 {
2159 my $lock = cf::lock_acquire "map_data:$self->{path}";
2160
2041 delete $cf::MAP{$self->path}; 2161 delete $cf::MAP{$self->path};
2042 2162
2043 $self->unlink_save; 2163 $self->unlink_save;
2044 2164
2045 bless $self, "cf::map"; 2165 bless $self, "cf::map";
2046 delete $self->{deny_reset}; 2166 delete $self->{deny_reset};
2047 $self->{deny_save} = 1; 2167 $self->{deny_save} = 1;
2048 $self->reset_timeout (1); 2168 $self->reset_timeout (1);
2049 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2169 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2050 2170
2051 $cf::MAP{$self->path} = $self; 2171 $cf::MAP{$self->path} = $self;
2172 }
2052 2173
2053 $self->reset; # polite request, might not happen 2174 $self->reset; # polite request, might not happen
2054} 2175}
2055 2176
2056=item $maps = cf::map::tmp_maps 2177=item $maps = cf::map::tmp_maps
… …
2132 2253
2133sub inv_recursive { 2254sub inv_recursive {
2134 inv_recursive_ inv $_[0] 2255 inv_recursive_ inv $_[0]
2135} 2256}
2136 2257
2258=item $ref = $ob->ref
2259
2260creates and returns a persistent reference to an objetc that can be stored as a string.
2261
2262=item $ob = cf::object::deref ($refstring)
2263
2264returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2265even if the object actually exists. May block.
2266
2267=cut
2268
2269sub deref {
2270 my ($ref) = @_;
2271
2272 # temporary compatibility#TODO#remove
2273 $ref =~ s{^<}{player/<};
2274
2275 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
2276 my ($uuid, $name) = ($1, $2);
2277 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2278 or return;
2279 $pl->ob->uuid eq $uuid
2280 or return;
2281
2282 $pl->ob
2283 } else {
2284 warn "$ref: cannot resolve object reference\n";
2285 undef
2286 }
2287}
2288
2137package cf; 2289package cf;
2138 2290
2139=back 2291=back
2140 2292
2141=head3 cf::object::player 2293=head3 cf::object::player
… …
2163 2315
2164 } else { 2316 } else {
2165 my $pl = $self->contr; 2317 my $pl = $self->contr;
2166 2318
2167 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) { 2319 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2168 my $diag = $pl->{npc_dialog}; 2320 my $dialog = $pl->{npc_dialog};
2169 $diag->{pl}->ext_reply ( 2321 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2170 $diag->{id},
2171 msgtype => "reply",
2172 msg => $diag->{pl}->expand_cfpod ($msg),
2173 add_topics => []
2174 );
2175 2322
2176 } else { 2323 } else {
2177 $msg = $npc->name . " says: $msg" if $npc; 2324 $msg = $npc->name . " says: $msg" if $npc;
2178 $self->message ($msg, $flags); 2325 $self->message ($msg, $flags);
2179 } 2326 }
2180 } 2327 }
2328}
2329
2330=item $object->send_msg ($channel, $msg, $color, [extra...])
2331
2332=cut
2333
2334sub cf::object::send_msg {
2335 my $pl = shift->contr
2336 or return;
2337 $pl->send_msg (@_);
2181} 2338}
2182 2339
2183=item $player_object->may ("access") 2340=item $player_object->may ("access")
2184 2341
2185Returns wether the given player is authorized to access resource "access" 2342Returns wether the given player is authorized to access resource "access"
… …
2264 # use -1 or undef as default coordinates, not 0, 0 2421 # use -1 or undef as default coordinates, not 0, 0
2265 ($x, $y) = ($map->enter_x, $map->enter_y) 2422 ($x, $y) = ($map->enter_x, $map->enter_y)
2266 if $x <=0 && $y <= 0; 2423 if $x <=0 && $y <= 0;
2267 2424
2268 $map->load; 2425 $map->load;
2269 $map->load_diag; 2426 $map->load_neighbours;
2270 2427
2271 return unless $self->contr->active; 2428 return unless $self->contr->active;
2272 $self->activate_recursive; 2429 $self->activate_recursive;
2273 2430
2274 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2431 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
… …
2294 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2451 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2295 2452
2296 $self->enter_link; 2453 $self->enter_link;
2297 2454
2298 (async { 2455 (async {
2456 # *tag paths override both path and x|y
2457 if ($path =~ /^\*(.*)$/) {
2458 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2459 my $ob = $obs[rand @obs];
2460
2461 # see if we actually can go there
2462 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2463 $ob = $obs[rand @obs];
2464 } else {
2465 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2466 }
2467 # else put us there anyways for now #d#
2468
2469 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2470 } else {
2471 ($path, $x, $y) = (undef, undef, undef);
2472 }
2473 }
2474
2299 my $map = eval { 2475 my $map = eval {
2300 my $map = cf::map::find $path; 2476 my $map = defined $path ? cf::map::find $path : undef;
2301 2477
2302 if ($map) { 2478 if ($map) {
2303 $map = $map->customise_for ($self); 2479 $map = $map->customise_for ($self);
2304 $map = $check->($map) if $check && $map; 2480 $map = $check->($map) if $check && $map;
2305 } else { 2481 } else {
2306 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2482 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2307 } 2483 }
2308 2484
2309 $map 2485 $map
2310 }; 2486 };
2311 2487
… …
2445the message, with C<log> being the default. If C<$color> is negative, suppress 2621the message, with C<log> being the default. If C<$color> is negative, suppress
2446the message unless the client supports the msg packet. 2622the message unless the client supports the msg packet.
2447 2623
2448=cut 2624=cut
2449 2625
2626our %CHANNEL = (
2627 "c/identify" => {
2628 id => "identify",
2629 title => "Identify",
2630 reply => undef,
2631 tooltip => "Items recently identified",
2632 },
2633 "c/examine" => {
2634 id => "examine",
2635 title => "Examine",
2636 reply => undef,
2637 tooltip => "Signs and other items you examined",
2638 },
2639);
2640
2450sub cf::client::send_msg { 2641sub cf::client::send_msg {
2451 my ($self, $channel, $msg, $color, @extra) = @_; 2642 my ($self, $channel, $msg, $color, @extra) = @_;
2452 2643
2453 $msg = $self->pl->expand_cfpod ($msg); 2644 $msg = $self->pl->expand_cfpod ($msg);
2454 2645
2455 $color &= ~cf::NDI_UNIQUE; # just in case... 2646 $color &= cf::NDI_CLIENT_MASK; # just in case...
2647
2648 # check predefined channels, for the benefit of C
2649 $channel = $CHANNEL{$channel} if $CHANNEL{$channel};
2456 2650
2457 if (ref $channel) { 2651 if (ref $channel) {
2458 # send meta info to client, if not yet sent 2652 # send meta info to client, if not yet sent
2459 unless (exists $self->{channel}{$channel->{id}}) { 2653 unless (exists $self->{channel}{$channel->{id}}) {
2460 $self->{channel}{$channel->{id}} = $channel; 2654 $self->{channel}{$channel->{id}} = $channel;
2461 $self->ext_event (channel_info => %$channel); 2655 $self->ext_msg (channel_info => $channel)
2656 if $self->can_msg;
2462 } 2657 }
2463 2658
2464 $channel = $channel->{id}; 2659 $channel = $channel->{id};
2465 } 2660 }
2466 2661
2467 return unless @extra || length $msg; 2662 return unless @extra || length $msg;
2468 2663
2469 if ($self->can_msg) { 2664 if ($self->can_msg) {
2665 # default colour, mask it out
2666 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2667 if $color & cf::NDI_DEF;
2668
2470 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra])); 2669 $self->send_packet ("msg " . $self->{json_coder}->encode (
2670 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2471 } else { 2671 } else {
2472 # replace some tags by gcfclient-compatible ones
2473 for ($msg) {
2474 1 while
2475 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2476 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2477 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2478 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2479 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2480 }
2481
2482 if ($color >= 0) { 2672 if ($color >= 0) {
2673 # replace some tags by gcfclient-compatible ones
2674 for ($msg) {
2675 1 while
2676 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2677 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2678 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2679 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2680 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2681 }
2682
2683 $color &= cf::NDI_COLOR_MASK;
2684
2685 utf8::encode $msg;
2686
2483 if (0 && $msg =~ /\[/) { 2687 if (0 && $msg =~ /\[/) {
2688 # COMMAND/INFO
2484 $self->send_packet ("drawextinfo $color 4 0 $msg") 2689 $self->send_packet ("drawextinfo $color 10 8 $msg")
2485 } else { 2690 } else {
2486 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; 2691 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2487 $self->send_packet ("drawinfo $color $msg") 2692 $self->send_packet ("drawinfo $color $msg")
2488 } 2693 }
2489 } 2694 }
2490 } 2695 }
2491} 2696}
2492 2697
2493=item $client->ext_event ($type, %msg) 2698=item $client->ext_msg ($type, @msg)
2494 2699
2495Sends an ext event to the client. 2700Sends an ext event to the client.
2496 2701
2497=cut 2702=cut
2498 2703
2499sub cf::client::ext_event($$%) { 2704sub cf::client::ext_msg($$@) {
2500 my ($self, $type, %msg) = @_; 2705 my ($self, $type, @msg) = @_;
2501 2706
2502 return unless $self->extcmd; 2707 if ($self->extcmd == 2) {
2503 2708 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2709 } elsif ($self->extcmd == 1) { # TODO: remove
2504 $msg{msgtype} = "event_$type"; 2710 push @msg, msgtype => "event_$type";
2505 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg)); 2711 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2712 }
2713}
2714
2715=item $client->ext_reply ($msgid, @msg)
2716
2717Sends an ext reply to the client.
2718
2719=cut
2720
2721sub cf::client::ext_reply($$@) {
2722 my ($self, $id, @msg) = @_;
2723
2724 if ($self->extcmd == 2) {
2725 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2726 } elsif ($self->extcmd == 1) {
2727 #TODO: version 1, remove
2728 unshift @msg, msgtype => "reply", msgid => $id;
2729 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2730 }
2506} 2731}
2507 2732
2508=item $success = $client->query ($flags, "text", \&cb) 2733=item $success = $client->query ($flags, "text", \&cb)
2509 2734
2510Queues a query to the client, calling the given callback with 2735Queues a query to the client, calling the given callback with
… …
2565 my ($ns, $buf) = @_; 2790 my ($ns, $buf) = @_;
2566 2791
2567 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 2792 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2568 2793
2569 if (ref $msg) { 2794 if (ref $msg) {
2795 my ($type, $reply, @payload) =
2796 "ARRAY" eq ref $msg
2797 ? @$msg
2798 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2799
2800 my @reply;
2801
2570 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 2802 if (my $cb = $EXTICMD{$type}) {
2571 if (my %reply = $cb->($ns, $msg)) { 2803 @reply = $cb->($ns, @payload);
2572 $reply{msgid} = $msg->{msgid};
2573 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2574 }
2575 } 2804 }
2805
2806 $ns->ext_reply ($reply, @reply)
2807 if $reply;
2808
2576 } else { 2809 } else {
2577 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 2810 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2578 } 2811 }
2579 2812
2580 cf::override; 2813 cf::override;
… …
2627our $safe = new Safe "safe"; 2860our $safe = new Safe "safe";
2628our $safe_hole = new Safe::Hole; 2861our $safe_hole = new Safe::Hole;
2629 2862
2630$SIG{FPE} = 'IGNORE'; 2863$SIG{FPE} = 'IGNORE';
2631 2864
2632$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2865$safe->permit_only (Opcode::opset qw(
2866 :base_core :base_mem :base_orig :base_math
2867 grepstart grepwhile mapstart mapwhile
2868 sort time
2869));
2633 2870
2634# here we export the classes and methods available to script code 2871# here we export the classes and methods available to script code
2635 2872
2636=pod 2873=pod
2637 2874
2638The following functions and methods are available within a safe environment: 2875The following functions and methods are available within a safe environment:
2639 2876
2640 cf::object 2877 cf::object
2641 contr pay_amount pay_player map x y force_find force_add 2878 contr pay_amount pay_player map x y force_find force_add
2642 insert remove 2879 insert remove name archname title slaying race decrease_ob_nr
2643 2880
2644 cf::object::player 2881 cf::object::player
2645 player 2882 player
2646 2883
2647 cf::player 2884 cf::player
… …
2652 2889
2653=cut 2890=cut
2654 2891
2655for ( 2892for (
2656 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 2893 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2894 insert remove inv name archname title slaying race
2657 insert remove)], 2895 decrease_ob_nr)],
2658 ["cf::object::player" => qw(player)], 2896 ["cf::object::player" => qw(player)],
2659 ["cf::player" => qw(peaceful)], 2897 ["cf::player" => qw(peaceful)],
2660 ["cf::map" => qw(trigger)], 2898 ["cf::map" => qw(trigger)],
2661) { 2899) {
2662 no strict 'refs'; 2900 no strict 'refs';
… …
2738# the server's init and main functions 2976# the server's init and main functions
2739 2977
2740sub load_facedata($) { 2978sub load_facedata($) {
2741 my ($path) = @_; 2979 my ($path) = @_;
2742 2980
2981 # HACK to clear player env face cache, we need some signal framework
2982 # for this (global event?)
2983 %ext::player_env::MUSIC_FACE_CACHE = ();
2984
2985 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2986
2743 warn "loading facedata from $path\n"; 2987 warn "loading facedata from $path\n";
2744 2988
2745 my $facedata; 2989 my $facedata;
2746 0 < aio_load $path, $facedata 2990 0 < aio_load $path, $facedata
2747 or die "$path: $!"; 2991 or die "$path: $!";
2748 2992
2749 $facedata = Coro::Storable::thaw $facedata; 2993 $facedata = Coro::Storable::thaw $facedata;
2750 2994
2751 $facedata->{version} == 2 2995 $facedata->{version} == 2
2752 or cf::cleanup "$path: version mismatch, cannot proceed."; 2996 or cf::cleanup "$path: version mismatch, cannot proceed.";
2997
2998 # patch in the exptable
2999 $facedata->{resource}{"res/exp_table"} = {
3000 type => FT_RSRC,
3001 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3002 };
3003 cf::cede_to_tick;
2753 3004
2754 { 3005 {
2755 my $faces = $facedata->{faceinfo}; 3006 my $faces = $facedata->{faceinfo};
2756 3007
2757 while (my ($face, $info) = each %$faces) { 3008 while (my ($face, $info) = each %$faces) {
2758 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3009 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2759 cf::face::set_visibility $idx, $info->{visibility}; 3010 cf::face::set_visibility $idx, $info->{visibility};
2760 cf::face::set_magicmap $idx, $info->{magicmap}; 3011 cf::face::set_magicmap $idx, $info->{magicmap};
2761 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3012 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2762 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3013 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2763 3014
2764 cf::cede_to_tick; 3015 cf::cede_to_tick;
2765 } 3016 }
2766 3017
2767 while (my ($face, $info) = each %$faces) { 3018 while (my ($face, $info) = each %$faces) {
… …
2792 3043
2793 { 3044 {
2794 # TODO: for gcfclient pleasure, we should give resources 3045 # TODO: for gcfclient pleasure, we should give resources
2795 # that gcfclient doesn't grok a >10000 face index. 3046 # that gcfclient doesn't grok a >10000 face index.
2796 my $res = $facedata->{resource}; 3047 my $res = $facedata->{resource};
2797 my $enc = JSON::XS->new->utf8->canonical; 3048
3049 my $soundconf = delete $res->{"res/sound.conf"};
2798 3050
2799 while (my ($name, $info) = each %$res) { 3051 while (my ($name, $info) = each %$res) {
2800 my $meta = $enc->encode ({
2801 name => $name,
2802 type => $info->{type},
2803 copyright => $info->{copyright}, #TODO#
2804 });
2805
2806 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3052 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3053 my $data;
2807 3054
2808 if ($name =~ /\.jpg$/) { 3055 if ($info->{type} & 1) {
2809 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack 3056 # prepend meta info
2810 cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack 3057
3058 my $meta = $enc->encode ({
3059 name => $name,
3060 %{ $info->{meta} || {} },
3061 });
3062
3063 $data = pack "(w/a*)*", $meta, $info->{data};
2811 } else { 3064 } else {
2812 my $data = pack "(w/a*)*", $meta, $info->{data}; 3065 $data = $info->{data};
2813 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2814
2815 cf::face::set_type $idx, 1;
2816 cf::face::set_data $idx, 0, $data, $chk;
2817 } 3066 }
2818 3067
3068 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3069 cf::face::set_type $idx, $info->{type};
3070
2819 cf::cede_to_tick; 3071 cf::cede_to_tick;
2820 } 3072 }
3073
3074 if ($soundconf) {
3075 $soundconf = $enc->decode (delete $soundconf->{data});
3076
3077 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3078 my $sound = $soundconf->{compat}[$_]
3079 or next;
3080
3081 my $face = cf::face::find "sound/$sound->[1]";
3082 cf::sound::set $sound->[0] => $face;
3083 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3084 }
3085
3086 while (my ($k, $v) = each %{$soundconf->{event}}) {
3087 my $face = cf::face::find "sound/$v";
3088 cf::sound::set $k => $face;
3089 }
3090 }
2821 } 3091 }
2822 3092
2823 1 3093 1
2824} 3094}
2825 3095
3096register_exticmd fx_want => sub {
3097 my ($ns, $want) = @_;
3098
3099 while (my ($k, $v) = each %$want) {
3100 $ns->fx_want ($k, $v);
3101 }
3102};
3103
2826sub reload_regions { 3104sub reload_regions {
3105 # HACK to clear player env face cache, we need some signal framework
3106 # for this (global event?)
3107 %ext::player_env::MUSIC_FACE_CACHE = ();
3108
2827 load_resource_file "$MAPDIR/regions" 3109 load_resource_file "$MAPDIR/regions"
2828 or die "unable to load regions file\n"; 3110 or die "unable to load regions file\n";
2829 3111
2830 for (cf::region::list) { 3112 for (cf::region::list) {
2831 $_->{match} = qr/$_->{match}/ 3113 $_->{match} = qr/$_->{match}/
… …
2867 3149
2868sub init { 3150sub init {
2869 reload_resources; 3151 reload_resources;
2870} 3152}
2871 3153
2872sub cfg_load { 3154sub reload_config {
2873 open my $fh, "<:utf8", "$CONFDIR/config" 3155 open my $fh, "<:utf8", "$CONFDIR/config"
2874 or return; 3156 or return;
2875 3157
2876 local $/; 3158 local $/;
2877 *CFG = YAML::Syck::Load <$fh>; 3159 *CFG = YAML::Syck::Load <$fh>;
… …
2897 (async { 3179 (async {
2898 Event::one_event; 3180 Event::one_event;
2899 })->prio (Coro::PRIO_MAX); 3181 })->prio (Coro::PRIO_MAX);
2900 }; 3182 };
2901 3183
2902 cfg_load; 3184 reload_config;
2903 db_init; 3185 db_init;
2904 load_extensions; 3186 load_extensions;
2905 3187
2906 $TICK_WATCHER->start; 3188 $TICK_WATCHER->start;
2907 Event::loop; 3189 Event::loop;
… …
3100 warn "reloading cf.pm"; 3382 warn "reloading cf.pm";
3101 require cf; 3383 require cf;
3102 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3384 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3103 3385
3104 warn "loading config and database again"; 3386 warn "loading config and database again";
3105 cf::cfg_load; 3387 cf::reload_config;
3106 3388
3107 warn "loading extensions"; 3389 warn "loading extensions";
3108 cf::load_extensions; 3390 cf::load_extensions;
3109 3391
3110 warn "reattaching attachments to objects/players"; 3392 warn "reattaching attachments to objects/players";
… …
3175 my $signal = new Coro::Signal; 3457 my $signal = new Coro::Signal;
3176 push @WAIT_FOR_TICK_BEGIN, $signal; 3458 push @WAIT_FOR_TICK_BEGIN, $signal;
3177 $signal->wait; 3459 $signal->wait;
3178} 3460}
3179 3461
3180 my $min = 1e6;#d#
3181 my $avg = 10;
3182$TICK_WATCHER = Event->timer ( 3462$TICK_WATCHER = Event->timer (
3183 reentrant => 0, 3463 reentrant => 0,
3184 parked => 1, 3464 parked => 1,
3185 prio => 0, 3465 prio => 0,
3186 at => $NEXT_TICK || $TICK, 3466 at => $NEXT_TICK || $TICK,
… …
3194 3474
3195 $NOW = $tick_start = Event::time; 3475 $NOW = $tick_start = Event::time;
3196 3476
3197 cf::server_tick; # one server iteration 3477 cf::server_tick; # one server iteration
3198 3478
3199 0 && sync_job {#d#
3200 for(1..10) {
3201 my $t = Event::time;
3202 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3203 or die;
3204
3205 $map->width (50);
3206 $map->height (50);
3207 $map->alloc;
3208 $map->_load_objects ("/tmp/x.map", 1);
3209 my $t = Event::time - $t;
3210
3211 #next unless $t < 0.0013;#d#
3212 if ($t < $min) {
3213 $min = $t;
3214 }
3215 $avg = $avg * 0.99 + $t * 0.01;
3216 }
3217 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3218 exit 0;
3219 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3220 };
3221
3222 $RUNTIME += $TICK; 3479 $RUNTIME += $TICK;
3223 $NEXT_TICK += $TICK; 3480 $NEXT_TICK += $TICK;
3224 3481
3225 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3482 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3226 $NEXT_RUNTIME_WRITE = $NOW + 10; 3483 $NEXT_RUNTIME_WRITE = $NOW + 10;
… …
3228 write_runtime 3485 write_runtime
3229 or warn "ERROR: unable to write runtime file: $!"; 3486 or warn "ERROR: unable to write runtime file: $!";
3230 }; 3487 };
3231 } 3488 }
3232 3489
3233# my $AFTER = Event::time;
3234# warn $AFTER - $NOW;#d#
3235
3236 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3490 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3237 $sig->send; 3491 $sig->send;
3238 } 3492 }
3239 while (my $sig = shift @WAIT_FOR_TICK) { 3493 while (my $sig = shift @WAIT_FOR_TICK) {
3240 $sig->send; 3494 $sig->send;
… …
3250 3504
3251 $LOAD = ($NOW - $tick_start) / $TICK; 3505 $LOAD = ($NOW - $tick_start) / $TICK;
3252 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3506 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3253 3507
3254 _post_tick; 3508 _post_tick;
3255
3256
3257 }, 3509 },
3258); 3510);
3259 3511
3260{ 3512{
3513 BDB::min_parallel 8;
3261 BDB::max_poll_time $TICK * 0.1; 3514 BDB::max_poll_time $TICK * 0.1;
3262 $BDB_POLL_WATCHER = Event->io ( 3515 $BDB_POLL_WATCHER = Event->io (
3263 reentrant => 0, 3516 reentrant => 0,
3264 fd => BDB::poll_fileno, 3517 fd => BDB::poll_fileno,
3265 poll => 'r', 3518 poll => 'r',
3266 prio => 0, 3519 prio => 0,
3267 data => WF_AUTOCANCEL, 3520 data => WF_AUTOCANCEL,
3268 cb => \&BDB::poll_cb, 3521 cb => \&BDB::poll_cb,
3269 ); 3522 );
3270 BDB::min_parallel 8;
3271 3523
3272 BDB::set_sync_prepare { 3524 BDB::set_sync_prepare {
3273 my $status; 3525 my $status;
3274 my $current = $Coro::current; 3526 my $current = $Coro::current;
3275 ( 3527 (
… …
3284 ) 3536 )
3285 }; 3537 };
3286 3538
3287 unless ($DB_ENV) { 3539 unless ($DB_ENV) {
3288 $DB_ENV = BDB::db_env_create; 3540 $DB_ENV = BDB::db_env_create;
3541 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3542 | BDB::LOG_AUTOREMOVE, 1);
3543 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3544 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3289 3545
3290 cf::sync_job { 3546 cf::sync_job {
3291 eval { 3547 eval {
3292 BDB::db_env_open 3548 BDB::db_env_open
3293 $DB_ENV, 3549 $DB_ENV,
… …
3295 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3551 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3296 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3552 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3297 0666; 3553 0666;
3298 3554
3299 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3555 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3300
3301 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3302 $DB_ENV->set_lk_detect;
3303 }; 3556 };
3304 3557
3305 cf::cleanup "db_env_open(db): $@" if $@; 3558 cf::cleanup "db_env_open(db): $@" if $@;
3306 }; 3559 };
3307 } 3560 }
3561
3562 $BDB_DEADLOCK_WATCHER = Event->timer (
3563 after => 3,
3564 interval => 1,
3565 hard => 1,
3566 prio => 0,
3567 data => WF_AUTOCANCEL,
3568 cb => sub {
3569 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3570 },
3571 );
3572 $BDB_CHECKPOINT_WATCHER = Event->timer (
3573 after => 11,
3574 interval => 60,
3575 hard => 1,
3576 prio => 0,
3577 data => WF_AUTOCANCEL,
3578 cb => sub {
3579 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3580 },
3581 );
3582 $BDB_TRICKLE_WATCHER = Event->timer (
3583 after => 5,
3584 interval => 10,
3585 hard => 1,
3586 prio => 0,
3587 data => WF_AUTOCANCEL,
3588 cb => sub {
3589 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3590 },
3591 );
3308} 3592}
3309 3593
3310{ 3594{
3311 IO::AIO::min_parallel 8; 3595 IO::AIO::min_parallel 8;
3312 3596

Diff Legend

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