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.581 by root, Fri Feb 3 02:04:11 2012 UTC vs.
Revision 1.603 by root, Tue Nov 13 01:12:23 2012 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,2009,2010,2011,2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008,2009,2010,2011,2012 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.
10# 10#
11# This program is distributed in the hope that it will be useful, 11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of 12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details. 14# GNU General Public License for more details.
15# 15#
16# You should have received a copy of the Affero GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see 17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>. 18# <http://www.gnu.org/licenses/>.
19# 19#
20# The authors can be reached via e-mail to <support@deliantra.net> 20# The authors can be reached via e-mail to <support@deliantra.net>
21# 21#
22 22
23package cf; 23package cf;
24 24
… …
32use Safe; 32use Safe;
33use Safe::Hole; 33use Safe::Hole;
34use Storable (); 34use Storable ();
35use Carp (); 35use Carp ();
36 36
37use Guard (); 37use AnyEvent ();
38use AnyEvent::IO ();
39use AnyEvent::DNS ();
40
38use Coro (); 41use Coro ();
39use Coro::State; 42use Coro::State;
40use Coro::Handle; 43use Coro::Handle;
41use Coro::EV; 44use Coro::EV;
42use Coro::AnyEvent; 45use Coro::AnyEvent;
… …
48use Coro::AIO; 51use Coro::AIO;
49use Coro::BDB 1.6; 52use Coro::BDB 1.6;
50use Coro::Storable; 53use Coro::Storable;
51use Coro::Util (); 54use Coro::Util ();
52 55
56use Guard ();
53use JSON::XS 2.01 (); 57use JSON::XS 2.01 ();
54use BDB (); 58use BDB ();
55use Data::Dumper; 59use Data::Dumper;
56use Fcntl; 60use Fcntl;
57use YAML::XS (); 61use YAML::XS ();
58use IO::AIO (); 62use IO::AIO ();
59use Time::HiRes;
60use Compress::LZF; 63use Compress::LZF;
61use Digest::MD5 (); 64use Digest::MD5 ();
62 65
63AnyEvent::detect; 66AnyEvent::detect;
64 67
… …
83our %COMMAND = (); 86our %COMMAND = ();
84our %COMMAND_TIME = (); 87our %COMMAND_TIME = ();
85 88
86our @EXTS = (); # list of extension package names 89our @EXTS = (); # list of extension package names
87our %EXTCMD = (); 90our %EXTCMD = ();
91our %EXTACMD = ();
88our %EXTICMD = (); 92our %EXTICMD = ();
93our %EXTIACMD = ();
89our %EXT_CORO = (); # coroutines bound to extensions 94our %EXT_CORO = (); # coroutines bound to extensions
90our %EXT_MAP = (); # pluggable maps 95our %EXT_MAP = (); # pluggable maps
91 96
92our $RELOAD; # number of reloads so far, non-zero while in reload 97our $RELOAD; # number of reloads so far, non-zero while in reload
93our @EVENT; 98our @EVENT;
… …
129our $DB_ENV; 134our $DB_ENV;
130 135
131our @EXTRA_MODULES = qw(pod match mapscript incloader); 136our @EXTRA_MODULES = qw(pod match mapscript incloader);
132 137
133our %CFG; 138our %CFG;
139our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
134 140
135our $UPTIME; $UPTIME ||= time; 141our $UPTIME; $UPTIME ||= time;
136our $RUNTIME = 0; 142our $RUNTIME = 0;
137our $SERVER_TICK = 0; 143our $SERVER_TICK = 0;
138our $NOW; 144our $NOW;
… …
219=item $cf::RUNTIME 225=item $cf::RUNTIME
220 226
221The time this server has run, starts at 0 and is increased by $cf::TICK on 227The time this server has run, starts at 0 and is increased by $cf::TICK on
222every server tick. 228every server tick.
223 229
224=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR 230=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
225$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR 231$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
226$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR 232$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
227 233
228Various directories - "/etc", read-only install directory, perl-library 234Various directories - "/etc", read-only install directory, perl-library
229directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 235directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
230unique-items directory, player file directory, random maps directory and 236unique-items directory, player file directory, random maps directory and
231database environment. 237database environment.
… …
245Configuration for the server, loaded from C</etc/deliantra-server/config>, or 251Configuration for the server, loaded from C</etc/deliantra-server/config>, or
246from wherever your confdir points to. 252from wherever your confdir points to.
247 253
248=item cf::wait_for_tick, cf::wait_for_tick_begin 254=item cf::wait_for_tick, cf::wait_for_tick_begin
249 255
250These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 256These are functions that inhibit the current coroutine one tick.
251returns directly I<after> the tick processing (and consequently, can only wake one thread 257cf::wait_for_tick_begin only returns directly I<after> the tick
258processing (and consequently, can only wake one thread per tick), while
252per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 259cf::wait_for_tick wakes up all waiters after tick processing.
253 260
254Note that cf::Wait_for_tick will immediately return when the server is not 261Note that cf::wait_for_tick will immediately return when the server is not
255ticking, making it suitable for small pauses in threads that need to run 262ticking, making it suitable for small pauses in threads that need to run
256when the server is paused. If that is not applicable (i.e. you I<really> 263when the server is paused. If that is not applicable (i.e. you I<really>
257want to wait, use C<$cf::WAIT_FOR_TICK>). 264want to wait, use C<$cf::WAIT_FOR_TICK>).
258 265
259=item $cf::WAIT_FOR_TICK 266=item $cf::WAIT_FOR_TICK
… …
335)) { 342)) {
336 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 343 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
337} 344}
338 345
339$EV::DIED = sub { 346$EV::DIED = sub {
340 Carp::cluck "error in event callback: @_"; 347 warn "error in event callback: $@";
341}; 348};
342 349
343############################################################################# 350#############################################################################
344 351
345sub fork_call(&@); 352sub fork_call(&@);
… …
566Allocate $time seconds of blocking CPU time at priority C<$priority> 573Allocate $time seconds of blocking CPU time at priority C<$priority>
567(default: 0): This call blocks and returns only when you have at least 574(default: 0): This call blocks and returns only when you have at least
568C<$time> seconds of cpu time till the next tick. The slot is only valid 575C<$time> seconds of cpu time till the next tick. The slot is only valid
569till the next cede. 576till the next cede.
570 577
571Background jobs should use a priority les than zero, interactive jobs 578Background jobs should use a priority less than zero, interactive jobs
572should use 100 or more. 579should use 100 or more.
573 580
574The optional C<$name> can be used to identify the job to run. It might be 581The optional C<$name> can be used to identify the job to run. It might be
575used for statistical purposes and should identify the same time-class. 582used for statistical purposes and should identify the same time-class.
576 583
… …
731 reset_signals; 738 reset_signals;
732} 739}
733 740
734sub fork_call(&@) { 741sub fork_call(&@) {
735 my ($cb, @args) = @_; 742 my ($cb, @args) = @_;
736
737 # we seemingly have to make a local copy of the whole thing,
738 # otherwise perl prematurely frees the stuff :/
739 # TODO: investigate and fix (likely this will be rather laborious)
740 743
741 my @res = Coro::Util::fork_eval { 744 my @res = Coro::Util::fork_eval {
742 cf::post_fork; 745 cf::post_fork;
743 &$cb 746 &$cb
744 } @args; 747 } @args;
… …
894 897
895 return db_get cache => "$id/data"; 898 return db_get cache => "$id/data";
896 } 899 }
897 } 900 }
898 901
899 my $t1 = Time::HiRes::time; 902 my $t1 = EV::time;
900 my $data = $process->(\@data); 903 my $data = $process->(\@data);
901 my $t2 = Time::HiRes::time; 904 my $t2 = EV::time;
902 905
903 info "cache: '$id' processed in ", $t2 - $t1, "s\n"; 906 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
904 907
905 db_put cache => "$id/data", $data; 908 db_put cache => "$id/data", $data;
906 db_put cache => "$id/md5" , $md5; 909 db_put cache => "$id/md5" , $md5;
… …
1426=cut 1429=cut
1427 1430
1428############################################################################# 1431#############################################################################
1429# command handling &c 1432# command handling &c
1430 1433
1431=item cf::register_command $name => \&callback($ob,$args); 1434=item cf::register_command $name => \&callback($ob,$args)
1432 1435
1433Register a callback for execution when the client sends the user command 1436Register a callback for execution when the client sends the user command
1434$name. 1437$name.
1435 1438
1436=cut 1439=cut
… …
1442 #warn "registering command '$name/$time' to '$caller'"; 1445 #warn "registering command '$name/$time' to '$caller'";
1443 1446
1444 push @{ $COMMAND{$name} }, [$caller, $cb]; 1447 push @{ $COMMAND{$name} }, [$caller, $cb];
1445} 1448}
1446 1449
1447=item cf::register_extcmd $name => \&callback($pl,$packet); 1450=item cf::register_extcmd $name => \&callback($pl,@args)
1448 1451
1449Register a callback for execution when the client sends an (synchronous) 1452Register a callback for execution when the client sends an (synchronous)
1450extcmd packet. Ext commands will be processed in the order they are 1453extcmd packet. Ext commands will be processed in the order they are
1451received by the server, like other user commands. The first argument is 1454received by the server, like other user commands. The first argument is
1452the logged-in player. Ext commands can only be processed after a player 1455the logged-in player. Ext commands can only be processed after a player
1453has logged in successfully. 1456has logged in successfully.
1454 1457
1455If the callback returns something, it is sent back as if reply was being 1458The values will be sent back to the client.
1456called.
1457 1459
1460=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
1461
1462Same as C<cf::register_extcmd>, but instead of returning values, the
1463callback needs to clal the C<$reply> function.
1464
1458=item cf::register_exticmd $name => \&callback($ns,$packet); 1465=item cf::register_exticmd $name => \&callback($ns,@args)
1459 1466
1460Register a callback for execution when the client sends an (asynchronous) 1467Register a callback for execution when the client sends an (asynchronous)
1461exticmd packet. Exti commands are processed by the server as soon as they 1468exticmd packet. Exti commands are processed by the server as soon as they
1462are received, i.e. out of order w.r.t. other commands. The first argument 1469are received, i.e. out of order w.r.t. other commands. The first argument
1463is a client socket. Exti commands can be received anytime, even before 1470is a client socket. Exti commands can be received anytime, even before
1464log-in. 1471log-in.
1465 1472
1466If the callback returns something, it is sent back as if reply was being 1473The values will be sent back to the client.
1467called.
1468 1474
1469=cut 1475=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
1470 1476
1477Same as C<cf::register_extcmd>, but instead of returning values, the
1478callback needs to clal the C<$reply> function.
1479
1480=cut
1481
1471sub register_extcmd { 1482sub register_extcmd($$) {
1472 my ($name, $cb) = @_; 1483 my ($name, $cb) = @_;
1473 1484
1474 $EXTCMD{$name} = $cb; 1485 $EXTCMD{$name} = $cb;
1475} 1486}
1476 1487
1477sub register_exticmd { 1488sub register_async_extcmd($$) {
1478 my ($name, $cb) = @_; 1489 my ($name, $cb) = @_;
1479 1490
1491 $EXTACMD{$name} = $cb;
1492}
1493
1494sub register_exticmd($$) {
1495 my ($name, $cb) = @_;
1496
1480 $EXTICMD{$name} = $cb; 1497 $EXTICMD{$name} = $cb;
1498}
1499
1500sub register_async_exticmd($$) {
1501 my ($name, $cb) = @_;
1502
1503 $EXTIACMD{$name} = $cb;
1481} 1504}
1482 1505
1483use File::Glob (); 1506use File::Glob ();
1484 1507
1485cf::player->attach ( 1508cf::player->attach (
… …
1501 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1524 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1502 1525
1503 if (ref $msg) { 1526 if (ref $msg) {
1504 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash 1527 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1505 1528
1506 my @reply;
1507
1508 if (my $cb = $EXTCMD{$type}) { 1529 if (my $cb = $EXTACMD{$type}) {
1530 $cb->(
1531 $pl,
1532 sub {
1533 $pl->ext_msg ("reply-$reply", @_)
1534 if $reply;
1535 },
1536 @payload
1537 );
1538 } else {
1539 my @reply;
1540
1541 if (my $cb = $EXTCMD{$type}) {
1509 @reply = $cb->($pl, @payload); 1542 @reply = $cb->($pl, @payload);
1543 }
1544
1545 $pl->ext_msg ("reply-$reply", @reply)
1546 if $reply;
1510 } 1547 }
1511
1512 $pl->ext_reply ($reply, @reply)
1513 if $reply;
1514 1548
1515 } else { 1549 } else {
1516 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1550 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1517 } 1551 }
1518 1552
… …
1531 }; 1565 };
1532 1566
1533 $grp 1567 $grp
1534} 1568}
1535 1569
1570sub _ext_cfg_reg($$$$) {
1571 my ($rvar, $varname, $cfgname, $default) = @_;
1572
1573 $cfgname = lc $varname
1574 unless length $cfgname;
1575
1576 $EXT_CFG{$cfgname} = [$rvar, $default];
1577
1578 $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
1579}
1580
1536sub load_extensions { 1581sub load_extensions {
1537 info "loading extensions..."; 1582 info "loading extensions...";
1583
1584 %EXT_CFG = ();
1538 1585
1539 cf::sync_job { 1586 cf::sync_job {
1540 my %todo; 1587 my %todo;
1541 1588
1542 for my $path (<$LIBDIR/*.ext>) { 1589 for my $path (<$LIBDIR/*.ext>) {
… …
1585 unless exists $done{$_}; 1632 unless exists $done{$_};
1586 } 1633 }
1587 1634
1588 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n"; 1635 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1589 1636
1637 my $source = $v->{source};
1638
1639 # support "CONF varname :confname = default" pseudo-statements
1640 $source =~ s{
1641 ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
1642 }{
1643 "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
1644 }gmxe;
1645
1590 my $active = eval $v->{source}; 1646 my $active = eval $source;
1591 1647
1592 if (length $@) { 1648 if (length $@) {
1593 error "$v->{path}: $@\n"; 1649 error "$v->{path}: $@\n";
1594 1650
1595 cf::cleanup "mandatory extension '$k' failed to load, exiting." 1651 cf::cleanup "mandatory extension '$k' failed to load, exiting."
… …
1882} 1938}
1883 1939
1884=item $protocol_xml = $player->expand_cfpod ($cfpod) 1940=item $protocol_xml = $player->expand_cfpod ($cfpod)
1885 1941
1886Expand deliantra pod fragments into protocol xml. 1942Expand deliantra pod fragments into protocol xml.
1887
1888=item $player->ext_reply ($msgid, @msg)
1889
1890Sends an ext reply to the player.
1891
1892=cut
1893
1894sub ext_reply($$@) {
1895 my ($self, $id, @msg) = @_;
1896
1897 $self->ns->ext_reply ($id, @msg)
1898}
1899 1943
1900=item $player->ext_msg ($type, @msg) 1944=item $player->ext_msg ($type, @msg)
1901 1945
1902Sends an ext event to the client. 1946Sends an ext event to the client.
1903 1947
… …
2606 2650
2607Creates and returns a persistent reference to an object that can be stored as a string. 2651Creates and returns a persistent reference to an object that can be stored as a string.
2608 2652
2609=item $ob = cf::object::deref ($refstring) 2653=item $ob = cf::object::deref ($refstring)
2610 2654
2611returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2655returns the objetc referenced by refstring. may return undef when it cannot find the object,
2612even if the object actually exists. May block. 2656even if the object actually exists. May block.
2613 2657
2614=cut 2658=cut
2615 2659
2616sub deref { 2660sub deref {
… …
3208=cut 3252=cut
3209 3253
3210sub cf::client::ext_msg($$@) { 3254sub cf::client::ext_msg($$@) {
3211 my ($self, $type, @msg) = @_; 3255 my ($self, $type, @msg) = @_;
3212 3256
3213 if ($self->extcmd == 2) {
3214 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3257 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3215 } elsif ($self->extcmd == 1) { # TODO: remove
3216 push @msg, msgtype => "event_$type";
3217 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3218 }
3219}
3220
3221=item $client->ext_reply ($msgid, @msg)
3222
3223Sends an ext reply to the client.
3224
3225=cut
3226
3227sub cf::client::ext_reply($$@) {
3228 my ($self, $id, @msg) = @_;
3229
3230 return unless $self->extcmd == 2;
3231
3232 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3233} 3258}
3234 3259
3235=item $success = $client->query ($flags, "text", \&cb) 3260=item $success = $client->query ($flags, "text", \&cb)
3236 3261
3237Queues a query to the client, calling the given callback with 3262Queues a query to the client, calling the given callback with
… …
3294 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3319 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3295 3320
3296 if (ref $msg) { 3321 if (ref $msg) {
3297 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash 3322 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3298 3323
3299 my @reply;
3300
3301 if (my $cb = $EXTICMD{$type}) { 3324 if (my $cb = $EXTIACMD{$type}) {
3325 $cb->(
3326 $ns,
3327 sub {
3328 $ns->ext_msg ("reply-$reply", @_)
3329 if $reply;
3330 },
3331 @payload
3332 );
3333 } else {
3334 my @reply;
3335
3336 if (my $cb = $EXTICMD{$type}) {
3302 @reply = $cb->($ns, @payload); 3337 @reply = $cb->($ns, @payload);
3338 }
3339
3340 $ns->ext_msg ("reply-$reply", @reply)
3341 if $reply;
3303 } 3342 }
3304
3305 $ns->ext_reply ($reply, @reply)
3306 if $reply;
3307
3308 } else { 3343 } else {
3309 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3344 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3310 } 3345 }
3311 3346
3312 cf::override; 3347 cf::override;
… …
3480=cut 3515=cut
3481 3516
3482############################################################################# 3517#############################################################################
3483# the server's init and main functions 3518# the server's init and main functions
3484 3519
3520{
3521 package cf::face;
3522
3523 our %HASH; # hash => idx
3524 our @DATA; # dynamically-created facedata, only faceste 0 used
3525 our @FOFS; # file offset, if > 0
3526 our @SIZE; # size of face, in octets
3527 our @META; # meta hash of face, if any
3528 our $DATAFH; # facedata filehandle
3529
3530 # internal api, not finalised
3531 sub set {
3532 my ($name, $type, $data) = @_;
3533
3534 my $idx = cf::face::find $name;
3535
3536 if ($idx) {
3537 delete $HASH{cf::face::get_chksum $idx};
3538 } else {
3539 $idx = cf::face::alloc $name;
3540 }
3541
3542 my $hash = cf::face::mangle_csum Digest::MD5::md5 $data;
3543
3544 cf::face::set_type $idx, $type;
3545 cf::face::set_csum $idx, 0, $hash;
3546
3547 # we need to destroy the SV itself, not just modify it, as a running ix
3548 # might hold a reference to it: "delete" achieves that.
3549 delete $FOFS[0][$idx];
3550 delete $DATA[0][$idx];
3551 $DATA[0][$idx] = $data;
3552 $SIZE[0][$idx] = length $data;
3553 delete $META[$idx];
3554 $HASH{$hash} = $idx;#d#
3555
3556 $idx
3557 }
3558
3559 sub _get_data($$$) {
3560 my ($idx, $set, $cb) = @_;
3561
3562 if (defined $DATA[$set][$idx]) {
3563 $cb->($DATA[$set][$idx]);
3564 } elsif (my $fofs = $FOFS[$set][$idx]) {
3565 my $size = $SIZE[$set][$idx];
3566 my $buf;
3567 IO::AIO::aio_read $DATAFH, $fofs, $size, $buf, 0, sub {
3568 if ($_[0] == $size) {
3569 #cf::debug "read face $idx, $size from $fofs as ", length $buf;#d#
3570 $cb->($buf);
3571 } else {
3572 cf::error "INTERNAL ERROR: unable to read facedata for face $idx#$set ($size, $fofs), ignoring request.";
3573 }
3574 };
3575 } else {
3576 cf::error "requested facedata for unknown face $idx#$set, ignoring.";
3577 }
3578 }
3579
3580 # rather ineffient
3581 sub cf::face::get_data($;$) {
3582 my ($idx, $set) = @_;
3583
3584 _get_data $idx, $set, Coro::rouse_cb;
3585 Coro::rouse_wait
3586 }
3587
3588 sub cf::face::ix {
3589 my ($ns, $set, $idx, $pri) = @_;
3590
3591 _get_data $idx, $set, sub {
3592 $ns->ix_send ($idx, $pri, $_[0]);
3593 };
3594 }
3595}
3596
3485sub load_facedata($) { 3597sub load_facedata($) {
3486 my ($path) = @_; 3598 my ($path) = @_;
3487 3599
3488 # HACK to clear player env face cache, we need some signal framework
3489 # for this (global event?)
3490 %ext::player_env::MUSIC_FACE_CACHE = ();
3491
3492 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3600 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3493 3601
3494 trace "loading facedata from $path\n"; 3602 trace "loading facedata from $path\n";
3495 3603
3496 my $facedata = decode_storable load_file $path; 3604 my $facedata = decode_storable load_file "$path/faceinfo";
3497 3605
3498 $facedata->{version} == 2 3606 $facedata->{version} == 2
3499 or cf::cleanup "$path: version mismatch, cannot proceed."; 3607 or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";
3500 3608
3501 # patch in the exptable 3609 my $fh = aio_open "$DATADIR/facedata", IO::AIO::O_RDONLY, 0
3502 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]); 3610 or cf::cleanup "$path/facedata: $!, cannot proceed.";
3503 $facedata->{resource}{"res/exp_table"} = { 3611
3504 type => FT_RSRC, 3612 get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
3505 data => $exp_table, 3613
3506 hash => (Digest::MD5::md5 $exp_table), 3614 # BEGIN ATOMIC
3507 }; 3615 # from here on, everything must be atomic - no thread switch allowed
3508 cf::cede_to_tick; 3616 my $t1 = EV::time;
3509 3617
3510 { 3618 {
3511 my $faces = $facedata->{faceinfo}; 3619 my $faces = $facedata->{faceinfo};
3512 3620
3513 while (my ($face, $info) = each %$faces) { 3621 for my $face (sort keys %$faces) {
3622 my $info = $faces->{$face};
3514 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3623 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3515 3624
3516 cf::face::set_visibility $idx, $info->{visibility}; 3625 cf::face::set_visibility $idx, $info->{visibility};
3517 cf::face::set_magicmap $idx, $info->{magicmap}; 3626 cf::face::set_magicmap $idx, $info->{magicmap};
3518 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3627 cf::face::set_csum $idx, 0, $info->{hash64}; $cf::face::SIZE[0][$idx] = $info->{size64}; $cf::face::FOFS[0][$idx] = $info->{fofs64};
3519 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3628 cf::face::set_csum $idx, 1, $info->{hash32}; $cf::face::SIZE[1][$idx] = $info->{size32}; $cf::face::FOFS[1][$idx] = $info->{fofs32};
3520 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ; 3629 cf::face::set_csum $idx, 2, $info->{glyph}; $cf::face::DATA[2][$idx] = $info->{glyph};
3521 3630 $cf::face::HASH{$info->{hash64}} = $idx;
3522 cf::cede_to_tick; 3631 delete $cf::face::META[$idx];
3523 } 3632 }
3524 3633
3525 while (my ($face, $info) = each %$faces) { 3634 while (my ($face, $info) = each %$faces) {
3526 next unless $info->{smooth}; 3635 next unless $info->{smooth};
3527 3636
… …
3532 cf::face::set_smooth $idx, $smooth; 3641 cf::face::set_smooth $idx, $smooth;
3533 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3642 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3534 } else { 3643 } else {
3535 error "smooth face '$info->{smooth}' not found for face '$face'"; 3644 error "smooth face '$info->{smooth}' not found for face '$face'";
3536 } 3645 }
3537
3538 cf::cede_to_tick;
3539 } 3646 }
3540 } 3647 }
3541 3648
3542 { 3649 {
3543 my $anims = $facedata->{animinfo}; 3650 my $anims = $facedata->{animinfo};
3544 3651
3545 while (my ($anim, $info) = each %$anims) { 3652 while (my ($anim, $info) = each %$anims) {
3546 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3653 cf::anim::set $anim, $info->{frames}, $info->{facings};
3547 cf::cede_to_tick;
3548 } 3654 }
3549 3655
3550 cf::anim::invalidate_all; # d'oh 3656 cf::anim::invalidate_all; # d'oh
3551 } 3657 }
3552 3658
… …
3556 while (my ($name, $info) = each %$res) { 3662 while (my ($name, $info) = each %$res) {
3557 if (defined (my $type = $info->{type})) { 3663 if (defined (my $type = $info->{type})) {
3558 # TODO: different hash - must free and use new index, or cache ixface data queue 3664 # TODO: different hash - must free and use new index, or cache ixface data queue
3559 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3665 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3560 3666
3561 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3562 cf::face::set_type $idx, $type; 3667 cf::face::set_type $idx, $type;
3668 cf::face::set_csum $idx, 0, $info->{hash};
3669 $cf::face::SIZE[0][$idx] = $info->{size};
3670 $cf::face::FOFS[0][$idx] = $info->{fofs};
3563 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already 3671 $cf::face::META[$idx] = $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3672 $cf::face::HASH{$info->{hash}} = $idx;
3564 } else { 3673 } else {
3565# $RESOURCE{$name} = $info; # unused 3674# $RESOURCE{$name} = $info; # unused
3566 } 3675 }
3567
3568 cf::cede_to_tick;
3569 } 3676 }
3570 } 3677 }
3678
3679 ($fh, $cf::face::DATAFH) = ($cf::face::DATAFH, $fh);
3680
3681 # HACK to clear player env face cache, we need some signal framework
3682 # for this (global event?)
3683 %ext::player_env::MUSIC_FACE_CACHE = ();
3684
3685 # END ATOMIC
3686
3687 cf::debug "facedata atomic update time ", EV::time - $t1;
3571 3688
3572 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3689 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3690
3691 aio_close $fh if $fh; # close old facedata
3573 3692
3574 1 3693 1
3575} 3694}
3576 3695
3577register_exticmd fx_want => sub { 3696register_exticmd fx_want => sub {
… …
3588 my $status = load_resource_file_ $_[0]; 3707 my $status = load_resource_file_ $_[0];
3589 get_slot 0.1, 100; 3708 get_slot 0.1, 100;
3590 cf::arch::commit_load; 3709 cf::arch::commit_load;
3591 3710
3592 $status 3711 $status
3712}
3713
3714sub reload_exp_table {
3715 _reload_exp_table;
3716
3717 cf::face::set
3718 "res/exp_table" => FT_RSRC,
3719 JSON::XS->new->utf8->canonical->encode (
3720 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3721 );
3722}
3723
3724sub reload_materials {
3725 _reload_materials;
3593} 3726}
3594 3727
3595sub reload_regions { 3728sub reload_regions {
3596 # HACK to clear player env face cache, we need some signal framework 3729 # HACK to clear player env face cache, we need some signal framework
3597 # for this (global event?) 3730 # for this (global event?)
… …
3605 if exists $_->{match}; 3738 if exists $_->{match};
3606 } 3739 }
3607} 3740}
3608 3741
3609sub reload_facedata { 3742sub reload_facedata {
3610 load_facedata "$DATADIR/facedata" 3743 load_facedata $DATADIR
3611 or die "unable to load facedata\n"; 3744 or die "unable to load facedata\n";
3612} 3745}
3613 3746
3614sub reload_archetypes { 3747sub reload_archetypes {
3615 load_resource_file "$DATADIR/archetypes" 3748 load_resource_file "$DATADIR/archetypes"
3616 or die "unable to load archetypes\n"; 3749 or die "unable to load archetypes\n";
3750
3751 cf::face::set
3752 "res/skill_info" => FT_RSRC,
3753 JSON::XS->new->utf8->canonical->encode (
3754 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3755 );
3756
3757 cf::face::set
3758 "res/spell_paths" => FT_RSRC,
3759 JSON::XS->new->utf8->canonical->encode (
3760 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3761 );
3617} 3762}
3618 3763
3619sub reload_treasures { 3764sub reload_treasures {
3620 load_resource_file "$DATADIR/treasures" 3765 load_resource_file "$DATADIR/treasures"
3621 or die "unable to load treasurelists\n"; 3766 or die "unable to load treasurelists\n";
… …
3642} 3787}
3643 3788
3644sub reload_resources { 3789sub reload_resources {
3645 trace "reloading resource files...\n"; 3790 trace "reloading resource files...\n";
3646 3791
3647 reload_exp_table;
3648 reload_materials; 3792 reload_materials;
3649 reload_facedata; 3793 reload_facedata;
3794 reload_exp_table;
3650 reload_sound; 3795 reload_sound;
3651 reload_archetypes; 3796 reload_archetypes;
3652 reload_regions; 3797 reload_regions;
3653 reload_treasures; 3798 reload_treasures;
3654 3799
… …
3713 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3858 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3714 3859
3715 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3860 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3716 3861
3717 # we must not ever block the main coroutine 3862 # we must not ever block the main coroutine
3718 local $Coro::idle = sub { 3863 $Coro::idle = sub {
3719 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3864 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3720 (async { 3865 (async {
3721 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3866 $Coro::current->{desc} = "IDLE BUG HANDLER";
3722 EV::loop EV::LOOP_ONESHOT; 3867 EV::loop EV::LOOP_ONESHOT;
3723 })->prio (Coro::PRIO_MAX); 3868 })->prio (Coro::PRIO_MAX);
… …
3726 evthread_start IO::AIO::poll_fileno; 3871 evthread_start IO::AIO::poll_fileno;
3727 3872
3728 cf::sync_job { 3873 cf::sync_job {
3729 cf::incloader::init (); 3874 cf::incloader::init ();
3730 3875
3876 db_init;
3877
3731 cf::init_anim; 3878 cf::init_anim;
3732 cf::init_attackmess; 3879 cf::init_attackmess;
3733 cf::init_dynamic; 3880 cf::init_dynamic;
3734 3881
3735 cf::load_settings; 3882 cf::load_settings;
3736 3883
3737 reload_resources; 3884 reload_resources;
3738 reload_config; 3885 reload_config;
3739 db_init;
3740 3886
3741 cf::init_uuid; 3887 cf::init_uuid;
3742 cf::init_signals; 3888 cf::init_signals;
3743 cf::init_skills; 3889 cf::init_skills;
3744 3890
… …
4169 } 4315 }
4170} 4316}
4171 4317
4172{ 4318{
4173 # configure BDB 4319 # configure BDB
4320 info "initialising database";
4174 4321
4175 BDB::min_parallel 16; 4322 BDB::min_parallel 16;
4176 BDB::max_poll_reqs $TICK * 0.1; 4323 BDB::max_poll_reqs $TICK * 0.1;
4177 #$AnyEvent::BDB::WATCHER->priority (1); 4324 #$AnyEvent::BDB::WATCHER->priority (1);
4178 4325
… …
4207 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4354 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4208 }; 4355 };
4209 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4356 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4210 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4357 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4211 }; 4358 };
4359
4360 info "database initialised";
4212} 4361}
4213 4362
4214{ 4363{
4215 # configure IO::AIO 4364 # configure IO::AIO
4216 4365
4366 info "initialising aio";
4217 IO::AIO::min_parallel 8; 4367 IO::AIO::min_parallel 8;
4218 IO::AIO::max_poll_time $TICK * 0.1; 4368 IO::AIO::max_poll_time $TICK * 0.1;
4219 undef $AnyEvent::AIO::WATCHER; 4369 undef $AnyEvent::AIO::WATCHER;
4370 info "aio initialised";
4220} 4371}
4221 4372
4222our $_log_backtrace; 4373our $_log_backtrace;
4223our $_log_backtrace_last; 4374our $_log_backtrace_last;
4224 4375

Diff Legend

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