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.494 by root, Mon Oct 26 05:18:00 2009 UTC vs.
Revision 1.530 by root, Wed Apr 28 21:05:33 2010 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify it under 6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the 7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your 8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version. 9# option) any later version.
… …
53use Coro::Util (); 53use Coro::Util ();
54 54
55use JSON::XS 2.01 (); 55use JSON::XS 2.01 ();
56use BDB (); 56use BDB ();
57use Data::Dumper; 57use Data::Dumper;
58use Digest::MD5;
59use Fcntl; 58use Fcntl;
60use YAML::XS (); 59use YAML::XS ();
61use IO::AIO (); 60use IO::AIO ();
62use Time::HiRes; 61use Time::HiRes;
63use Compress::LZF; 62use Compress::LZF;
… …
107our $RANDOMDIR = "$LOCALDIR/random"; 106our $RANDOMDIR = "$LOCALDIR/random";
108our $BDBDIR = "$LOCALDIR/db"; 107our $BDBDIR = "$LOCALDIR/db";
109our $PIDFILE = "$LOCALDIR/pid"; 108our $PIDFILE = "$LOCALDIR/pid";
110our $RUNTIMEFILE = "$LOCALDIR/runtime"; 109our $RUNTIMEFILE = "$LOCALDIR/runtime";
111 110
112our %RESOURCE; 111our %RESOURCE; # unused
112
113our $OUTPUT_RATE_MIN = 3000;
114our $OUTPUT_RATE_MAX = 1000000;
115
116our $MAX_LINKS = 32; # how many chained exits to follow
117our $VERBOSE_IO = 1;
113 118
114our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 119our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
115our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
116our $NEXT_TICK; 121our $NEXT_TICK;
117our $USE_FSYNC = 1; # use fsync to write maps - default on 122our $USE_FSYNC = 1; # use fsync to write maps - default on
… …
163 168
164our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
165 170
166sub cf::map::normalise; 171sub cf::map::normalise;
167 172
173sub in_main() {
174 $Coro::current == $Coro::main
175}
176
168############################################################################# 177#############################################################################
169 178
170%REFLECT = (); 179%REFLECT = ();
171for (@REFLECT) { 180for (@REFLECT) {
172 my $reflect = JSON::XS::decode_json $_; 181 my $reflect = JSON::XS::decode_json $_;
… …
259$Coro::State::DIEHOOK = sub { 268$Coro::State::DIEHOOK = sub {
260 return unless $^S eq 0; # "eq", not "==" 269 return unless $^S eq 0; # "eq", not "=="
261 270
262 warn Carp::longmess $_[0]; 271 warn Carp::longmess $_[0];
263 272
264 if ($Coro::current == $Coro::main) {#d# 273 if (in_main) {#d#
265 warn "DIEHOOK called in main context, Coro bug?\n";#d# 274 warn "DIEHOOK called in main context, Coro bug?\n";#d#
266 return;#d# 275 return;#d#
267 }#d# 276 }#d#
268 277
269 # kill coroutine otherwise 278 # kill coroutine otherwise
… …
397} 406}
398 407
399=item cf::periodic $interval, $cb 408=item cf::periodic $interval, $cb
400 409
401Like EV::periodic, but randomly selects a starting point so that the actions 410Like EV::periodic, but randomly selects a starting point so that the actions
402get spread over timer. 411get spread over time.
403 412
404=cut 413=cut
405 414
406sub periodic($$) { 415sub periodic($$) {
407 my ($interval, $cb) = @_; 416 my ($interval, $cb) = @_;
… …
424 433
425=cut 434=cut
426 435
427our @SLOT_QUEUE; 436our @SLOT_QUEUE;
428our $SLOT_QUEUE; 437our $SLOT_QUEUE;
438our $SLOT_DECAY = 0.9;
429 439
430$SLOT_QUEUE->cancel if $SLOT_QUEUE; 440$SLOT_QUEUE->cancel if $SLOT_QUEUE;
431$SLOT_QUEUE = Coro::async { 441$SLOT_QUEUE = Coro::async {
432 $Coro::current->desc ("timeslot manager"); 442 $Coro::current->desc ("timeslot manager");
433 443
434 my $signal = new Coro::Signal; 444 my $signal = new Coro::Signal;
445 my $busy;
435 446
436 while () { 447 while () {
437 next_job: 448 next_job:
449
438 my $avail = cf::till_tick; 450 my $avail = cf::till_tick;
439 if ($avail > 0.01) { 451
440 for (0 .. $#SLOT_QUEUE) { 452 for (0 .. $#SLOT_QUEUE) {
441 if ($SLOT_QUEUE[$_][0] < $avail) { 453 if ($SLOT_QUEUE[$_][0] <= $avail) {
454 $busy = 0;
442 my $job = splice @SLOT_QUEUE, $_, 1, (); 455 my $job = splice @SLOT_QUEUE, $_, 1, ();
443 $job->[2]->send; 456 $job->[2]->send;
444 Coro::cede; 457 Coro::cede;
445 goto next_job; 458 goto next_job;
446 } 459 } else {
460 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
447 } 461 }
448 } 462 }
449 463
450 if (@SLOT_QUEUE) { 464 if (@SLOT_QUEUE) {
451 # we do not use wait_for_tick() as it returns immediately when tick is inactive 465 # we do not use wait_for_tick() as it returns immediately when tick is inactive
452 push @cf::WAIT_FOR_TICK, $signal; 466 push @cf::WAIT_FOR_TICK, $signal;
453 $signal->wait; 467 $signal->wait;
454 } else { 468 } else {
469 $busy = 0;
455 Coro::schedule; 470 Coro::schedule;
456 } 471 }
457 } 472 }
458}; 473};
459 474
460sub get_slot($;$$) { 475sub get_slot($;$$) {
461 return if tick_inhibit || $Coro::current == $Coro::main; 476 return if tick_inhibit || $Coro::current == $Coro::main;
462 477
463 my ($time, $pri, $name) = @_; 478 my ($time, $pri, $name) = @_;
464 479
465 $time = $TICK * .6 if $time > $TICK * .6; 480 $time = clamp $time, 0.01, $TICK * .6;
481
466 my $sig = new Coro::Signal; 482 my $sig = new Coro::Signal;
467 483
468 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 484 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
469 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 485 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
470 $SLOT_QUEUE->ready; 486 $SLOT_QUEUE->ready;
… …
497 513
498sub sync_job(&) { 514sub sync_job(&) {
499 my ($job) = @_; 515 my ($job) = @_;
500 516
501 if ($Coro::current == $Coro::main) { 517 if ($Coro::current == $Coro::main) {
502 my $time = EV::time; 518 my $time = AE::time;
503 519
504 # this is the main coro, too bad, we have to block 520 # this is the main coro, too bad, we have to block
505 # till the operation succeeds, freezing the server :/ 521 # till the operation succeeds, freezing the server :/
506 522
507 LOG llevError, Carp::longmess "sync job";#d# 523 LOG llevError, Carp::longmess "sync job";#d#
… …
524 } else { 540 } else {
525 EV::loop EV::LOOP_ONESHOT; 541 EV::loop EV::LOOP_ONESHOT;
526 } 542 }
527 } 543 }
528 544
529 my $time = EV::time - $time; 545 my $time = AE::time - $time;
530 546
531 $TICK_START += $time; # do not account sync jobs to server load 547 $TICK_START += $time; # do not account sync jobs to server load
532 548
533 wantarray ? @res : $res[0] 549 wantarray ? @res : $res[0]
534 } else { 550 } else {
… …
578 reset_signals; 594 reset_signals;
579 &$cb 595 &$cb
580 }, @args; 596 }, @args;
581 597
582 wantarray ? @res : $res[-1] 598 wantarray ? @res : $res[-1]
599}
600
601sub objinfo {
602 (
603 "counter value" => cf::object::object_count,
604 "objects created" => cf::object::create_count,
605 "objects destroyed" => cf::object::destroy_count,
606 "freelist size" => cf::object::free_count,
607 "allocated objects" => cf::object::objects_size,
608 "active objects" => cf::object::actives_size,
609 )
583} 610}
584 611
585=item $coin = coin_from_name $name 612=item $coin = coin_from_name $name
586 613
587=cut 614=cut
… …
1168 1195
1169 sync_job { 1196 sync_job {
1170 if (length $$rdata) { 1197 if (length $$rdata) {
1171 utf8::decode (my $decname = $filename); 1198 utf8::decode (my $decname = $filename);
1172 warn sprintf "saving %s (%d,%d)\n", 1199 warn sprintf "saving %s (%d,%d)\n",
1173 $decname, length $$rdata, scalar @$objs; 1200 $decname, length $$rdata, scalar @$objs
1201 if $VERBOSE_IO;
1174 1202
1175 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1203 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1176 aio_chmod $fh, SAVE_MODE; 1204 aio_chmod $fh, SAVE_MODE;
1177 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1205 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1178 if ($cf::USE_FSYNC) { 1206 if ($cf::USE_FSYNC) {
… …
1235 $av = $st->{objs}; 1263 $av = $st->{objs};
1236 } 1264 }
1237 1265
1238 utf8::decode (my $decname = $filename); 1266 utf8::decode (my $decname = $filename);
1239 warn sprintf "loading %s (%d,%d)\n", 1267 warn sprintf "loading %s (%d,%d)\n",
1240 $decname, length $data, scalar @{$av || []}; 1268 $decname, length $data, scalar @{$av || []}
1269 if $VERBOSE_IO;
1241 1270
1242 ($data, $av) 1271 ($data, $av)
1243} 1272}
1244 1273
1245=head2 COMMAND CALLBACKS 1274=head2 COMMAND CALLBACKS
… …
1304} 1333}
1305 1334
1306use File::Glob (); 1335use File::Glob ();
1307 1336
1308cf::player->attach ( 1337cf::player->attach (
1309 on_command => sub { 1338 on_unknown_command => sub {
1310 my ($pl, $name, $params) = @_; 1339 my ($pl, $name, $params) = @_;
1311 1340
1312 my $cb = $COMMAND{$name} 1341 my $cb = $COMMAND{$name}
1313 or return; 1342 or return;
1314 1343
… …
1393 . "\n};\n1"; 1422 . "\n};\n1";
1394 1423
1395 $todo{$base} = \%ext; 1424 $todo{$base} = \%ext;
1396 } 1425 }
1397 1426
1427 my $pass = 0;
1398 my %done; 1428 my %done;
1399 while (%todo) { 1429 while (%todo) {
1400 my $progress; 1430 my $progress;
1401 1431
1432 ++$pass;
1433
1434 ext:
1402 while (my ($k, $v) = each %todo) { 1435 while (my ($k, $v) = each %todo) {
1403 for (split /,\s*/, $v->{meta}{depends}) { 1436 for (split /,\s*/, $v->{meta}{depends}) {
1404 goto skip 1437 next ext
1405 unless exists $done{$_}; 1438 unless exists $done{$_};
1406 } 1439 }
1407 1440
1408 warn "... loading '$k' into '$v->{pkg}'\n"; 1441 warn "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1409 1442
1410 unless (eval $v->{source}) { 1443 my $active = eval $v->{source};
1444
1445 if (length $@) {
1411 my $msg = $@ ? "$v->{path}: $@\n" 1446 warn "$v->{path}: $@\n";
1412 : "$v->{base}: extension inactive.\n";
1413 1447
1414 if (exists $v->{meta}{mandatory}) {
1415 warn $msg;
1416 cf::cleanup "mandatory extension failed to load, exiting."; 1448 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1417 } 1449 if exists $v->{meta}{mandatory};
1418 1450
1419 warn $msg; 1451 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1452 delete $todo{$k};
1453 } else {
1454 $done{$k} = delete $todo{$k};
1455 push @EXTS, $v->{pkg};
1456 $progress = 1;
1457
1458 warn "$v->{base}: extension inactive.\n"
1459 unless $active;
1420 } 1460 }
1421
1422 $done{$k} = delete $todo{$k};
1423 push @EXTS, $v->{pkg};
1424 $progress = 1;
1425 } 1461 }
1426 1462
1427 skip: 1463 unless ($progress) {
1428 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1464 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1429 unless $progress; 1465
1466 while (my ($k, $v) = each %todo) {
1467 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1468 if exists $v->{meta}{mandatory};
1469 }
1470 }
1430 } 1471 }
1431 }; 1472 };
1432} 1473}
1433 1474
1434############################################################################# 1475#############################################################################
… …
1518 $cf::PLAYER{$login} = $pl 1559 $cf::PLAYER{$login} = $pl
1519 } 1560 }
1520 } 1561 }
1521} 1562}
1522 1563
1564cf::player->attach (
1565 on_load => sub {
1566 my ($pl, $path) = @_;
1567
1568 # restore slots saved in save, below
1569 my $slots = delete $pl->{_slots};
1570
1571 $pl->ob->current_weapon ($slots->[0]);
1572 $pl->combat_ob ($slots->[1]);
1573 $pl->ranged_ob ($slots->[2]);
1574 },
1575);
1576
1523sub save($) { 1577sub save($) {
1524 my ($pl) = @_; 1578 my ($pl) = @_;
1525 1579
1526 return if $pl->{deny_save}; 1580 return if $pl->{deny_save};
1527 1581
… …
1532 1586
1533 aio_mkdir playerdir $pl, 0770; 1587 aio_mkdir playerdir $pl, 0770;
1534 $pl->{last_save} = $cf::RUNTIME; 1588 $pl->{last_save} = $cf::RUNTIME;
1535 1589
1536 cf::get_slot 0.01; 1590 cf::get_slot 0.01;
1591
1592 # save slots, to be restored later
1593 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1537 1594
1538 $pl->save_pl ($path); 1595 $pl->save_pl ($path);
1539 cf::cede_to_tick; 1596 cf::cede_to_tick;
1540} 1597}
1541 1598
… …
1578 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1635 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1579 1636
1580 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1637 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1581 $pl->deactivate; 1638 $pl->deactivate;
1582 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1639 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1583 $pl->ob->check_score;
1584 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1640 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1585 $pl->ns->destroy if $pl->ns; 1641 $pl->ns->destroy if $pl->ns;
1586 1642
1587 my $path = playerdir $pl; 1643 my $path = playerdir $pl;
1588 my $temp = "$path~$cf::RUNTIME~deleting~"; 1644 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1643 \@logins 1699 \@logins
1644} 1700}
1645 1701
1646=item $player->maps 1702=item $player->maps
1647 1703
1704=item cf::player::maps $login
1705
1648Returns an arrayref of map paths that are private for this 1706Returns an arrayref of map paths that are private for this
1649player. May block. 1707player. May block.
1650 1708
1651=cut 1709=cut
1652 1710
… …
1714=cut 1772=cut
1715 1773
1716sub find_by_path($) { 1774sub find_by_path($) {
1717 my ($path) = @_; 1775 my ($path) = @_;
1718 1776
1777 $path =~ s/^~[^\/]*//; # skip ~login
1778
1719 my ($match, $specificity); 1779 my ($match, $specificity);
1720 1780
1721 for my $region (list) { 1781 for my $region (list) {
1722 if ($region->{match} && $path =~ $region->{match}) { 1782 if ($region->{match} && $path =~ $region->{match}) {
1723 ($match, $specificity) = ($region, $region->specificity) 1783 ($match, $specificity) = ($region, $region->specificity)
… …
1754 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1814 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1755 1815
1756 # mit "rum" bekleckern, nicht 1816 # mit "rum" bekleckern, nicht
1757 $self->_create_random_map ( 1817 $self->_create_random_map (
1758 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1818 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1759 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1819 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1760 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1820 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1761 $rmp->{exit_on_final_map}, 1821 $rmp->{exit_on_final_map},
1762 $rmp->{xsize}, $rmp->{ysize}, 1822 $rmp->{xsize}, $rmp->{ysize},
1763 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1823 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1764 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1824 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1786 1846
1787 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1847 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1788} 1848}
1789 1849
1790# also paths starting with '/' 1850# also paths starting with '/'
1791$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1851$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1792 1852
1793sub thawer_merge { 1853sub thawer_merge {
1794 my ($self, $merge) = @_; 1854 my ($self, $merge) = @_;
1795 1855
1796 # we have to keep some variables in memory intact 1856 # we have to keep some variables in memory intact
… …
2010 2070
2011 $cf::MAP{$path} = $map 2071 $cf::MAP{$path} = $map
2012 } 2072 }
2013} 2073}
2014 2074
2015sub pre_load { } 2075sub pre_load { }
2016sub post_load { } 2076#sub post_load { } # XS
2017 2077
2018sub load { 2078sub load {
2019 my ($self) = @_; 2079 my ($self) = @_;
2020 2080
2021 local $self->{deny_reset} = 1; # loading can take a long time 2081 local $self->{deny_reset} = 1; # loading can take a long time
… …
2078 } 2138 }
2079 2139
2080 $self->post_load; 2140 $self->post_load;
2081} 2141}
2082 2142
2143# customize the map for a given player, i.e.
2144# return the _real_ map. used by e.g. per-player
2145# maps to change the path to ~playername/mappath
2083sub customise_for { 2146sub customise_for {
2084 my ($self, $ob) = @_; 2147 my ($self, $ob) = @_;
2085 2148
2086 return find "~" . $ob->name . "/" . $self->{path} 2149 return find "~" . $ob->name . "/" . $self->{path}
2087 if $self->per_player; 2150 if $self->per_player;
… …
2103 or next; 2166 or next;
2104 $neigh = find $neigh, $map 2167 $neigh = find $neigh, $map
2105 or next; 2168 or next;
2106 $neigh->load; 2169 $neigh->load;
2107 2170
2171 # now find the diagonal neighbours
2108 push @neigh, 2172 push @neigh,
2109 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2173 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2110 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2174 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2111 } 2175 }
2112 2176
… …
2164 $MAP_PREFETCHER->prio (6); 2228 $MAP_PREFETCHER->prio (6);
2165 2229
2166 () 2230 ()
2167} 2231}
2168 2232
2233# common code, used by both ->save and ->swapout
2169sub save { 2234sub _save {
2170 my ($self) = @_; 2235 my ($self) = @_;
2171
2172 my $lock = cf::lock_acquire "map_data:$self->{path}";
2173 2236
2174 $self->{last_save} = $cf::RUNTIME; 2237 $self->{last_save} = $cf::RUNTIME;
2175 2238
2176 return unless $self->dirty; 2239 return unless $self->dirty;
2177 2240
… …
2197 } else { 2260 } else {
2198 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2261 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2199 } 2262 }
2200} 2263}
2201 2264
2265sub save {
2266 my ($self) = @_;
2267
2268 my $lock = cf::lock_acquire "map_data:$self->{path}";
2269
2270 $self->_save;
2271}
2272
2202sub swap_out { 2273sub swap_out {
2203 my ($self) = @_; 2274 my ($self) = @_;
2204 2275
2205 # save first because save cedes
2206 $self->save;
2207
2208 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2276 my $lock = cf::lock_acquire "map_data:$self->{path}";
2209 2277
2210 return if $self->players;
2211 return if $self->in_memory != cf::MAP_ACTIVE; 2278 return if $self->in_memory != cf::MAP_ACTIVE;
2212 return if $self->{deny_save}; 2279 return if $self->{deny_save};
2280 return if $self->players;
2213 2281
2282 # first deactivate the map and "unlink" it from the core
2283 $self->deactivate;
2284 $_->clear_links_to ($self) for values %cf::MAP;
2214 $self->in_memory (cf::MAP_SWAPPED); 2285 $self->in_memory (cf::MAP_SWAPPED);
2286
2287 # then atomically save
2288 $self->_save;
2289
2290 # then free the map
2291 $self->clear;
2292}
2293
2294sub reset_at {
2295 my ($self) = @_;
2296
2297 # TODO: safety, remove and allow resettable per-player maps
2298 return 1e99 if $self->{deny_reset};
2299
2300 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2301 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2302
2303 $time + $to
2304}
2305
2306sub should_reset {
2307 my ($self) = @_;
2308
2309 $self->reset_at <= $cf::RUNTIME
2310}
2311
2312sub reset {
2313 my ($self) = @_;
2314
2315 my $lock = cf::lock_acquire "map_data:$self->{path}";
2316
2317 return if $self->players;
2318
2319 warn "resetting map ", $self->path, "\n";
2320
2321 $self->in_memory (cf::MAP_SWAPPED);
2322
2323 # need to save uniques path
2324 unless ($self->{deny_save}) {
2325 my $uniq = $self->uniq_path; utf8::encode $uniq;
2326
2327 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2328 if $uniq;
2329 }
2330
2331 delete $cf::MAP{$self->path};
2215 2332
2216 $self->deactivate; 2333 $self->deactivate;
2217 $_->clear_links_to ($self) for values %cf::MAP; 2334 $_->clear_links_to ($self) for values %cf::MAP;
2218 $self->clear; 2335 $self->clear;
2219}
2220
2221sub reset_at {
2222 my ($self) = @_;
2223
2224 # TODO: safety, remove and allow resettable per-player maps
2225 return 1e99 if $self->{deny_reset};
2226
2227 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2228 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2229
2230 $time + $to
2231}
2232
2233sub should_reset {
2234 my ($self) = @_;
2235
2236 $self->reset_at <= $cf::RUNTIME
2237}
2238
2239sub reset {
2240 my ($self) = @_;
2241
2242 my $lock = cf::lock_acquire "map_data:$self->{path}";
2243
2244 return if $self->players;
2245
2246 warn "resetting map ", $self->path, "\n";
2247
2248 $self->in_memory (cf::MAP_SWAPPED);
2249
2250 # need to save uniques path
2251 unless ($self->{deny_save}) {
2252 my $uniq = $self->uniq_path; utf8::encode $uniq;
2253
2254 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2255 if $uniq;
2256 }
2257
2258 delete $cf::MAP{$self->path};
2259
2260 $self->deactivate;
2261 $_->clear_links_to ($self) for values %cf::MAP;
2262 $self->clear;
2263 2336
2264 $self->unlink_save; 2337 $self->unlink_save;
2265 $self->destroy; 2338 $self->destroy;
2266} 2339}
2267 2340
… …
2275 2348
2276 delete $cf::MAP{$self->path}; 2349 delete $cf::MAP{$self->path};
2277 2350
2278 $self->unlink_save; 2351 $self->unlink_save;
2279 2352
2280 bless $self, "cf::map"; 2353 bless $self, "cf::map::wrap";
2281 delete $self->{deny_reset}; 2354 delete $self->{deny_reset};
2282 $self->{deny_save} = 1; 2355 $self->{deny_save} = 1;
2283 $self->reset_timeout (1); 2356 $self->reset_timeout (1);
2284 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2357 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2285 2358
… …
2515 2588
2516Freezes the player and moves him/her to a special map (C<{link}>). 2589Freezes the player and moves him/her to a special map (C<{link}>).
2517 2590
2518The player should be reasonably safe there for short amounts of time (e.g. 2591The player should be reasonably safe there for short amounts of time (e.g.
2519for loading a map). You I<MUST> call C<leave_link> as soon as possible, 2592for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2520though, as the palyer cannot control the character while it is on the link 2593though, as the player cannot control the character while it is on the link
2521map. 2594map.
2522 2595
2523Will never block. 2596Will never block.
2524 2597
2525=item $player_object->leave_link ($map, $x, $y) 2598=item $player_object->leave_link ($map, $x, $y)
… …
2546sub cf::object::player::enter_link { 2619sub cf::object::player::enter_link {
2547 my ($self) = @_; 2620 my ($self) = @_;
2548 2621
2549 $self->deactivate_recursive; 2622 $self->deactivate_recursive;
2550 2623
2624 ++$self->{_link_recursion};
2625
2551 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2626 return if UNIVERSAL::isa $self->map, "ext::map_link";
2552 2627
2553 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2628 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2554 if $self->map && $self->map->{path} ne "{link}"; 2629 if $self->map && $self->map->{path} ne "{link}";
2555 2630
2556 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2631 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2557} 2632}
2558 2633
2559sub cf::object::player::leave_link { 2634sub cf::object::player::leave_link {
2560 my ($self, $map, $x, $y) = @_; 2635 my ($self, $map, $x, $y) = @_;
2561 2636
… …
2586 $map->load_neighbours; 2661 $map->load_neighbours;
2587 2662
2588 return unless $self->contr->active; 2663 return unless $self->contr->active;
2589 2664
2590 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2665 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2591 $self->enter_map ($map, $x, $y); 2666 if ($self->enter_map ($map, $x, $y)) {
2592 2667 # entering was successful
2668 delete $self->{_link_recursion};
2593 # only activate afterwards, to support waiting in hooks 2669 # only activate afterwards, to support waiting in hooks
2594 $self->activate_recursive; 2670 $self->activate_recursive;
2595} 2671 }
2596 2672
2673}
2674
2597=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2675=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2598 2676
2599Moves the player to the given map-path and coordinates by first freezing 2677Moves the player to the given map-path and coordinates by first freezing
2600her, loading and preparing them map, calling the provided $check callback 2678her, loading and preparing them map, calling the provided $check callback
2601that has to return the map if sucecssful, and then unfreezes the player on 2679that has to return the map if sucecssful, and then unfreezes the player on
2602the new (success) or old (failed) map position. In either case, $done will 2680the new (success) or old (failed) map position. In either case, $done will
… …
2609 2687
2610our $GOTOGEN; 2688our $GOTOGEN;
2611 2689
2612sub cf::object::player::goto { 2690sub cf::object::player::goto {
2613 my ($self, $path, $x, $y, $check, $done) = @_; 2691 my ($self, $path, $x, $y, $check, $done) = @_;
2692
2693 if ($self->{_link_recursion} >= $MAX_LINKS) {
2694 warn "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2695 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2696 ($path, $x, $y) = @$EMERGENCY_POSITION;
2697 }
2614 2698
2615 # do generation counting so two concurrent goto's will be executed in-order 2699 # do generation counting so two concurrent goto's will be executed in-order
2616 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2700 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2617 2701
2618 $self->enter_link; 2702 $self->enter_link;
… …
2642 my $map = eval { 2726 my $map = eval {
2643 my $map = defined $path ? cf::map::find $path : undef; 2727 my $map = defined $path ? cf::map::find $path : undef;
2644 2728
2645 if ($map) { 2729 if ($map) {
2646 $map = $map->customise_for ($self); 2730 $map = $map->customise_for ($self);
2647 $map = $check->($map) if $check && $map; 2731 $map = $check->($map, $x, $y, $self) if $check && $map;
2648 } else { 2732 } else {
2649 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2733 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2650 } 2734 }
2651 2735
2652 $map 2736 $map
… …
2660 if ($gen == $self->{_goto_generation}) { 2744 if ($gen == $self->{_goto_generation}) {
2661 delete $self->{_goto_generation}; 2745 delete $self->{_goto_generation};
2662 $self->leave_link ($map, $x, $y); 2746 $self->leave_link ($map, $x, $y);
2663 } 2747 }
2664 2748
2665 $done->() if $done; 2749 $done->($self) if $done;
2666 })->prio (1); 2750 })->prio (1);
2667} 2751}
2668 2752
2669=item $player_object->enter_exit ($exit_object) 2753=item $player_object->enter_exit ($exit_object)
2670 2754
… …
3116 3200
3117 $coro 3201 $coro
3118} 3202}
3119 3203
3120cf::client->attach ( 3204cf::client->attach (
3121 on_destroy => sub { 3205 on_client_destroy => sub {
3122 my ($ns) = @_; 3206 my ($ns) = @_;
3123 3207
3124 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3208 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3125 }, 3209 },
3126); 3210);
… …
3142our $safe_hole = new Safe::Hole; 3226our $safe_hole = new Safe::Hole;
3143 3227
3144$SIG{FPE} = 'IGNORE'; 3228$SIG{FPE} = 'IGNORE';
3145 3229
3146$safe->permit_only (Opcode::opset qw( 3230$safe->permit_only (Opcode::opset qw(
3147 :base_core :base_mem :base_orig :base_math 3231 :base_core :base_mem :base_orig :base_math :base_loop
3148 grepstart grepwhile mapstart mapwhile 3232 grepstart grepwhile mapstart mapwhile
3149 sort time 3233 sort time
3150)); 3234));
3151 3235
3152# here we export the classes and methods available to script code 3236# here we export the classes and methods available to script code
… …
3204 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3288 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3205 $qcode =~ s/\n/\\n/g; 3289 $qcode =~ s/\n/\\n/g;
3206 3290
3207 %vars = (_dummy => 0) unless %vars; 3291 %vars = (_dummy => 0) unless %vars;
3208 3292
3293 my @res;
3209 local $_; 3294 local $_;
3210 local @safe::cf::_safe_eval_args = values %vars;
3211 3295
3212 my $eval = 3296 my $eval =
3213 "do {\n" 3297 "do {\n"
3214 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3298 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3215 . "#line 0 \"{$qcode}\"\n" 3299 . "#line 0 \"{$qcode}\"\n"
3216 . $code 3300 . $code
3217 . "\n}" 3301 . "\n}"
3218 ; 3302 ;
3219 3303
3304 if ($CFG{safe_eval}) {
3220 sub_generation_inc; 3305 sub_generation_inc;
3306 local @safe::cf::_safe_eval_args = values %vars;
3221 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3307 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3222 sub_generation_inc; 3308 sub_generation_inc;
3309 } else {
3310 local @cf::_safe_eval_args = values %vars;
3311 @res = wantarray ? eval eval : scalar eval $eval;
3312 }
3223 3313
3224 if ($@) { 3314 if ($@) {
3225 warn "$@"; 3315 warn "$@";
3226 warn "while executing safe code '$code'\n"; 3316 warn "while executing safe code '$code'\n";
3227 warn "with arguments " . (join " ", %vars) . "\n"; 3317 warn "with arguments " . (join " ", %vars) . "\n";
… …
3246=cut 3336=cut
3247 3337
3248sub register_script_function { 3338sub register_script_function {
3249 my ($fun, $cb) = @_; 3339 my ($fun, $cb) = @_;
3250 3340
3251 no strict 'refs'; 3341 $fun = "safe::$fun" if $CFG{safe_eval};
3252 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3342 *$fun = $safe_hole->wrap ($cb);
3253} 3343}
3254 3344
3255=back 3345=back
3256 3346
3257=cut 3347=cut
… …
3278 3368
3279 $facedata->{version} == 2 3369 $facedata->{version} == 2
3280 or cf::cleanup "$path: version mismatch, cannot proceed."; 3370 or cf::cleanup "$path: version mismatch, cannot proceed.";
3281 3371
3282 # patch in the exptable 3372 # patch in the exptable
3373 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3283 $facedata->{resource}{"res/exp_table"} = { 3374 $facedata->{resource}{"res/exp_table"} = {
3284 type => FT_RSRC, 3375 type => FT_RSRC,
3285 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3376 data => $exp_table,
3377 hash => (Digest::MD5::md5 $exp_table),
3286 }; 3378 };
3287 cf::cede_to_tick; 3379 cf::cede_to_tick;
3288 3380
3289 { 3381 {
3290 my $faces = $facedata->{faceinfo}; 3382 my $faces = $facedata->{faceinfo};
… …
3292 while (my ($face, $info) = each %$faces) { 3384 while (my ($face, $info) = each %$faces) {
3293 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3385 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3294 3386
3295 cf::face::set_visibility $idx, $info->{visibility}; 3387 cf::face::set_visibility $idx, $info->{visibility};
3296 cf::face::set_magicmap $idx, $info->{magicmap}; 3388 cf::face::set_magicmap $idx, $info->{magicmap};
3297 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3389 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3298 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3390 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3299 3391
3300 cf::cede_to_tick; 3392 cf::cede_to_tick;
3301 } 3393 }
3302 3394
3303 while (my ($face, $info) = each %$faces) { 3395 while (my ($face, $info) = each %$faces) {
… …
3327 3419
3328 cf::anim::invalidate_all; # d'oh 3420 cf::anim::invalidate_all; # d'oh
3329 } 3421 }
3330 3422
3331 { 3423 {
3332 # TODO: for gcfclient pleasure, we should give resources
3333 # that gcfclient doesn't grok a >10000 face index.
3334 my $res = $facedata->{resource}; 3424 my $res = $facedata->{resource};
3335 3425
3336 while (my ($name, $info) = each %$res) { 3426 while (my ($name, $info) = each %$res) {
3337 if (defined $info->{type}) { 3427 if (defined $info->{type}) {
3338 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3428 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3339 my $data;
3340 3429
3341 if ($info->{type} & 1) { 3430 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3342 # prepend meta info
3343
3344 my $meta = $enc->encode ({
3345 name => $name,
3346 %{ $info->{meta} || {} },
3347 });
3348
3349 $data = pack "(w/a*)*", $meta, $info->{data};
3350 } else {
3351 $data = $info->{data};
3352 }
3353
3354 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3355 cf::face::set_type $idx, $info->{type}; 3431 cf::face::set_type $idx, $info->{type};
3356 } else { 3432 } else {
3357 $RESOURCE{$name} = $info; 3433 $RESOURCE{$name} = $info; # unused
3358 } 3434 }
3359 3435
3360 cf::cede_to_tick; 3436 cf::cede_to_tick;
3361 } 3437 }
3362 } 3438 }
3363 3439
3364 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3440 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3365 3441
3366 1 3442 1
3367} 3443}
3368
3369cf::global->attach (on_resource_update => sub {
3370 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3371 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3372
3373 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3374 my $sound = $soundconf->{compat}[$_]
3375 or next;
3376
3377 my $face = cf::face::find "sound/$sound->[1]";
3378 cf::sound::set $sound->[0] => $face;
3379 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3380 }
3381
3382 while (my ($k, $v) = each %{$soundconf->{event}}) {
3383 my $face = cf::face::find "sound/$v";
3384 cf::sound::set $k => $face;
3385 }
3386 }
3387});
3388 3444
3389register_exticmd fx_want => sub { 3445register_exticmd fx_want => sub {
3390 my ($ns, $want) = @_; 3446 my ($ns, $want) = @_;
3391 3447
3392 while (my ($k, $v) = each %$want) { 3448 while (my ($k, $v) = each %$want) {
… …
3431sub reload_treasures { 3487sub reload_treasures {
3432 load_resource_file "$DATADIR/treasures" 3488 load_resource_file "$DATADIR/treasures"
3433 or die "unable to load treasurelists\n"; 3489 or die "unable to load treasurelists\n";
3434} 3490}
3435 3491
3492sub reload_sound {
3493 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3494 or die "$DATADIR/sound $!";
3495
3496 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
3497
3498 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3499 my $sound = $soundconf->{compat}[$_]
3500 or next;
3501
3502 my $face = cf::face::find "sound/$sound->[1]";
3503 cf::sound::set $sound->[0] => $face;
3504 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3505 }
3506
3507 while (my ($k, $v) = each %{$soundconf->{event}}) {
3508 my $face = cf::face::find "sound/$v";
3509 cf::sound::set $k => $face;
3510 }
3511}
3512
3436sub reload_resources { 3513sub reload_resources {
3437 warn "reloading resource files...\n"; 3514 warn "reloading resource files...\n";
3438 3515
3439 reload_facedata; 3516 reload_facedata;
3517 reload_sound;
3440 reload_archetypes; 3518 reload_archetypes;
3441 reload_regions; 3519 reload_regions;
3442 reload_treasures; 3520 reload_treasures;
3443 3521
3444 warn "finished reloading resource files\n"; 3522 warn "finished reloading resource files\n";
… …
3451 or return; 3529 or return;
3452 3530
3453 local $/; 3531 local $/;
3454 *CFG = YAML::XS::Load scalar <$fh>; 3532 *CFG = YAML::XS::Load scalar <$fh>;
3455 3533
3456 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3534 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3457 3535
3458 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3536 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3459 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3537 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3460 3538
3461 if (exists $CFG{mlockall}) { 3539 if (exists $CFG{mlockall}) {
… …
3502 3580
3503 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3581 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3504 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3582 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3505 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3583 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3506 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3584 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3507
3508 cf::init_experience;
3509 cf::init_anim;
3510 cf::init_attackmess;
3511 cf::init_dynamic;
3512 3585
3513 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3586 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3514 3587
3515 # we must not ever block the main coroutine 3588 # we must not ever block the main coroutine
3516 local $Coro::idle = sub { 3589 local $Coro::idle = sub {
… …
3522 }; 3595 };
3523 3596
3524 evthread_start IO::AIO::poll_fileno; 3597 evthread_start IO::AIO::poll_fileno;
3525 3598
3526 cf::sync_job { 3599 cf::sync_job {
3600 cf::init_experience;
3601 cf::init_anim;
3602 cf::init_attackmess;
3603 cf::init_dynamic;
3604
3605 cf::load_settings;
3606 cf::load_materials;
3607
3527 reload_resources; 3608 reload_resources;
3528 reload_config; 3609 reload_config;
3529 db_init; 3610 db_init;
3530 3611
3531 cf::load_settings;
3532 cf::load_materials;
3533 cf::init_uuid; 3612 cf::init_uuid;
3534 cf::init_signals; 3613 cf::init_signals;
3535 cf::init_commands;
3536 cf::init_skills; 3614 cf::init_skills;
3537 3615
3538 cf::init_beforeplay; 3616 cf::init_beforeplay;
3539 3617
3540 atomic; 3618 atomic;
… …
3547 use POSIX (); 3625 use POSIX ();
3548 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3626 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3549 3627
3550 (pop @POST_INIT)->(0) while @POST_INIT; 3628 (pop @POST_INIT)->(0) while @POST_INIT;
3551 }; 3629 };
3630
3631 cf::object::thawer::errors_are_fatal 0;
3632 warn "parse errors in files are no longer fatal from this point on.\n";
3552 3633
3553 main_loop; 3634 main_loop;
3554} 3635}
3555 3636
3556############################################################################# 3637#############################################################################
… …
3558 3639
3559# install some emergency cleanup handlers 3640# install some emergency cleanup handlers
3560BEGIN { 3641BEGIN {
3561 our %SIGWATCHER = (); 3642 our %SIGWATCHER = ();
3562 for my $signal (qw(INT HUP TERM)) { 3643 for my $signal (qw(INT HUP TERM)) {
3563 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3644 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3564 cf::cleanup "SIG$signal"; 3645 cf::cleanup "SIG$signal";
3565 }; 3646 };
3566 } 3647 }
3567} 3648}
3568 3649
3569sub write_runtime_sync { 3650sub write_runtime_sync {
3651 my $t0 = AE::time;
3652
3570 # first touch the runtime file to show we are still running: 3653 # first touch the runtime file to show we are still running:
3571 # the fsync below can take a very very long time. 3654 # the fsync below can take a very very long time.
3572 3655
3573 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3656 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3574 3657
3575 my $guard = cf::lock_acquire "write_runtime"; 3658 my $guard = cf::lock_acquire "write_runtime";
3576 3659
3577 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3660 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3578 or return; 3661 or return;
3579 3662
3580 my $value = $cf::RUNTIME + 90 + 10; 3663 my $value = $cf::RUNTIME + 90 + 10;
3581 # 10 is the runtime save interval, for a monotonic clock 3664 # 10 is the runtime save interval, for a monotonic clock
3582 # 60 allows for the watchdog to kill the server. 3665 # 60 allows for the watchdog to kill the server.
… …
3595 or return; 3678 or return;
3596 3679
3597 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3680 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3598 and return; 3681 and return;
3599 3682
3600 warn "runtime file written.\n"; 3683 warn sprintf "runtime file written (%gs).\n", AE::time - $t0;
3601 3684
3602 1 3685 1
3603} 3686}
3604 3687
3605our $uuid_lock; 3688our $uuid_lock;
… …
3731 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3814 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3732 for my $name (keys %$leaf_symtab) { 3815 for my $name (keys %$leaf_symtab) {
3733 _gv_clear *{"$pkg$name"}; 3816 _gv_clear *{"$pkg$name"};
3734# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3817# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3735 } 3818 }
3736 warn "cleared package $pkg\n";#d#
3737} 3819}
3738 3820
3739sub do_reload_perl() { 3821sub do_reload_perl() {
3740 # can/must only be called in main 3822 # can/must only be called in main
3741 if ($Coro::current != $Coro::main) { 3823 if (in_main) {
3742 warn "can only reload from main coroutine"; 3824 warn "can only reload from main coroutine";
3743 return; 3825 return;
3744 } 3826 }
3745 3827
3746 return if $RELOAD++; 3828 return if $RELOAD++;
3747 3829
3748 my $t1 = EV::time; 3830 my $t1 = AE::time;
3749 3831
3750 while ($RELOAD) { 3832 while ($RELOAD) {
3751 warn "reloading..."; 3833 warn "reloading...";
3752 3834
3753 warn "entering sync_job"; 3835 warn "entering sync_job";
… …
3856 3938
3857 warn "reloaded"; 3939 warn "reloaded";
3858 --$RELOAD; 3940 --$RELOAD;
3859 } 3941 }
3860 3942
3861 $t1 = EV::time - $t1; 3943 $t1 = AE::time - $t1;
3862 warn "reload completed in ${t1}s\n"; 3944 warn "reload completed in ${t1}s\n";
3863}; 3945};
3864 3946
3865our $RELOAD_WATCHER; # used only during reload 3947our $RELOAD_WATCHER; # used only during reload
3866 3948
… …
3869 # coro crashes during coro_state_free->destroy here. 3951 # coro crashes during coro_state_free->destroy here.
3870 3952
3871 $RELOAD_WATCHER ||= cf::async { 3953 $RELOAD_WATCHER ||= cf::async {
3872 Coro::AIO::aio_wait cache_extensions; 3954 Coro::AIO::aio_wait cache_extensions;
3873 3955
3874 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 3956 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3875 do_reload_perl; 3957 do_reload_perl;
3876 undef $RELOAD_WATCHER; 3958 undef $RELOAD_WATCHER;
3877 }; 3959 };
3878 }; 3960 };
3879} 3961}
… …
3896 3978
3897our @WAIT_FOR_TICK; 3979our @WAIT_FOR_TICK;
3898our @WAIT_FOR_TICK_BEGIN; 3980our @WAIT_FOR_TICK_BEGIN;
3899 3981
3900sub wait_for_tick { 3982sub wait_for_tick {
3901 return if tick_inhibit || $Coro::current == $Coro::main; 3983 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3902 3984
3903 my $signal = new Coro::Signal; 3985 my $signal = new Coro::Signal;
3904 push @WAIT_FOR_TICK, $signal; 3986 push @WAIT_FOR_TICK, $signal;
3905 $signal->wait; 3987 $signal->wait;
3906} 3988}
3907 3989
3908sub wait_for_tick_begin { 3990sub wait_for_tick_begin {
3909 return if tick_inhibit || $Coro::current == $Coro::main; 3991 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3910 3992
3911 my $signal = new Coro::Signal; 3993 my $signal = new Coro::Signal;
3912 push @WAIT_FOR_TICK_BEGIN, $signal; 3994 push @WAIT_FOR_TICK_BEGIN, $signal;
3913 $signal->wait; 3995 $signal->wait;
3914} 3996}
… …
3919 unless ++$bug_warning > 10; 4001 unless ++$bug_warning > 10;
3920 return; 4002 return;
3921 } 4003 }
3922 4004
3923 cf::server_tick; # one server iteration 4005 cf::server_tick; # one server iteration
4006
4007 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3924 4008
3925 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4009 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3926 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4010 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3927 Coro::async_pool { 4011 Coro::async_pool {
3928 $Coro::current->{desc} = "runtime saver"; 4012 $Coro::current->{desc} = "runtime saver";
… …
3951} 4035}
3952 4036
3953{ 4037{
3954 # configure BDB 4038 # configure BDB
3955 4039
3956 BDB::min_parallel 8; 4040 BDB::min_parallel 16;
3957 BDB::max_poll_reqs $TICK * 0.1; 4041 BDB::max_poll_reqs $TICK * 0.1;
3958 $AnyEvent::BDB::WATCHER->priority (1); 4042 $AnyEvent::BDB::WATCHER->priority (1);
3959 4043
3960 unless ($DB_ENV) { 4044 unless ($DB_ENV) {
3961 $DB_ENV = BDB::db_env_create; 4045 $DB_ENV = BDB::db_env_create;

Diff Legend

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