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.604 by root, Thu Nov 15 07:08:08 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 {
… …
3156 id => "death", 3200 id => "death",
3157 title => "Death", 3201 title => "Death",
3158 reply => undef, 3202 reply => undef,
3159 tooltip => "Reason for and more info about your most recent death", 3203 tooltip => "Reason for and more info about your most recent death",
3160 }, 3204 },
3205 "c/fatal" => {
3206 id => "fatal",
3207 title => "Fatal Error",
3208 reply => undef,
3209 tooltip => "Reason for the server disconnect",
3210 },
3161 "c/say" => $SAY_CHANNEL, 3211 "c/say" => $SAY_CHANNEL,
3162 "c/chat" => $CHAT_CHANNEL, 3212 "c/chat" => $CHAT_CHANNEL,
3163); 3213);
3164 3214
3165sub cf::client::send_msg { 3215sub cf::client::send_msg {
… …
3208=cut 3258=cut
3209 3259
3210sub cf::client::ext_msg($$@) { 3260sub cf::client::ext_msg($$@) {
3211 my ($self, $type, @msg) = @_; 3261 my ($self, $type, @msg) = @_;
3212 3262
3213 if ($self->extcmd == 2) {
3214 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3263 $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} 3264}
3234 3265
3235=item $success = $client->query ($flags, "text", \&cb) 3266=item $success = $client->query ($flags, "text", \&cb)
3236 3267
3237Queues a query to the client, calling the given callback with 3268Queues a query to the client, calling the given callback with
… …
3294 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3325 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3295 3326
3296 if (ref $msg) { 3327 if (ref $msg) {
3297 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash 3328 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3298 3329
3299 my @reply;
3300
3301 if (my $cb = $EXTICMD{$type}) { 3330 if (my $cb = $EXTIACMD{$type}) {
3331 $cb->(
3332 $ns,
3333 sub {
3334 $ns->ext_msg ("reply-$reply", @_)
3335 if $reply;
3336 },
3337 @payload
3338 );
3339 } else {
3340 my @reply;
3341
3342 if (my $cb = $EXTICMD{$type}) {
3302 @reply = $cb->($ns, @payload); 3343 @reply = $cb->($ns, @payload);
3344 }
3345
3346 $ns->ext_msg ("reply-$reply", @reply)
3347 if $reply;
3303 } 3348 }
3304
3305 $ns->ext_reply ($reply, @reply)
3306 if $reply;
3307
3308 } else { 3349 } else {
3309 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3350 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3310 } 3351 }
3311 3352
3312 cf::override; 3353 cf::override;
… …
3480=cut 3521=cut
3481 3522
3482############################################################################# 3523#############################################################################
3483# the server's init and main functions 3524# the server's init and main functions
3484 3525
3526{
3527 package cf::face;
3528
3529 our %HASH; # hash => idx
3530 our @DATA; # dynamically-created facedata, only faceste 0 used
3531 our @FOFS; # file offset, if > 0
3532 our @SIZE; # size of face, in octets
3533 our @META; # meta hash of face, if any
3534 our $DATAFH; # facedata filehandle
3535
3536 # internal api, not finalised
3537 sub set {
3538 my ($name, $type, $data) = @_;
3539
3540 my $idx = cf::face::find $name;
3541
3542 if ($idx) {
3543 delete $HASH{cf::face::get_chksum $idx};
3544 } else {
3545 $idx = cf::face::alloc $name;
3546 }
3547
3548 my $hash = cf::face::mangle_csum Digest::MD5::md5 $data;
3549
3550 cf::face::set_type $idx, $type;
3551 cf::face::set_csum $idx, 0, $hash;
3552
3553 # we need to destroy the SV itself, not just modify it, as a running ix
3554 # might hold a reference to it: "delete" achieves that.
3555 delete $FOFS[0][$idx];
3556 delete $DATA[0][$idx];
3557 $DATA[0][$idx] = $data;
3558 $SIZE[0][$idx] = length $data;
3559 delete $META[$idx];
3560 $HASH{$hash} = $idx;#d#
3561
3562 $idx
3563 }
3564
3565 sub _get_data($$$) {
3566 my ($idx, $set, $cb) = @_;
3567
3568 if (defined $DATA[$set][$idx]) {
3569 $cb->($DATA[$set][$idx]);
3570 } elsif (my $fofs = $FOFS[$set][$idx]) {
3571 my $size = $SIZE[$set][$idx];
3572 my $buf;
3573 IO::AIO::aio_read $DATAFH, $fofs, $size, $buf, 0, sub {
3574 if ($_[0] == $size) {
3575 #cf::debug "read face $idx, $size from $fofs as ", length $buf;#d#
3576 $cb->($buf);
3577 } else {
3578 cf::error "INTERNAL ERROR: unable to read facedata for face $idx#$set ($size, $fofs), ignoring request.";
3579 }
3580 };
3581 } else {
3582 cf::error "requested facedata for unknown face $idx#$set, ignoring.";
3583 }
3584 }
3585
3586 # rather ineffient
3587 sub cf::face::get_data($;$) {
3588 my ($idx, $set) = @_;
3589
3590 _get_data $idx, $set, Coro::rouse_cb;
3591 Coro::rouse_wait
3592 }
3593
3594 sub cf::face::ix {
3595 my ($ns, $set, $idx, $pri) = @_;
3596
3597 _get_data $idx, $set, sub {
3598 $ns->ix_send ($idx, $pri, $_[0]);
3599 };
3600 }
3601}
3602
3485sub load_facedata($) { 3603sub load_facedata($) {
3486 my ($path) = @_; 3604 my ($path) = @_;
3487 3605
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; 3606 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3493 3607
3494 trace "loading facedata from $path\n"; 3608 trace "loading facedata from $path\n";
3495 3609
3496 my $facedata = decode_storable load_file $path; 3610 my $facedata = decode_storable load_file "$path/faceinfo";
3497 3611
3498 $facedata->{version} == 2 3612 $facedata->{version} == 2
3499 or cf::cleanup "$path: version mismatch, cannot proceed."; 3613 or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";
3500 3614
3501 # patch in the exptable 3615 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]); 3616 or cf::cleanup "$path/facedata: $!, cannot proceed.";
3503 $facedata->{resource}{"res/exp_table"} = { 3617
3504 type => FT_RSRC, 3618 get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
3505 data => $exp_table, 3619
3506 hash => (Digest::MD5::md5 $exp_table), 3620 # BEGIN ATOMIC
3507 }; 3621 # from here on, everything must be atomic - no thread switch allowed
3508 cf::cede_to_tick; 3622 my $t1 = EV::time;
3509 3623
3510 { 3624 {
3511 my $faces = $facedata->{faceinfo}; 3625 my $faces = $facedata->{faceinfo};
3512 3626
3513 while (my ($face, $info) = each %$faces) { 3627 for my $face (sort keys %$faces) {
3628 my $info = $faces->{$face};
3514 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3629 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3515 3630
3516 cf::face::set_visibility $idx, $info->{visibility}; 3631 cf::face::set_visibility $idx, $info->{visibility};
3517 cf::face::set_magicmap $idx, $info->{magicmap}; 3632 cf::face::set_magicmap $idx, $info->{magicmap};
3518 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3633 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}; 3634 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} ; 3635 cf::face::set_csum $idx, 2, $info->{glyph}; $cf::face::DATA[2][$idx] = $info->{glyph};
3521 3636 $cf::face::HASH{$info->{hash64}} = $idx;
3522 cf::cede_to_tick; 3637 delete $cf::face::META[$idx];
3523 } 3638 }
3524 3639
3525 while (my ($face, $info) = each %$faces) { 3640 while (my ($face, $info) = each %$faces) {
3526 next unless $info->{smooth}; 3641 next unless $info->{smooth};
3527 3642
… …
3532 cf::face::set_smooth $idx, $smooth; 3647 cf::face::set_smooth $idx, $smooth;
3533 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3648 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3534 } else { 3649 } else {
3535 error "smooth face '$info->{smooth}' not found for face '$face'"; 3650 error "smooth face '$info->{smooth}' not found for face '$face'";
3536 } 3651 }
3537
3538 cf::cede_to_tick;
3539 } 3652 }
3540 } 3653 }
3541 3654
3542 { 3655 {
3543 my $anims = $facedata->{animinfo}; 3656 my $anims = $facedata->{animinfo};
3544 3657
3545 while (my ($anim, $info) = each %$anims) { 3658 while (my ($anim, $info) = each %$anims) {
3546 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3659 cf::anim::set $anim, $info->{frames}, $info->{facings};
3547 cf::cede_to_tick;
3548 } 3660 }
3549 3661
3550 cf::anim::invalidate_all; # d'oh 3662 cf::anim::invalidate_all; # d'oh
3551 } 3663 }
3552 3664
… …
3556 while (my ($name, $info) = each %$res) { 3668 while (my ($name, $info) = each %$res) {
3557 if (defined (my $type = $info->{type})) { 3669 if (defined (my $type = $info->{type})) {
3558 # TODO: different hash - must free and use new index, or cache ixface data queue 3670 # 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; 3671 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3560 3672
3561 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3562 cf::face::set_type $idx, $type; 3673 cf::face::set_type $idx, $type;
3674 cf::face::set_csum $idx, 0, $info->{hash};
3675 $cf::face::SIZE[0][$idx] = $info->{size};
3676 $cf::face::FOFS[0][$idx] = $info->{fofs};
3563 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already 3677 $cf::face::META[$idx] = $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3678 $cf::face::HASH{$info->{hash}} = $idx;
3564 } else { 3679 } else {
3565# $RESOURCE{$name} = $info; # unused 3680# $RESOURCE{$name} = $info; # unused
3566 } 3681 }
3567
3568 cf::cede_to_tick;
3569 } 3682 }
3570 } 3683 }
3684
3685 ($fh, $cf::face::DATAFH) = ($cf::face::DATAFH, $fh);
3686
3687 # HACK to clear player env face cache, we need some signal framework
3688 # for this (global event?)
3689 %ext::player_env::MUSIC_FACE_CACHE = ();
3690
3691 # END ATOMIC
3692
3693 cf::debug "facedata atomic update time ", EV::time - $t1;
3571 3694
3572 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3695 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3696
3697 aio_close $fh if $fh; # close old facedata
3573 3698
3574 1 3699 1
3575} 3700}
3576 3701
3577register_exticmd fx_want => sub { 3702register_exticmd fx_want => sub {
… …
3588 my $status = load_resource_file_ $_[0]; 3713 my $status = load_resource_file_ $_[0];
3589 get_slot 0.1, 100; 3714 get_slot 0.1, 100;
3590 cf::arch::commit_load; 3715 cf::arch::commit_load;
3591 3716
3592 $status 3717 $status
3718}
3719
3720sub reload_exp_table {
3721 _reload_exp_table;
3722
3723 cf::face::set
3724 "res/exp_table" => FT_RSRC,
3725 JSON::XS->new->utf8->canonical->encode (
3726 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3727 );
3728}
3729
3730sub reload_materials {
3731 _reload_materials;
3593} 3732}
3594 3733
3595sub reload_regions { 3734sub reload_regions {
3596 # HACK to clear player env face cache, we need some signal framework 3735 # HACK to clear player env face cache, we need some signal framework
3597 # for this (global event?) 3736 # for this (global event?)
… …
3605 if exists $_->{match}; 3744 if exists $_->{match};
3606 } 3745 }
3607} 3746}
3608 3747
3609sub reload_facedata { 3748sub reload_facedata {
3610 load_facedata "$DATADIR/facedata" 3749 load_facedata $DATADIR
3611 or die "unable to load facedata\n"; 3750 or die "unable to load facedata\n";
3612} 3751}
3613 3752
3614sub reload_archetypes { 3753sub reload_archetypes {
3615 load_resource_file "$DATADIR/archetypes" 3754 load_resource_file "$DATADIR/archetypes"
3616 or die "unable to load archetypes\n"; 3755 or die "unable to load archetypes\n";
3756
3757 cf::face::set
3758 "res/skill_info" => FT_RSRC,
3759 JSON::XS->new->utf8->canonical->encode (
3760 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3761 );
3762
3763 cf::face::set
3764 "res/spell_paths" => FT_RSRC,
3765 JSON::XS->new->utf8->canonical->encode (
3766 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3767 );
3617} 3768}
3618 3769
3619sub reload_treasures { 3770sub reload_treasures {
3620 load_resource_file "$DATADIR/treasures" 3771 load_resource_file "$DATADIR/treasures"
3621 or die "unable to load treasurelists\n"; 3772 or die "unable to load treasurelists\n";
… …
3642} 3793}
3643 3794
3644sub reload_resources { 3795sub reload_resources {
3645 trace "reloading resource files...\n"; 3796 trace "reloading resource files...\n";
3646 3797
3647 reload_exp_table;
3648 reload_materials; 3798 reload_materials;
3649 reload_facedata; 3799 reload_facedata;
3800 reload_exp_table;
3650 reload_sound; 3801 reload_sound;
3651 reload_archetypes; 3802 reload_archetypes;
3652 reload_regions; 3803 reload_regions;
3653 reload_treasures; 3804 reload_treasures;
3654 3805
… …
3713 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3864 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3714 3865
3715 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3866 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3716 3867
3717 # we must not ever block the main coroutine 3868 # we must not ever block the main coroutine
3718 local $Coro::idle = sub { 3869 $Coro::idle = sub {
3719 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3870 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3720 (async { 3871 (async {
3721 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3872 $Coro::current->{desc} = "IDLE BUG HANDLER";
3722 EV::loop EV::LOOP_ONESHOT; 3873 EV::loop EV::LOOP_ONESHOT;
3723 })->prio (Coro::PRIO_MAX); 3874 })->prio (Coro::PRIO_MAX);
… …
3726 evthread_start IO::AIO::poll_fileno; 3877 evthread_start IO::AIO::poll_fileno;
3727 3878
3728 cf::sync_job { 3879 cf::sync_job {
3729 cf::incloader::init (); 3880 cf::incloader::init ();
3730 3881
3882 db_init;
3883
3731 cf::init_anim; 3884 cf::init_anim;
3732 cf::init_attackmess; 3885 cf::init_attackmess;
3733 cf::init_dynamic; 3886 cf::init_dynamic;
3734 3887
3735 cf::load_settings; 3888 cf::load_settings;
3736 3889
3737 reload_resources; 3890 reload_resources;
3738 reload_config; 3891 reload_config;
3739 db_init;
3740 3892
3741 cf::init_uuid; 3893 cf::init_uuid;
3742 cf::init_signals; 3894 cf::init_signals;
3743 cf::init_skills; 3895 cf::init_skills;
3744 3896
… …
4169 } 4321 }
4170} 4322}
4171 4323
4172{ 4324{
4173 # configure BDB 4325 # configure BDB
4326 info "initialising database";
4174 4327
4175 BDB::min_parallel 16; 4328 BDB::min_parallel 16;
4176 BDB::max_poll_reqs $TICK * 0.1; 4329 BDB::max_poll_reqs $TICK * 0.1;
4177 #$AnyEvent::BDB::WATCHER->priority (1); 4330 #$AnyEvent::BDB::WATCHER->priority (1);
4178 4331
… …
4207 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4360 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4208 }; 4361 };
4209 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4362 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4210 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4363 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4211 }; 4364 };
4365
4366 info "database initialised";
4212} 4367}
4213 4368
4214{ 4369{
4215 # configure IO::AIO 4370 # configure IO::AIO
4216 4371
4372 info "initialising aio";
4217 IO::AIO::min_parallel 8; 4373 IO::AIO::min_parallel 8;
4218 IO::AIO::max_poll_time $TICK * 0.1; 4374 IO::AIO::max_poll_time $TICK * 0.1;
4219 undef $AnyEvent::AIO::WATCHER; 4375 undef $AnyEvent::AIO::WATCHER;
4376 info "aio initialised";
4220} 4377}
4221 4378
4222our $_log_backtrace; 4379our $_log_backtrace;
4223our $_log_backtrace_last; 4380our $_log_backtrace_last;
4224 4381

Diff Legend

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