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.574 by root, Sun May 8 21:51:27 2011 UTC vs.
Revision 1.598 by root, Sun Nov 11 02:38:10 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 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;
… …
108our $RANDOMDIR = "$LOCALDIR/random"; 113our $RANDOMDIR = "$LOCALDIR/random";
109our $BDBDIR = "$LOCALDIR/db"; 114our $BDBDIR = "$LOCALDIR/db";
110our $PIDFILE = "$LOCALDIR/pid"; 115our $PIDFILE = "$LOCALDIR/pid";
111our $RUNTIMEFILE = "$LOCALDIR/runtime"; 116our $RUNTIMEFILE = "$LOCALDIR/runtime";
112 117
113our %RESOURCE; # unused 118#our %RESOURCE; # unused
114 119
115our $OUTPUT_RATE_MIN = 3000; 120our $OUTPUT_RATE_MIN = 3000;
116our $OUTPUT_RATE_MAX = 1000000; 121our $OUTPUT_RATE_MAX = 1000000;
117 122
118our $MAX_LINKS = 32; # how many chained exits to follow 123our $MAX_LINKS = 32; # how many chained exits to follow
… …
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.
… …
335)) { 341)) {
336 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 342 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
337} 343}
338 344
339$EV::DIED = sub { 345$EV::DIED = sub {
340 Carp::cluck "error in event callback: @_"; 346 warn "error in event callback: $@";
341}; 347};
342 348
343############################################################################# 349#############################################################################
344 350
345sub fork_call(&@); 351sub fork_call(&@);
… …
372 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 378 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
373 $d 379 $d
374 } || "[unable to dump $_[0]: '$@']"; 380 } || "[unable to dump $_[0]: '$@']";
375} 381}
376 382
377=item $scalar = load_file $path 383=item $scalar = cf::load_file $path
378 384
379Loads the given file from path and returns its contents. Croaks on error 385Loads the given file from path and returns its contents. Croaks on error
380and can block. 386and can block.
381 387
382=cut 388=cut
… …
384sub load_file($) { 390sub load_file($) {
385 0 <= aio_load $_[0], my $data 391 0 <= aio_load $_[0], my $data
386 or Carp::croak "$_[0]: $!"; 392 or Carp::croak "$_[0]: $!";
387 393
388 $data 394 $data
395}
396
397=item $success = cf::replace_file $path, $data, $sync
398
399Atomically replaces the file at the given $path with new $data, and
400optionally $sync the data to disk before replacing the file.
401
402=cut
403
404sub replace_file($$;$) {
405 my ($path, $data, $sync) = @_;
406
407 my $lock = cf::lock_acquire ("replace_file:$path");
408
409 my $fh = aio_open "$path~", Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_TRUNC, 0644
410 or return;
411
412 $data = $data->() if ref $data;
413
414 length $data == aio_write $fh, 0, (length $data), $data, 0
415 or return;
416
417 !$sync
418 or !aio_fsync $fh
419 or return;
420
421 aio_close $fh
422 and return;
423
424 aio_rename "$path~", $path
425 and return;
426
427 if ($sync) {
428 $path =~ s%/[^/]*$%%;
429 aio_pathsync $path;
430 }
431
432 1
389} 433}
390 434
391=item $ref = cf::decode_json $json 435=item $ref = cf::decode_json $json
392 436
393Converts a JSON string into the corresponding perl data structure. 437Converts a JSON string into the corresponding perl data structure.
… …
856 900
857 return db_get cache => "$id/data"; 901 return db_get cache => "$id/data";
858 } 902 }
859 } 903 }
860 904
861 my $t1 = Time::HiRes::time; 905 my $t1 = EV::time;
862 my $data = $process->(\@data); 906 my $data = $process->(\@data);
863 my $t2 = Time::HiRes::time; 907 my $t2 = EV::time;
864 908
865 info "cache: '$id' processed in ", $t2 - $t1, "s\n"; 909 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
866 910
867 db_put cache => "$id/data", $data; 911 db_put cache => "$id/data", $data;
868 db_put cache => "$id/md5" , $md5; 912 db_put cache => "$id/md5" , $md5;
… …
1388=cut 1432=cut
1389 1433
1390############################################################################# 1434#############################################################################
1391# command handling &c 1435# command handling &c
1392 1436
1393=item cf::register_command $name => \&callback($ob,$args); 1437=item cf::register_command $name => \&callback($ob,$args)
1394 1438
1395Register a callback for execution when the client sends the user command 1439Register a callback for execution when the client sends the user command
1396$name. 1440$name.
1397 1441
1398=cut 1442=cut
… …
1404 #warn "registering command '$name/$time' to '$caller'"; 1448 #warn "registering command '$name/$time' to '$caller'";
1405 1449
1406 push @{ $COMMAND{$name} }, [$caller, $cb]; 1450 push @{ $COMMAND{$name} }, [$caller, $cb];
1407} 1451}
1408 1452
1409=item cf::register_extcmd $name => \&callback($pl,$packet); 1453=item cf::register_extcmd $name => \&callback($pl,@args)
1410 1454
1411Register a callback for execution when the client sends an (synchronous) 1455Register a callback for execution when the client sends an (synchronous)
1412extcmd packet. Ext commands will be processed in the order they are 1456extcmd packet. Ext commands will be processed in the order they are
1413received by the server, like other user commands. The first argument is 1457received by the server, like other user commands. The first argument is
1414the logged-in player. Ext commands can only be processed after a player 1458the logged-in player. Ext commands can only be processed after a player
1415has logged in successfully. 1459has logged in successfully.
1416 1460
1417If the callback returns something, it is sent back as if reply was being 1461The values will be sent back to the client.
1418called.
1419 1462
1463=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
1464
1465Same as C<cf::register_extcmd>, but instead of returning values, the
1466callback needs to clal the C<$reply> function.
1467
1420=item cf::register_exticmd $name => \&callback($ns,$packet); 1468=item cf::register_exticmd $name => \&callback($ns,@args)
1421 1469
1422Register a callback for execution when the client sends an (asynchronous) 1470Register a callback for execution when the client sends an (asynchronous)
1423exticmd packet. Exti commands are processed by the server as soon as they 1471exticmd packet. Exti commands are processed by the server as soon as they
1424are received, i.e. out of order w.r.t. other commands. The first argument 1472are received, i.e. out of order w.r.t. other commands. The first argument
1425is a client socket. Exti commands can be received anytime, even before 1473is a client socket. Exti commands can be received anytime, even before
1426log-in. 1474log-in.
1427 1475
1428If the callback returns something, it is sent back as if reply was being 1476The values will be sent back to the client.
1429called.
1430 1477
1431=cut 1478=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
1432 1479
1480Same as C<cf::register_extcmd>, but instead of returning values, the
1481callback needs to clal the C<$reply> function.
1482
1483=cut
1484
1433sub register_extcmd { 1485sub register_extcmd($$) {
1434 my ($name, $cb) = @_; 1486 my ($name, $cb) = @_;
1435 1487
1436 $EXTCMD{$name} = $cb; 1488 $EXTCMD{$name} = $cb;
1437} 1489}
1438 1490
1439sub register_exticmd { 1491sub register_async_extcmd($$) {
1440 my ($name, $cb) = @_; 1492 my ($name, $cb) = @_;
1441 1493
1494 $EXTACMD{$name} = $cb;
1495}
1496
1497sub register_exticmd($$) {
1498 my ($name, $cb) = @_;
1499
1442 $EXTICMD{$name} = $cb; 1500 $EXTICMD{$name} = $cb;
1501}
1502
1503sub register_async_exticmd($$) {
1504 my ($name, $cb) = @_;
1505
1506 $EXTIACMD{$name} = $cb;
1443} 1507}
1444 1508
1445use File::Glob (); 1509use File::Glob ();
1446 1510
1447cf::player->attach ( 1511cf::player->attach (
… …
1461 my ($pl, $buf) = @_; 1525 my ($pl, $buf) = @_;
1462 1526
1463 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1527 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1464 1528
1465 if (ref $msg) { 1529 if (ref $msg) {
1466 my ($type, $reply, @payload) = 1530 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1467 "ARRAY" eq ref $msg
1468 ? @$msg
1469 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1470 1531
1471 my @reply;
1472
1473 if (my $cb = $EXTCMD{$type}) { 1532 if (my $cb = $EXTACMD{$type}) {
1533 $cb->(
1534 $pl,
1535 sub {
1536 $pl->ext_msg ("reply-$reply", @_)
1537 if $reply;
1538 },
1539 @payload
1540 );
1541 } else {
1542 my @reply;
1543
1544 if (my $cb = $EXTCMD{$type}) {
1474 @reply = $cb->($pl, @payload); 1545 @reply = $cb->($pl, @payload);
1546 }
1547
1548 $pl->ext_msg ("reply-$reply", @reply)
1549 if $reply;
1475 } 1550 }
1476
1477 $pl->ext_reply ($reply, @reply)
1478 if $reply;
1479 1551
1480 } else { 1552 } else {
1481 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1553 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1482 } 1554 }
1483 1555
… …
1496 }; 1568 };
1497 1569
1498 $grp 1570 $grp
1499} 1571}
1500 1572
1573sub _ext_cfg_reg($$$$) {
1574 my ($rvar, $varname, $cfgname, $default) = @_;
1575
1576 $cfgname = lc $varname
1577 unless length $cfgname;
1578
1579 $EXT_CFG{$cfgname} = [$rvar, $default];
1580
1581 $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
1582}
1583
1501sub load_extensions { 1584sub load_extensions {
1502 info "loading extensions..."; 1585 info "loading extensions...";
1586
1587 %EXT_CFG = ();
1503 1588
1504 cf::sync_job { 1589 cf::sync_job {
1505 my %todo; 1590 my %todo;
1506 1591
1507 for my $path (<$LIBDIR/*.ext>) { 1592 for my $path (<$LIBDIR/*.ext>) {
… …
1550 unless exists $done{$_}; 1635 unless exists $done{$_};
1551 } 1636 }
1552 1637
1553 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n"; 1638 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1554 1639
1640 my $source = $v->{source};
1641
1642 # support "CONF varname :confname = default" pseudo-statements
1643 $source =~ s{
1644 ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
1645 }{
1646 "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
1647 }gmxe;
1648
1555 my $active = eval $v->{source}; 1649 my $active = eval $source;
1556 1650
1557 if (length $@) { 1651 if (length $@) {
1558 error "$v->{path}: $@\n"; 1652 error "$v->{path}: $@\n";
1559 1653
1560 cf::cleanup "mandatory extension '$k' failed to load, exiting." 1654 cf::cleanup "mandatory extension '$k' failed to load, exiting."
… …
1847} 1941}
1848 1942
1849=item $protocol_xml = $player->expand_cfpod ($cfpod) 1943=item $protocol_xml = $player->expand_cfpod ($cfpod)
1850 1944
1851Expand deliantra pod fragments into protocol xml. 1945Expand deliantra pod fragments into protocol xml.
1852
1853=item $player->ext_reply ($msgid, @msg)
1854
1855Sends an ext reply to the player.
1856
1857=cut
1858
1859sub ext_reply($$@) {
1860 my ($self, $id, @msg) = @_;
1861
1862 $self->ns->ext_reply ($id, @msg)
1863}
1864 1946
1865=item $player->ext_msg ($type, @msg) 1947=item $player->ext_msg ($type, @msg)
1866 1948
1867Sends an ext event to the client. 1949Sends an ext event to the client.
1868 1950
… …
3173=cut 3255=cut
3174 3256
3175sub cf::client::ext_msg($$@) { 3257sub cf::client::ext_msg($$@) {
3176 my ($self, $type, @msg) = @_; 3258 my ($self, $type, @msg) = @_;
3177 3259
3178 if ($self->extcmd == 2) {
3179 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3260 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3180 } elsif ($self->extcmd == 1) { # TODO: remove
3181 push @msg, msgtype => "event_$type";
3182 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3183 }
3184}
3185
3186=item $client->ext_reply ($msgid, @msg)
3187
3188Sends an ext reply to the client.
3189
3190=cut
3191
3192sub cf::client::ext_reply($$@) {
3193 my ($self, $id, @msg) = @_;
3194
3195 if ($self->extcmd == 2) {
3196 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3197 } elsif ($self->extcmd == 1) {
3198 #TODO: version 1, remove
3199 unshift @msg, msgtype => "reply", msgid => $id;
3200 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3201 }
3202} 3261}
3203 3262
3204=item $success = $client->query ($flags, "text", \&cb) 3263=item $success = $client->query ($flags, "text", \&cb)
3205 3264
3206Queues a query to the client, calling the given callback with 3265Queues a query to the client, calling the given callback with
… …
3261 my ($ns, $buf) = @_; 3320 my ($ns, $buf) = @_;
3262 3321
3263 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3322 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3264 3323
3265 if (ref $msg) { 3324 if (ref $msg) {
3266 my ($type, $reply, @payload) = 3325 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3267 "ARRAY" eq ref $msg
3268 ? @$msg
3269 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3270 3326
3271 my @reply;
3272
3273 if (my $cb = $EXTICMD{$type}) { 3327 if (my $cb = $EXTIACMD{$type}) {
3328 $cb->(
3329 $ns,
3330 sub {
3331 $ns->ext_msg ("reply-$reply", @_)
3332 if $reply;
3333 },
3334 @payload
3335 );
3336 } else {
3337 my @reply;
3338
3339 if (my $cb = $EXTICMD{$type}) {
3274 @reply = $cb->($ns, @payload); 3340 @reply = $cb->($ns, @payload);
3341 }
3342
3343 $ns->ext_msg ("reply-$reply", @reply)
3344 if $reply;
3275 } 3345 }
3276
3277 $ns->ext_reply ($reply, @reply)
3278 if $reply;
3279
3280 } else { 3346 } else {
3281 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3347 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3282 } 3348 }
3283 3349
3284 cf::override; 3350 cf::override;
… …
3452=cut 3518=cut
3453 3519
3454############################################################################# 3520#############################################################################
3455# the server's init and main functions 3521# the server's init and main functions
3456 3522
3523our %FACEHASH; # hash => idx, #d# HACK for http server
3524
3525# internal api, not fianlised
3526sub set_face {
3527 my ($name, $type, $data) = @_;
3528
3529 my $idx = cf::face::find $name;
3530
3531 if ($idx) {
3532 delete $FACEHASH{cf::face::get_chksum $idx};
3533 } else {
3534 $idx = cf::face::alloc $name;
3535 }
3536
3537 my $hash = cf::face::mangle_chksum Digest::MD5::md5 $data;
3538
3539 cf::face::set_type $idx, $type;
3540 cf::face::set_data $idx, 0, $data, $hash;
3541 cf::face::set_meta $idx, $type & 1 ? undef : undef;
3542 $FACEHASH{$hash} = $idx;#d#
3543
3544 $idx
3545}
3546
3457sub load_facedata($) { 3547sub load_facedata($) {
3458 my ($path) = @_; 3548 my ($path) = @_;
3459 3549
3460 # HACK to clear player env face cache, we need some signal framework 3550 # HACK to clear player env face cache, we need some signal framework
3461 # for this (global event?) 3551 # for this (global event?)
… …
3468 my $facedata = decode_storable load_file $path; 3558 my $facedata = decode_storable load_file $path;
3469 3559
3470 $facedata->{version} == 2 3560 $facedata->{version} == 2
3471 or cf::cleanup "$path: version mismatch, cannot proceed."; 3561 or cf::cleanup "$path: version mismatch, cannot proceed.";
3472 3562
3473 # patch in the exptable
3474 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3475 $facedata->{resource}{"res/exp_table"} = {
3476 type => FT_RSRC,
3477 data => $exp_table,
3478 hash => (Digest::MD5::md5 $exp_table),
3479 };
3480 cf::cede_to_tick; 3563 cf::cede_to_tick;
3481 3564
3482 { 3565 {
3483 my $faces = $facedata->{faceinfo}; 3566 my $faces = delete $facedata->{faceinfo};
3484 3567
3485 while (my ($face, $info) = each %$faces) { 3568 for my $face (sort keys %$faces) {
3569 my $info = $faces->{$face};
3486 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3570 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3487 3571
3488 cf::face::set_visibility $idx, $info->{visibility}; 3572 cf::face::set_visibility $idx, $info->{visibility};
3489 cf::face::set_magicmap $idx, $info->{magicmap}; 3573 cf::face::set_magicmap $idx, $info->{magicmap};
3490 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3574 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3491 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3575 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3492 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ; 3576 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3493 3577 $FACEHASH{$info->{hash64}} = $idx;#d#
3578
3494 cf::cede_to_tick; 3579 cf::cede_to_tick;
3495 } 3580 }
3496 3581
3497 while (my ($face, $info) = each %$faces) { 3582 while (my ($face, $info) = each %$faces) {
3498 next unless $info->{smooth}; 3583 next unless $info->{smooth};
… …
3510 cf::cede_to_tick; 3595 cf::cede_to_tick;
3511 } 3596 }
3512 } 3597 }
3513 3598
3514 { 3599 {
3515 my $anims = $facedata->{animinfo}; 3600 my $anims = delete $facedata->{animinfo};
3516 3601
3517 while (my ($anim, $info) = each %$anims) { 3602 while (my ($anim, $info) = each %$anims) {
3518 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3603 cf::anim::set $anim, $info->{frames}, $info->{facings};
3519 cf::cede_to_tick; 3604 cf::cede_to_tick;
3520 } 3605 }
3521 3606
3522 cf::anim::invalidate_all; # d'oh 3607 cf::anim::invalidate_all; # d'oh
3523 } 3608 }
3524 3609
3525 { 3610 {
3526 my $res = $facedata->{resource}; 3611 my $res = delete $facedata->{resource};
3527 3612
3528 while (my ($name, $info) = each %$res) { 3613 while (my ($name, $info) = each %$res) {
3529 if (defined $info->{type}) { 3614 if (defined (my $type = $info->{type})) {
3615 # TODO: different hash - must free and use new index, or cache ixface data queue
3530 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3616 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3531 3617
3618 cf::face::set_type $idx, $type;
3532 cf::face::set_data $idx, 0, $info->{data}, $info->{hash}; 3619 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3533 cf::face::set_type $idx, $info->{type}; 3620 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3621 $FACEHASH{$info->{hash}} = $idx;#d#
3534 } else { 3622 } else {
3535 $RESOURCE{$name} = $info; # unused 3623# $RESOURCE{$name} = $info; # unused
3536 } 3624 }
3537 3625
3538 cf::cede_to_tick; 3626 cf::cede_to_tick;
3539 } 3627 }
3540 } 3628 }
… …
3558 my $status = load_resource_file_ $_[0]; 3646 my $status = load_resource_file_ $_[0];
3559 get_slot 0.1, 100; 3647 get_slot 0.1, 100;
3560 cf::arch::commit_load; 3648 cf::arch::commit_load;
3561 3649
3562 $status 3650 $status
3651}
3652
3653sub reload_exp_table {
3654 _reload_exp_table;
3655
3656 set_face "res/exp_table" => FT_RSRC,
3657 JSON::XS->new->utf8->canonical->encode (
3658 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3659 );
3660}
3661
3662sub reload_materials {
3663 _reload_materials;
3563} 3664}
3564 3665
3565sub reload_regions { 3666sub reload_regions {
3566 # HACK to clear player env face cache, we need some signal framework 3667 # HACK to clear player env face cache, we need some signal framework
3567 # for this (global event?) 3668 # for this (global event?)
… …
3582} 3683}
3583 3684
3584sub reload_archetypes { 3685sub reload_archetypes {
3585 load_resource_file "$DATADIR/archetypes" 3686 load_resource_file "$DATADIR/archetypes"
3586 or die "unable to load archetypes\n"; 3687 or die "unable to load archetypes\n";
3688
3689 set_face "res/skill_info" => FT_RSRC,
3690 JSON::XS->new->utf8->canonical->encode (
3691 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3692 );
3693 set_face "res/spell_paths" => FT_RSRC,
3694 JSON::XS->new->utf8->canonical->encode (
3695 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3696 );
3587} 3697}
3588 3698
3589sub reload_treasures { 3699sub reload_treasures {
3590 load_resource_file "$DATADIR/treasures" 3700 load_resource_file "$DATADIR/treasures"
3591 or die "unable to load treasurelists\n"; 3701 or die "unable to load treasurelists\n";
… …
3612} 3722}
3613 3723
3614sub reload_resources { 3724sub reload_resources {
3615 trace "reloading resource files...\n"; 3725 trace "reloading resource files...\n";
3616 3726
3617 reload_exp_table;
3618 reload_materials; 3727 reload_materials;
3619 reload_facedata; 3728 reload_facedata;
3729 reload_exp_table;
3620 reload_sound; 3730 reload_sound;
3621 reload_archetypes; 3731 reload_archetypes;
3622 reload_regions; 3732 reload_regions;
3623 reload_treasures; 3733 reload_treasures;
3624 3734
… …
3676 3786
3677sub main { 3787sub main {
3678 cf::init_globals; # initialise logging 3788 cf::init_globals; # initialise logging
3679 3789
3680 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3790 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3681 LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3791 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3682 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3792 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3683 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3793 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3684 3794
3685 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3795 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3686 3796
3687 # we must not ever block the main coroutine 3797 # we must not ever block the main coroutine
3688 local $Coro::idle = sub { 3798 $Coro::idle = sub {
3689 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3799 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3690 (async { 3800 (async {
3691 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3801 $Coro::current->{desc} = "IDLE BUG HANDLER";
3692 EV::loop EV::LOOP_ONESHOT; 3802 EV::loop EV::LOOP_ONESHOT;
3693 })->prio (Coro::PRIO_MAX); 3803 })->prio (Coro::PRIO_MAX);
… …
3696 evthread_start IO::AIO::poll_fileno; 3806 evthread_start IO::AIO::poll_fileno;
3697 3807
3698 cf::sync_job { 3808 cf::sync_job {
3699 cf::incloader::init (); 3809 cf::incloader::init ();
3700 3810
3811 db_init;
3812
3701 cf::init_anim; 3813 cf::init_anim;
3702 cf::init_attackmess; 3814 cf::init_attackmess;
3703 cf::init_dynamic; 3815 cf::init_dynamic;
3704 3816
3705 cf::load_settings; 3817 cf::load_settings;
3706 3818
3707 reload_resources; 3819 reload_resources;
3708 reload_config; 3820 reload_config;
3709 db_init;
3710 3821
3711 cf::init_uuid; 3822 cf::init_uuid;
3712 cf::init_signals; 3823 cf::init_signals;
3713 cf::init_skills; 3824 cf::init_skills;
3714 3825
… …
3728 }; 3839 };
3729 3840
3730 cf::object::thawer::errors_are_fatal 0; 3841 cf::object::thawer::errors_are_fatal 0;
3731 info "parse errors in files are no longer fatal from this point on.\n"; 3842 info "parse errors in files are no longer fatal from this point on.\n";
3732 3843
3733 my $free_main; $free_main = EV::idle sub { 3844 AE::postpone {
3734 undef $free_main;
3735 undef &main; # free gobs of memory :) 3845 undef &main; # free gobs of memory :)
3736 }; 3846 };
3737 3847
3738 goto &main_loop; 3848 goto &main_loop;
3739} 3849}
… …
3896 4006
3897 cf::write_runtime_sync; # external watchdog should not bark 4007 cf::write_runtime_sync; # external watchdog should not bark
3898 4008
3899 trace "emergency_perl_save: flushing outstanding aio requests"; 4009 trace "emergency_perl_save: flushing outstanding aio requests";
3900 while (IO::AIO::nreqs || BDB::nreqs) { 4010 while (IO::AIO::nreqs || BDB::nreqs) {
3901 Coro::EV::timer_once 0.01; # let the sync_job do it's thing 4011 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
3902 } 4012 }
3903 4013
3904 cf::write_runtime_sync; # external watchdog should not bark 4014 cf::write_runtime_sync; # external watchdog should not bark
3905 }; 4015 };
3906 4016
… …
4140 } 4250 }
4141} 4251}
4142 4252
4143{ 4253{
4144 # configure BDB 4254 # configure BDB
4255 info "initialising database";
4145 4256
4146 BDB::min_parallel 16; 4257 BDB::min_parallel 16;
4147 BDB::max_poll_reqs $TICK * 0.1; 4258 BDB::max_poll_reqs $TICK * 0.1;
4148 $AnyEvent::BDB::WATCHER->priority (1); 4259 #$AnyEvent::BDB::WATCHER->priority (1);
4149 4260
4150 unless ($DB_ENV) { 4261 unless ($DB_ENV) {
4151 $DB_ENV = BDB::db_env_create; 4262 $DB_ENV = BDB::db_env_create;
4152 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4263 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4153 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4264 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
… …
4178 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4289 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4179 }; 4290 };
4180 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4291 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4181 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4292 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4182 }; 4293 };
4294
4295 info "database initialised";
4183} 4296}
4184 4297
4185{ 4298{
4186 # configure IO::AIO 4299 # configure IO::AIO
4187 4300
4301 info "initialising aio";
4188 IO::AIO::min_parallel 8; 4302 IO::AIO::min_parallel 8;
4189 IO::AIO::max_poll_time $TICK * 0.1; 4303 IO::AIO::max_poll_time $TICK * 0.1;
4190 undef $AnyEvent::AIO::WATCHER; 4304 undef $AnyEvent::AIO::WATCHER;
4305 info "aio initialised";
4191} 4306}
4192 4307
4193our $_log_backtrace; 4308our $_log_backtrace;
4194our $_log_backtrace_last; 4309our $_log_backtrace_last;
4195 4310

Diff Legend

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