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.561 by root, Fri Apr 22 06:10:33 2011 UTC vs.
Revision 1.613 by root, Mon Nov 26 13:12:16 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 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; 142our $RUNTIME = 0;
143our $SERVER_TICK = 0;
137our $NOW; 144our $NOW;
138 145
139our (%PLAYER, %PLAYER_LOADING); # all users 146our (%PLAYER, %PLAYER_LOADING); # all users
140our (%MAP, %MAP_LOADING ); # all maps 147our (%MAP, %MAP_LOADING ); # all maps
141our $LINK_MAP; # the special {link} map, which is always available 148our $LINK_MAP; # the special {link} map, which is always available
150 157
151our @POST_INIT; 158our @POST_INIT;
152 159
153our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow) 160our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
154our $REALLY_UNLOOP; # never set to true, please :) 161our $REALLY_UNLOOP; # never set to true, please :)
162
163our $WAIT_FOR_TICK = new Coro::Signal;
164our @WAIT_FOR_TICK_BEGIN;
155 165
156binmode STDOUT; 166binmode STDOUT;
157binmode STDERR; 167binmode STDERR;
158 168
159# read virtual server time, if available 169# read virtual server time, if available
193 203
194=over 4 204=over 4
195 205
196=item $cf::UPTIME 206=item $cf::UPTIME
197 207
198The timestamp of the server start (so not actually an uptime). 208The timestamp of the server start (so not actually an "uptime").
209
210=item $cf::SERVER_TICK
211
212An unsigned integer that starts at zero when the server is started and is
213incremented on every tick.
214
215=item $cf::NOW
216
217The (real) time of the last (current) server tick - updated before and
218after tick processing, so this is useful only as a rough "what time is it
219now" estimate.
220
221=item $cf::TICK
222
223The interval between each server tick, in seconds.
199 224
200=item $cf::RUNTIME 225=item $cf::RUNTIME
201 226
202The 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
203every server tick. 228every server tick.
204 229
205=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR 230=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
206$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR 231$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
207$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR 232$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
208 233
209Various directories - "/etc", read-only install directory, perl-library 234Various directories - "/etc", read-only install directory, perl-library
210directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 235directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
211unique-items directory, player file directory, random maps directory and 236unique-items directory, player file directory, random maps directory and
212database environment. 237database environment.
213 238
214=item $cf::NOW
215
216The time of the last (current) server tick.
217
218=item $cf::TICK
219
220The interval between server ticks, in seconds.
221
222=item $cf::LOADAVG 239=item $cf::LOADAVG
223 240
224The current CPU load on the server (alpha-smoothed), as a value between 0 241The current CPU load on the server (alpha-smoothed), as a value between 0
225(none) and 1 (overloaded), indicating how much time is spent on processing 242(none) and 1 (overloaded), indicating how much time is spent on processing
226objects per tick. Healthy values are < 0.5. 243objects per tick. Healthy values are < 0.5.
234Configuration for the server, loaded from C</etc/deliantra-server/config>, or 251Configuration for the server, loaded from C</etc/deliantra-server/config>, or
235from wherever your confdir points to. 252from wherever your confdir points to.
236 253
237=item cf::wait_for_tick, cf::wait_for_tick_begin 254=item cf::wait_for_tick, cf::wait_for_tick_begin
238 255
239These 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.
240returns 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
241per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 259cf::wait_for_tick wakes up all waiters after tick processing.
260
261Note that cf::wait_for_tick will immediately return when the server is not
262ticking, making it suitable for small pauses in threads that need to run
263when the server is paused. If that is not applicable (i.e. you I<really>
264want to wait, use C<$cf::WAIT_FOR_TICK>).
265
266=item $cf::WAIT_FOR_TICK
267
268Note that C<cf::wait_for_tick> is probably the correct thing to use. This
269variable contains a L<Coro::Signal> that is broadcats after every server
270tick. Calling C<< ->wait >> on it will suspend the caller until after the
271next server tick.
242 272
243=cut 273=cut
244 274
245sub wait_for_tick(); 275sub wait_for_tick();
246sub wait_for_tick_begin(); 276sub wait_for_tick_begin();
312)) { 342)) {
313 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 343 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
314} 344}
315 345
316$EV::DIED = sub { 346$EV::DIED = sub {
317 Carp::cluck "error in event callback: @_"; 347 warn "error in event callback: $@";
318}; 348};
319 349
320############################################################################# 350#############################################################################
321 351
322sub fork_call(&@); 352sub fork_call(&@);
349 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 379 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
350 $d 380 $d
351 } || "[unable to dump $_[0]: '$@']"; 381 } || "[unable to dump $_[0]: '$@']";
352} 382}
353 383
354=item $scalar = load_file $path 384=item $scalar = cf::load_file $path
355 385
356Loads the given file from path and returns its contents. Croaks on error 386Loads the given file from path and returns its contents. Croaks on error
357and can block. 387and can block.
358 388
359=cut 389=cut
361sub load_file($) { 391sub load_file($) {
362 0 <= aio_load $_[0], my $data 392 0 <= aio_load $_[0], my $data
363 or Carp::croak "$_[0]: $!"; 393 or Carp::croak "$_[0]: $!";
364 394
365 $data 395 $data
396}
397
398=item $success = cf::replace_file $path, $data, $sync
399
400Atomically replaces the file at the given $path with new $data, and
401optionally $sync the data to disk before replacing the file.
402
403=cut
404
405sub replace_file($$;$) {
406 my ($path, $data, $sync) = @_;
407
408 my $lock = cf::lock_acquire ("replace_file:$path");
409
410 my $fh = aio_open "$path~", Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_TRUNC, 0644
411 or return;
412
413 $data = $data->() if ref $data;
414
415 length $data == aio_write $fh, 0, (length $data), $data, 0
416 or return;
417
418 !$sync
419 or !aio_fsync $fh
420 or return;
421
422 aio_close $fh
423 and return;
424
425 aio_rename "$path~", $path
426 and return;
427
428 if ($sync) {
429 $path =~ s%/[^/]*$%%;
430 aio_pathsync $path;
431 }
432
433 1
366} 434}
367 435
368=item $ref = cf::decode_json $json 436=item $ref = cf::decode_json $json
369 437
370Converts a JSON string into the corresponding perl data structure. 438Converts a JSON string into the corresponding perl data structure.
505Allocate $time seconds of blocking CPU time at priority C<$priority> 573Allocate $time seconds of blocking CPU time at priority C<$priority>
506(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
507C<$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
508till the next cede. 576till the next cede.
509 577
510Background jobs should use a priority les than zero, interactive jobs 578Background jobs should use a priority less than zero, interactive jobs
511should use 100 or more. 579should use 100 or more.
512 580
513The 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
514used for statistical purposes and should identify the same time-class. 582used for statistical purposes and should identify the same time-class.
515 583
528 my $signal = new Coro::Signal; 596 my $signal = new Coro::Signal;
529 my $busy; 597 my $busy;
530 598
531 while () { 599 while () {
532 next_job: 600 next_job:
601
602 Coro::cede;
533 603
534 my $avail = cf::till_tick; 604 my $avail = cf::till_tick;
535 605
536 for (0 .. $#SLOT_QUEUE) { 606 for (0 .. $#SLOT_QUEUE) {
537 if ($SLOT_QUEUE[$_][0] <= $avail) { 607 if ($SLOT_QUEUE[$_][0] <= $avail) {
538 $busy = 0; 608 $busy = 0;
539 my $job = splice @SLOT_QUEUE, $_, 1, (); 609 my $job = splice @SLOT_QUEUE, $_, 1, ();
540 $job->[2]->send; 610 $job->[2]->send;
541 Coro::cede;
542 goto next_job; 611 goto next_job;
543 } else { 612 } else {
544 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY; 613 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
545 } 614 }
546 } 615 }
547 616
548 if (@SLOT_QUEUE) { 617 if (@SLOT_QUEUE) {
549 # we do not use wait_for_tick() as it returns immediately when tick is inactive 618 wait_for_tick;
550 push @cf::WAIT_FOR_TICK, $signal;
551 $signal->wait;
552 } else { 619 } else {
553 $busy = 0; 620 $busy = 0;
554 Coro::schedule; 621 Coro::schedule;
555 } 622 }
556 } 623 }
671 reset_signals; 738 reset_signals;
672} 739}
673 740
674sub fork_call(&@) { 741sub fork_call(&@) {
675 my ($cb, @args) = @_; 742 my ($cb, @args) = @_;
676
677 # we seemingly have to make a local copy of the whole thing,
678 # otherwise perl prematurely frees the stuff :/
679 # TODO: investigate and fix (likely this will be rather laborious)
680 743
681 my @res = Coro::Util::fork_eval { 744 my @res = Coro::Util::fork_eval {
682 cf::post_fork; 745 cf::post_fork;
683 &$cb 746 &$cb
684 } @args; 747 } @args;
834 897
835 return db_get cache => "$id/data"; 898 return db_get cache => "$id/data";
836 } 899 }
837 } 900 }
838 901
839 my $t1 = Time::HiRes::time; 902 my $t1 = EV::time;
840 my $data = $process->(\@data); 903 my $data = $process->(\@data);
841 my $t2 = Time::HiRes::time; 904 my $t2 = EV::time;
842 905
843 info "cache: '$id' processed in ", $t2 - $t1, "s\n"; 906 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
844 907
845 db_put cache => "$id/data", $data; 908 db_put cache => "$id/data", $data;
846 db_put cache => "$id/md5" , $md5; 909 db_put cache => "$id/md5" , $md5;
1366=cut 1429=cut
1367 1430
1368############################################################################# 1431#############################################################################
1369# command handling &c 1432# command handling &c
1370 1433
1371=item cf::register_command $name => \&callback($ob,$args); 1434=item cf::register_command $name => \&callback($ob,$args)
1372 1435
1373Register a callback for execution when the client sends the user command 1436Register a callback for execution when the client sends the user command
1374$name. 1437$name.
1375 1438
1376=cut 1439=cut
1382 #warn "registering command '$name/$time' to '$caller'"; 1445 #warn "registering command '$name/$time' to '$caller'";
1383 1446
1384 push @{ $COMMAND{$name} }, [$caller, $cb]; 1447 push @{ $COMMAND{$name} }, [$caller, $cb];
1385} 1448}
1386 1449
1387=item cf::register_extcmd $name => \&callback($pl,$packet); 1450=item cf::register_extcmd $name => \&callback($pl,@args)
1388 1451
1389Register a callback for execution when the client sends an (synchronous) 1452Register a callback for execution when the client sends an (synchronous)
1390extcmd packet. Ext commands will be processed in the order they are 1453extcmd packet. Ext commands will be processed in the order they are
1391received by the server, like other user commands. The first argument is 1454received by the server, like other user commands. The first argument is
1392the 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
1393has logged in successfully. 1456has logged in successfully.
1394 1457
1395If the callback returns something, it is sent back as if reply was being 1458The values will be sent back to the client.
1396called.
1397 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
1398=item cf::register_exticmd $name => \&callback($ns,$packet); 1465=item cf::register_exticmd $name => \&callback($ns,@args)
1399 1466
1400Register a callback for execution when the client sends an (asynchronous) 1467Register a callback for execution when the client sends an (asynchronous)
1401exticmd 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
1402are 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
1403is a client socket. Exti commands can be received anytime, even before 1470is a client socket. Exti commands can be received anytime, even before
1404log-in. 1471log-in.
1405 1472
1406If the callback returns something, it is sent back as if reply was being 1473The values will be sent back to the client.
1407called.
1408 1474
1409=cut 1475=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
1410 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
1411sub register_extcmd { 1482sub register_extcmd($$) {
1412 my ($name, $cb) = @_; 1483 my ($name, $cb) = @_;
1413 1484
1414 $EXTCMD{$name} = $cb; 1485 $EXTCMD{$name} = $cb;
1415} 1486}
1416 1487
1417sub register_exticmd { 1488sub register_async_extcmd($$) {
1418 my ($name, $cb) = @_; 1489 my ($name, $cb) = @_;
1419 1490
1491 $EXTACMD{$name} = $cb;
1492}
1493
1494sub register_exticmd($$) {
1495 my ($name, $cb) = @_;
1496
1420 $EXTICMD{$name} = $cb; 1497 $EXTICMD{$name} = $cb;
1498}
1499
1500sub register_async_exticmd($$) {
1501 my ($name, $cb) = @_;
1502
1503 $EXTIACMD{$name} = $cb;
1421} 1504}
1422 1505
1423use File::Glob (); 1506use File::Glob ();
1424 1507
1425cf::player->attach ( 1508cf::player->attach (
1439 my ($pl, $buf) = @_; 1522 my ($pl, $buf) = @_;
1440 1523
1441 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1524 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1442 1525
1443 if (ref $msg) { 1526 if (ref $msg) {
1444 my ($type, $reply, @payload) = 1527 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1445 "ARRAY" eq ref $msg
1446 ? @$msg
1447 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1448 1528
1449 my @reply;
1450
1451 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}) {
1452 @reply = $cb->($pl, @payload); 1542 @reply = $cb->($pl, @payload);
1543 }
1544
1545 $pl->ext_msg ("reply-$reply", @reply)
1546 if $reply;
1453 } 1547 }
1454
1455 $pl->ext_reply ($reply, @reply)
1456 if $reply;
1457 1548
1458 } else { 1549 } else {
1459 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1550 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1460 } 1551 }
1461 1552
1474 }; 1565 };
1475 1566
1476 $grp 1567 $grp
1477} 1568}
1478 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
1479sub load_extensions { 1581sub load_extensions {
1480 info "loading extensions..."; 1582 info "loading extensions...";
1583
1584 %EXT_CFG = ();
1481 1585
1482 cf::sync_job { 1586 cf::sync_job {
1483 my %todo; 1587 my %todo;
1484 1588
1485 for my $path (<$LIBDIR/*.ext>) { 1589 for my $path (<$LIBDIR/*.ext>) {
1528 unless exists $done{$_}; 1632 unless exists $done{$_};
1529 } 1633 }
1530 1634
1531 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n"; 1635 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1532 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
1533 my $active = eval $v->{source}; 1646 my $active = eval $source;
1534 1647
1535 if (length $@) { 1648 if (length $@) {
1536 error "$v->{path}: $@\n"; 1649 error "$v->{path}: $@\n";
1537 1650
1538 cf::cleanup "mandatory extension '$k' failed to load, exiting." 1651 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1825} 1938}
1826 1939
1827=item $protocol_xml = $player->expand_cfpod ($cfpod) 1940=item $protocol_xml = $player->expand_cfpod ($cfpod)
1828 1941
1829Expand deliantra pod fragments into protocol xml. 1942Expand deliantra pod fragments into protocol xml.
1830
1831=item $player->ext_reply ($msgid, @msg)
1832
1833Sends an ext reply to the player.
1834
1835=cut
1836
1837sub ext_reply($$@) {
1838 my ($self, $id, @msg) = @_;
1839
1840 $self->ns->ext_reply ($id, @msg)
1841}
1842 1943
1843=item $player->ext_msg ($type, @msg) 1944=item $player->ext_msg ($type, @msg)
1844 1945
1845Sends an ext event to the client. 1946Sends an ext event to the client.
1846 1947
2069 $self->{load_path} = $path; 2170 $self->{load_path} = $path;
2070 2171
2071 1 2172 1
2072} 2173}
2073 2174
2175# used to laod the header of an original map
2074sub load_header_orig { 2176sub load_header_orig {
2075 my ($self) = @_; 2177 my ($self) = @_;
2076 2178
2077 $self->load_header_from ($self->load_path) 2179 $self->load_header_from ($self->load_path)
2078} 2180}
2079 2181
2182# used to laod the header of an instantiated map
2080sub load_header_temp { 2183sub load_header_temp {
2081 my ($self) = @_; 2184 my ($self) = @_;
2082 2185
2083 $self->load_header_from ($self->save_path) 2186 $self->load_header_from ($self->save_path)
2084} 2187}
2085 2188
2189# called after loading the header from an instantiated map
2086sub prepare_temp { 2190sub prepare_temp {
2087 my ($self) = @_; 2191 my ($self) = @_;
2088 2192
2089 $self->last_access ((delete $self->{last_access}) 2193 $self->last_access ((delete $self->{last_access})
2090 || $cf::RUNTIME); #d# 2194 || $cf::RUNTIME); #d#
2091 # safety 2195 # safety
2092 $self->{instantiate_time} = $cf::RUNTIME 2196 $self->{instantiate_time} = $cf::RUNTIME
2093 if $self->{instantiate_time} > $cf::RUNTIME; 2197 if $self->{instantiate_time} > $cf::RUNTIME;
2094} 2198}
2095 2199
2200# called after loading the header from an original map
2096sub prepare_orig { 2201sub prepare_orig {
2097 my ($self) = @_; 2202 my ($self) = @_;
2098 2203
2099 $self->{load_original} = 1; 2204 $self->{load_original} = 1;
2100 $self->{instantiate_time} = $cf::RUNTIME; 2205 $self->{instantiate_time} = $cf::RUNTIME;
2126sub find { 2231sub find {
2127 my ($path, $origin) = @_; 2232 my ($path, $origin) = @_;
2128 2233
2129 cf::cede_to_tick; 2234 cf::cede_to_tick;
2130 2235
2131 $path = normalise $path, $origin && $origin->path; 2236 $path = normalise $path, $origin;
2132 2237
2133 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2238 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2134 my $guard2 = cf::lock_acquire "map_find:$path"; 2239 my $guard2 = cf::lock_acquire "map_find:$path";
2135 2240
2136 $cf::MAP{$path} || do { 2241 $cf::MAP{$path} || do {
2167 2272
2168 { 2273 {
2169 my $guard = cf::lock_acquire "map_data:$path"; 2274 my $guard = cf::lock_acquire "map_data:$path";
2170 2275
2171 return unless $self->valid; 2276 return unless $self->valid;
2172 return unless $self->in_memory == cf::MAP_SWAPPED; 2277 return unless $self->state == cf::MAP_SWAPPED;
2173
2174 $self->in_memory (cf::MAP_LOADING);
2175 2278
2176 $self->alloc; 2279 $self->alloc;
2177 2280
2178 $self->pre_load; 2281 $self->pre_load;
2179 cf::cede_to_tick; 2282 cf::cede_to_tick;
2180 2283
2284 if (exists $self->{load_path}) {
2181 my $f = new_from_file cf::object::thawer $self->{load_path}; 2285 my $f = new_from_file cf::object::thawer $self->{load_path};
2182 $f->skip_block; 2286 $f->skip_block;
2183 $self->_load_objects ($f) 2287 $self->_load_objects ($f)
2184 or return; 2288 or return;
2185 2289
2186 $self->post_load_original 2290 $self->post_load_original
2187 if delete $self->{load_original}; 2291 if delete $self->{load_original};
2188 2292
2189 if (my $uniq = $self->uniq_path) { 2293 if (my $uniq = $self->uniq_path) {
2190 utf8::encode $uniq; 2294 utf8::encode $uniq;
2191 unless (aio_stat $uniq) { 2295 unless (aio_stat $uniq) {
2192 if (my $f = new_from_file cf::object::thawer $uniq) { 2296 if (my $f = new_from_file cf::object::thawer $uniq) {
2193 $self->clear_unique_items; 2297 $self->clear_unique_items;
2194 $self->_load_objects ($f); 2298 $self->_load_objects ($f);
2195 $f->resolve_delayed_derefs; 2299 $f->resolve_delayed_derefs;
2300 }
2196 } 2301 }
2197 } 2302 }
2198 }
2199 2303
2200 $f->resolve_delayed_derefs; 2304 $f->resolve_delayed_derefs;
2305 } else {
2306 $self->post_load_original
2307 if delete $self->{load_original};
2308 }
2309
2310 $self->state (cf::MAP_INACTIVE);
2201 2311
2202 cf::cede_to_tick; 2312 cf::cede_to_tick;
2203 # now do the right thing for maps 2313 # now do the right thing for maps
2204 $self->link_multipart_objects; 2314 $self->link_multipart_objects;
2205 $self->difficulty ($self->estimate_difficulty) 2315 $self->difficulty ($self->estimate_difficulty)
2209 unless ($self->{deny_activate}) { 2319 unless ($self->{deny_activate}) {
2210 $self->decay_objects; 2320 $self->decay_objects;
2211 $self->fix_auto_apply; 2321 $self->fix_auto_apply;
2212 $self->update_buttons; 2322 $self->update_buttons;
2213 cf::cede_to_tick; 2323 cf::cede_to_tick;
2214 $self->activate; 2324 #$self->activate; # no longer activate maps automatically
2215 } 2325 }
2216 2326
2217 $self->{last_save} = $cf::RUNTIME; 2327 $self->{last_save} = $cf::RUNTIME;
2218 $self->last_access ($cf::RUNTIME); 2328 $self->last_access ($cf::RUNTIME);
2219
2220 $self->in_memory (cf::MAP_ACTIVE);
2221 } 2329 }
2222 2330
2223 $self->post_load; 2331 $self->post_load;
2224 2332
2225 1 2333 1
2238# if $self->per_party; 2346# if $self->per_party;
2239 2347
2240 $self 2348 $self
2241} 2349}
2242 2350
2243# find and load all maps in the 3x3 area around a map
2244sub load_neighbours {
2245 my ($map) = @_;
2246
2247 my @neigh; # diagonal neighbours
2248
2249 for (0 .. 3) {
2250 my $neigh = $map->tile_path ($_)
2251 or next;
2252 $neigh = find $neigh, $map
2253 or next;
2254 $neigh->load;
2255
2256 # now find the diagonal neighbours
2257 push @neigh,
2258 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2259 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2260 }
2261
2262 for (grep defined $_->[0], @neigh) {
2263 my ($path, $origin) = @$_;
2264 my $neigh = find $path, $origin
2265 or next;
2266 $neigh->load;
2267 }
2268}
2269
2270sub find_sync { 2351sub find_sync {
2271 my ($path, $origin) = @_; 2352 my ($path, $origin) = @_;
2272 2353
2354 # it's a bug to call this from the main context
2273 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync" 2355 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2274 if $Coro::current == $Coro::main; 2356 if $Coro::current == $Coro::main;
2275 2357
2276 find $path, $origin 2358 find $path, $origin
2277} 2359}
2278 2360
2279sub do_load_sync { 2361sub do_load_sync {
2280 my ($map) = @_; 2362 my ($map) = @_;
2281 2363
2364 # it's a bug to call this from the main context
2282 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync" 2365 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2283 if $Coro::current == $Coro::main; 2366 if $Coro::current == $Coro::main;
2284 2367
2285 $map->load; 2368 $map->load;
2286} 2369}
2289our $MAP_PREFETCHER = undef; 2372our $MAP_PREFETCHER = undef;
2290 2373
2291sub find_async { 2374sub find_async {
2292 my ($path, $origin, $load) = @_; 2375 my ($path, $origin, $load) = @_;
2293 2376
2294 $path = normalise $path, $origin && $origin->{path}; 2377 $path = normalise $path, $origin;
2295 2378
2296 if (my $map = $cf::MAP{$path}) { 2379 if (my $map = $cf::MAP{$path}) {
2297 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2380 return $map if !$load || $map->linkable;
2298 } 2381 }
2299 2382
2300 $MAP_PREFETCH{$path} |= $load; 2383 $MAP_PREFETCH{$path} |= $load;
2301 2384
2302 $MAP_PREFETCHER ||= cf::async { 2385 $MAP_PREFETCHER ||= cf::async {
2361sub swap_out { 2444sub swap_out {
2362 my ($self) = @_; 2445 my ($self) = @_;
2363 2446
2364 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2447 my $lock = cf::lock_acquire "map_data:$self->{path}";
2365 2448
2366 return if $self->in_memory != cf::MAP_ACTIVE; 2449 return if !$self->linkable;
2367 return if $self->{deny_save}; 2450 return if $self->{deny_save};
2368 return if $self->players; 2451 return if $self->players;
2369 2452
2370 # first deactivate the map and "unlink" it from the core 2453 # first deactivate the map and "unlink" it from the core
2371 $self->deactivate; 2454 $self->deactivate;
2372 $_->clear_links_to ($self) for values %cf::MAP; 2455 $_->clear_links_to ($self) for values %cf::MAP;
2373 $self->in_memory (cf::MAP_SWAPPED); 2456 $self->state (cf::MAP_SWAPPED);
2374 2457
2375 # then atomically save 2458 # then atomically save
2376 $self->_save; 2459 $self->_save;
2377 2460
2378 # then free the map 2461 # then free the map
2404 2487
2405 return if $self->players; 2488 return if $self->players;
2406 2489
2407 cf::trace "resetting map ", $self->path, "\n"; 2490 cf::trace "resetting map ", $self->path, "\n";
2408 2491
2409 $self->in_memory (cf::MAP_SWAPPED); 2492 $self->state (cf::MAP_SWAPPED);
2410 2493
2411 # need to save uniques path 2494 # need to save uniques path
2412 unless ($self->{deny_save}) { 2495 unless ($self->{deny_save}) {
2413 my $uniq = $self->uniq_path; utf8::encode $uniq; 2496 my $uniq = $self->uniq_path; utf8::encode $uniq;
2414 2497
2567 2650
2568Creates 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.
2569 2652
2570=item $ob = cf::object::deref ($refstring) 2653=item $ob = cf::object::deref ($refstring)
2571 2654
2572returns 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,
2573even if the object actually exists. May block. 2656even if the object actually exists. May block.
2574 2657
2575=cut 2658=cut
2576 2659
2577sub deref { 2660sub deref {
2744 # use -1 or undef as default coordinates, not 0, 0 2827 # use -1 or undef as default coordinates, not 0, 0
2745 ($x, $y) = ($map->enter_x, $map->enter_y) 2828 ($x, $y) = ($map->enter_x, $map->enter_y)
2746 if $x <= 0 && $y <= 0; 2829 if $x <= 0 && $y <= 0;
2747 2830
2748 $map->load; 2831 $map->load;
2749 $map->load_neighbours;
2750 2832
2751 return unless $self->contr->active; 2833 return unless $self->contr->active;
2752 2834
2753 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2835 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2754 if ($self->enter_map ($map, $x, $y)) { 2836 if ($self->enter_map ($map, $x, $y)) {
2810 ($path, $x, $y) = (undef, undef, undef); 2892 ($path, $x, $y) = (undef, undef, undef);
2811 } 2893 }
2812 } 2894 }
2813 2895
2814 my $map = eval { 2896 my $map = eval {
2815 my $map = defined $path ? cf::map::find $path : undef; 2897 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2816 2898
2817 if ($map) { 2899 if ($map) {
2818 $map = $map->customise_for ($self); 2900 $map = $map->customise_for ($self);
2819 $map = $check->($map, $x, $y, $self) if $check && $map; 2901 $map = $check->($map, $x, $y, $self) if $check && $map;
2820 } else { 2902 } else {
2910 $Coro::current->{desc} = "enter_exit"; 2992 $Coro::current->{desc} = "enter_exit";
2911 2993
2912 unless (eval { 2994 unless (eval {
2913 $self->deactivate_recursive; # just to be sure 2995 $self->deactivate_recursive; # just to be sure
2914 2996
2915 # random map handling
2916 {
2917 my $guard = cf::lock_acquire "exit_prepare:$exit";
2918
2919 prepare_random_map $exit
2920 if $exit->slaying eq "/!";
2921 }
2922
2923 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2997 my $map = cf::map::normalise $exit->slaying, $exit->map;
2924 my $x = $exit->stats->hp; 2998 my $x = $exit->stats->hp;
2925 my $y = $exit->stats->sp; 2999 my $y = $exit->stats->sp;
3000
3001 # special map handling
3002 my $slaying = $exit->slaying;
3003
3004 # special map handling
3005 if ($slaying eq "/!") {
3006 my $guard = cf::lock_acquire "exit_prepare:$exit";
3007
3008 prepare_random_map $exit
3009 if $exit->slaying eq "/!"; # need to re-check after getting the lock
3010
3011 $map = $exit->slaying;
3012
3013 } elsif ($slaying eq '!up') {
3014 $map = $exit->map->tile_path (cf::TILE_UP);
3015 $x = $exit->x;
3016 $y = $exit->y;
3017
3018 } elsif ($slaying eq '!down') {
3019 $map = $exit->map->tile_path (cf::TILE_DOWN);
3020 $x = $exit->x;
3021 $y = $exit->y;
3022 }
2926 3023
2927 $self->goto ($map, $x, $y); 3024 $self->goto ($map, $x, $y);
2928 3025
2929 # if exit is damned, update players death & WoR home-position 3026 # if exit is damned, update players death & WoR home-position
2930 $self->contr->savebed ($map, $x, $y) 3027 $self->contr->savebed ($map, $x, $y)
2945 3042
2946=head3 cf::client 3043=head3 cf::client
2947 3044
2948=over 4 3045=over 4
2949 3046
2950=item $client->send_drawinfo ($text, $flags)
2951
2952Sends a drawinfo packet to the client. Circumvents output buffering so
2953should not be used under normal circumstances.
2954
2955=cut
2956
2957sub cf::client::send_drawinfo {
2958 my ($self, $text, $flags) = @_;
2959
2960 utf8::encode $text;
2961 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2962}
2963
2964=item $client->send_big_packet ($pkt) 3047=item $client->send_big_packet ($pkt)
2965 3048
2966Like C<send_packet>, but tries to compress large packets, and fragments 3049Like C<send_packet>, but tries to compress large packets, and fragments
2967them as required. 3050them as required.
2968 3051
2986 $self->send_packet ($pkt); 3069 $self->send_packet ($pkt);
2987} 3070}
2988 3071
2989=item $client->send_msg ($channel, $msg, $color, [extra...]) 3072=item $client->send_msg ($channel, $msg, $color, [extra...])
2990 3073
2991Send a drawinfo or msg packet to the client, formatting the msg for the 3074Send a msg packet to the client, formatting the msg for the client if
2992client if neccessary. C<$type> should be a string identifying the type of 3075necessary. C<$type> should be a string identifying the type of the
2993the message, with C<log> being the default. If C<$color> is negative, suppress 3076message, with C<log> being the default. If C<$color> is negative, suppress
2994the message unless the client supports the msg packet. 3077the message unless the client supports the msg packet.
2995 3078
2996=cut 3079=cut
2997 3080
2998# non-persistent channels (usually the info channel) 3081# non-persistent channels (usually the info channel)
3103 id => "death", 3186 id => "death",
3104 title => "Death", 3187 title => "Death",
3105 reply => undef, 3188 reply => undef,
3106 tooltip => "Reason for and more info about your most recent death", 3189 tooltip => "Reason for and more info about your most recent death",
3107 }, 3190 },
3191 "c/fatal" => {
3192 id => "fatal",
3193 title => "Fatal Error",
3194 reply => undef,
3195 tooltip => "Reason for the server disconnect",
3196 },
3108 "c/say" => $SAY_CHANNEL, 3197 "c/say" => $SAY_CHANNEL,
3109 "c/chat" => $CHAT_CHANNEL, 3198 "c/chat" => $CHAT_CHANNEL,
3110); 3199);
3111 3200
3112sub cf::client::send_msg { 3201sub cf::client::send_msg {
3155=cut 3244=cut
3156 3245
3157sub cf::client::ext_msg($$@) { 3246sub cf::client::ext_msg($$@) {
3158 my ($self, $type, @msg) = @_; 3247 my ($self, $type, @msg) = @_;
3159 3248
3160 if ($self->extcmd == 2) {
3161 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3249 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3162 } elsif ($self->extcmd == 1) { # TODO: remove
3163 push @msg, msgtype => "event_$type";
3164 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3165 }
3166}
3167
3168=item $client->ext_reply ($msgid, @msg)
3169
3170Sends an ext reply to the client.
3171
3172=cut
3173
3174sub cf::client::ext_reply($$@) {
3175 my ($self, $id, @msg) = @_;
3176
3177 if ($self->extcmd == 2) {
3178 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3179 } elsif ($self->extcmd == 1) {
3180 #TODO: version 1, remove
3181 unshift @msg, msgtype => "reply", msgid => $id;
3182 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3183 }
3184} 3250}
3185 3251
3186=item $success = $client->query ($flags, "text", \&cb) 3252=item $success = $client->query ($flags, "text", \&cb)
3187 3253
3188Queues a query to the client, calling the given callback with 3254Queues a query to the client, calling the given callback with
3208 3274
3209 $self->send_packet ($self->{query_queue}[0][0]) 3275 $self->send_packet ($self->{query_queue}[0][0])
3210 if @{ $self->{query_queue} } == 1; 3276 if @{ $self->{query_queue} } == 1;
3211 3277
3212 1 3278 1
3279}
3280
3281=item $client->update_command_faces
3282
3283=cut
3284
3285our %COMMAND_FACE;
3286
3287sub cf::client::update_command_faces {
3288 my ($self) = @_;
3289
3290 my @faces = grep $_,
3291 $COMMAND_FACE{preferred},
3292 $COMMAND_FACE{standard},
3293 $COMMAND_FACE{skill},
3294 $self->pl->ob->flag (cf::FLAG_WIZ) ? $COMMAND_FACE{dm} : (),
3295 $COMMAND_FACE{emote},
3296 ;
3297
3298 $self->send_face ($_)
3299 for @faces;
3300 $self->flush_fx;
3301
3302 $self->ext_msg (command_list => @faces);
3303}
3304
3305=item cf::client::set_command_face $type, $commands
3306
3307=cut
3308
3309sub cf::client::set_command_face {
3310 my ($type, $list) = @_;
3311
3312 my $idx = &cf::face::set ( #d# ugly forward reference
3313 "command_list/$type" => cf::FT_RSRC,
3314 JSON::XS->new->utf8->encode ([ sort @$list ])
3315 );
3316
3317 $COMMAND_FACE{$type} = $idx;
3213} 3318}
3214 3319
3215cf::client->attach ( 3320cf::client->attach (
3216 on_connect => sub { 3321 on_connect => sub {
3217 my ($ns) = @_; 3322 my ($ns) = @_;
3243 my ($ns, $buf) = @_; 3348 my ($ns, $buf) = @_;
3244 3349
3245 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3350 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3246 3351
3247 if (ref $msg) { 3352 if (ref $msg) {
3248 my ($type, $reply, @payload) = 3353 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3249 "ARRAY" eq ref $msg
3250 ? @$msg
3251 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3252 3354
3253 my @reply;
3254
3255 if (my $cb = $EXTICMD{$type}) { 3355 if (my $cb = $EXTIACMD{$type}) {
3356 $cb->(
3357 $ns,
3358 sub {
3359 $ns->ext_msg ("reply-$reply", @_)
3360 if $reply;
3361 },
3362 @payload
3363 );
3364 } else {
3365 my @reply;
3366
3367 if (my $cb = $EXTICMD{$type}) {
3256 @reply = $cb->($ns, @payload); 3368 @reply = $cb->($ns, @payload);
3369 }
3370
3371 $ns->ext_msg ("reply-$reply", @reply)
3372 if $reply;
3257 } 3373 }
3258
3259 $ns->ext_reply ($reply, @reply)
3260 if $reply;
3261
3262 } else { 3374 } else {
3263 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3375 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3264 } 3376 }
3265 3377
3266 cf::override; 3378 cf::override;
3434=cut 3546=cut
3435 3547
3436############################################################################# 3548#############################################################################
3437# the server's init and main functions 3549# the server's init and main functions
3438 3550
3551{
3552 package cf::face;
3553
3554 our %HASH; # hash => idx
3555 our @DATA; # dynamically-created facedata, only faceste 0 used
3556 our @FOFS; # file offset, if > 0
3557 our @SIZE; # size of face, in octets
3558 our @META; # meta hash of face, if any
3559 our $DATAFH; # facedata filehandle
3560
3561 # internal api, not finalised
3562 sub set {
3563 my ($name, $type, $data) = @_;
3564
3565 my $idx = cf::face::find $name;
3566
3567 if ($idx) {
3568 delete $HASH{cf::face::get_csum $idx};
3569 } else {
3570 $idx = cf::face::alloc $name;
3571 }
3572
3573 my $hash = cf::face::mangle_csum Digest::MD5::md5 $data;
3574
3575 cf::face::set_type $idx, $type;
3576 cf::face::set_csum $idx, 0, $hash;
3577
3578 # we need to destroy the SV itself, not just modify it, as a running ix
3579 # might hold a reference to it: "delete" achieves that.
3580 delete $FOFS[0][$idx];
3581 delete $DATA[0][$idx];
3582 $DATA[0][$idx] = $data;
3583 $SIZE[0][$idx] = length $data;
3584 delete $META[$idx];
3585 $HASH{$hash} = $idx;#d#
3586
3587 $idx
3588 }
3589
3590 sub _get_data($$$) {
3591 my ($idx, $set, $cb) = @_;
3592
3593 if (defined $DATA[$set][$idx]) {
3594 $cb->($DATA[$set][$idx]);
3595 } elsif (my $fofs = $FOFS[$set][$idx]) {
3596 my $size = $SIZE[$set][$idx];
3597 my $buf;
3598 IO::AIO::aio_read $DATAFH, $fofs, $size, $buf, 0, sub {
3599 if ($_[0] == $size) {
3600 #cf::debug "read face $idx, $size from $fofs as ", length $buf;#d#
3601 $cb->($buf);
3602 } else {
3603 cf::error "INTERNAL ERROR: unable to read facedata for face $idx#$set ($size, $fofs), ignoring request.";
3604 }
3605 };
3606 } else {
3607 cf::error "requested facedata for unknown face $idx#$set, ignoring.";
3608 }
3609 }
3610
3611 # rather ineffient
3612 sub cf::face::get_data($;$) {
3613 my ($idx, $set) = @_;
3614
3615 _get_data $idx, $set, Coro::rouse_cb;
3616 Coro::rouse_wait
3617 }
3618
3619 sub cf::face::ix {
3620 my ($ns, $set, $idx, $pri) = @_;
3621
3622 _get_data $idx, $set, sub {
3623 $ns->ix_send ($idx, $pri, $_[0]);
3624 };
3625 }
3626}
3627
3439sub load_facedata($) { 3628sub load_facedata($) {
3440 my ($path) = @_; 3629 my ($path) = @_;
3441 3630
3442 # HACK to clear player env face cache, we need some signal framework
3443 # for this (global event?)
3444 %ext::player_env::MUSIC_FACE_CACHE = ();
3445
3446 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3631 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3447 3632
3448 trace "loading facedata from $path\n"; 3633 trace "loading facedata from $path\n";
3449 3634
3450 my $facedata = decode_storable load_file $path; 3635 my $facedata = decode_storable load_file "$path/faceinfo";
3451 3636
3452 $facedata->{version} == 2 3637 $facedata->{version} == 2
3453 or cf::cleanup "$path: version mismatch, cannot proceed."; 3638 or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";
3454 3639
3455 # patch in the exptable 3640 my $fh = aio_open "$DATADIR/facedata", IO::AIO::O_RDONLY, 0
3456 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]); 3641 or cf::cleanup "$path/facedata: $!, cannot proceed.";
3457 $facedata->{resource}{"res/exp_table"} = { 3642
3458 type => FT_RSRC, 3643 get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
3459 data => $exp_table, 3644
3460 hash => (Digest::MD5::md5 $exp_table), 3645 # BEGIN ATOMIC
3461 }; 3646 # from here on, everything must be atomic - no thread switch allowed
3462 cf::cede_to_tick; 3647 my $t1 = EV::time;
3463 3648
3464 { 3649 {
3465 my $faces = $facedata->{faceinfo}; 3650 my $faces = $facedata->{faceinfo};
3466 3651
3467 while (my ($face, $info) = each %$faces) { 3652 for my $face (sort keys %$faces) {
3653 my $info = $faces->{$face};
3468 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3654 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3469 3655
3470 cf::face::set_visibility $idx, $info->{visibility}; 3656 cf::face::set_visibility $idx, $info->{visibility};
3471 cf::face::set_magicmap $idx, $info->{magicmap}; 3657 cf::face::set_magicmap $idx, $info->{magicmap};
3472 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3658 cf::face::set_csum $idx, 0, $info->{hash64}; $cf::face::SIZE[0][$idx] = $info->{size64}; $cf::face::FOFS[0][$idx] = $info->{fofs64};
3473 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3659 cf::face::set_csum $idx, 1, $info->{hash32}; $cf::face::SIZE[1][$idx] = $info->{size32}; $cf::face::FOFS[1][$idx] = $info->{fofs32};
3474 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ; 3660 cf::face::set_csum $idx, 2, $info->{glyph}; $cf::face::DATA[2][$idx] = $info->{glyph};
3475 3661 $cf::face::HASH{$info->{hash64}} = $idx;
3476 cf::cede_to_tick; 3662 delete $cf::face::META[$idx];
3477 } 3663 }
3478 3664
3479 while (my ($face, $info) = each %$faces) { 3665 while (my ($face, $info) = each %$faces) {
3480 next unless $info->{smooth}; 3666 next unless $info->{smooth};
3481 3667
3486 cf::face::set_smooth $idx, $smooth; 3672 cf::face::set_smooth $idx, $smooth;
3487 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3673 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3488 } else { 3674 } else {
3489 error "smooth face '$info->{smooth}' not found for face '$face'"; 3675 error "smooth face '$info->{smooth}' not found for face '$face'";
3490 } 3676 }
3491
3492 cf::cede_to_tick;
3493 } 3677 }
3494 } 3678 }
3495 3679
3496 { 3680 {
3497 my $anims = $facedata->{animinfo}; 3681 my $anims = $facedata->{animinfo};
3498 3682
3499 while (my ($anim, $info) = each %$anims) { 3683 while (my ($anim, $info) = each %$anims) {
3500 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3684 cf::anim::set $anim, $info->{frames}, $info->{facings};
3501 cf::cede_to_tick;
3502 } 3685 }
3503 3686
3504 cf::anim::invalidate_all; # d'oh 3687 cf::anim::invalidate_all; # d'oh
3505 } 3688 }
3506 3689
3507 { 3690 {
3508 my $res = $facedata->{resource}; 3691 my $res = $facedata->{resource};
3509 3692
3510 while (my ($name, $info) = each %$res) { 3693 while (my ($name, $info) = each %$res) {
3511 if (defined $info->{type}) { 3694 if (defined (my $type = $info->{type})) {
3695 # TODO: different hash - must free and use new index, or cache ixface data queue
3512 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3696 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3513 3697
3514 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3515 cf::face::set_type $idx, $info->{type}; 3698 cf::face::set_type $idx, $type;
3699 cf::face::set_csum $idx, 0, $info->{hash};
3700 $cf::face::SIZE[0][$idx] = $info->{size};
3701 $cf::face::FOFS[0][$idx] = $info->{fofs};
3702 $cf::face::META[$idx] = $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3703 $cf::face::HASH{$info->{hash}} = $idx;
3516 } else { 3704 } else {
3517 $RESOURCE{$name} = $info; # unused 3705# $RESOURCE{$name} = $info; # unused
3518 } 3706 }
3519
3520 cf::cede_to_tick;
3521 } 3707 }
3522 } 3708 }
3709
3710 ($fh, $cf::face::DATAFH) = ($cf::face::DATAFH, $fh);
3711
3712 # HACK to clear player env face cache, we need some signal framework
3713 # for this (global event?)
3714 %ext::player_env::MUSIC_FACE_CACHE = ();
3715
3716 # END ATOMIC
3717
3718 cf::debug "facedata atomic update time ", EV::time - $t1;
3523 3719
3524 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3720 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3721
3722 aio_close $fh if $fh; # close old facedata
3525 3723
3526 1 3724 1
3527} 3725}
3528 3726
3529register_exticmd fx_want => sub { 3727register_exticmd fx_want => sub {
3540 my $status = load_resource_file_ $_[0]; 3738 my $status = load_resource_file_ $_[0];
3541 get_slot 0.1, 100; 3739 get_slot 0.1, 100;
3542 cf::arch::commit_load; 3740 cf::arch::commit_load;
3543 3741
3544 $status 3742 $status
3743}
3744
3745sub reload_exp_table {
3746 _reload_exp_table;
3747
3748 cf::face::set
3749 "res/exp_table" => FT_RSRC,
3750 JSON::XS->new->utf8->canonical->encode (
3751 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3752 );
3753}
3754
3755sub reload_materials {
3756 _reload_materials;
3545} 3757}
3546 3758
3547sub reload_regions { 3759sub reload_regions {
3548 # HACK to clear player env face cache, we need some signal framework 3760 # HACK to clear player env face cache, we need some signal framework
3549 # for this (global event?) 3761 # for this (global event?)
3557 if exists $_->{match}; 3769 if exists $_->{match};
3558 } 3770 }
3559} 3771}
3560 3772
3561sub reload_facedata { 3773sub reload_facedata {
3562 load_facedata "$DATADIR/facedata" 3774 load_facedata $DATADIR
3563 or die "unable to load facedata\n"; 3775 or die "unable to load facedata\n";
3564} 3776}
3565 3777
3566sub reload_archetypes { 3778sub reload_archetypes {
3567 load_resource_file "$DATADIR/archetypes" 3779 load_resource_file "$DATADIR/archetypes"
3568 or die "unable to load archetypes\n"; 3780 or die "unable to load archetypes\n";
3781
3782 cf::face::set
3783 "res/skill_info" => FT_RSRC,
3784 JSON::XS->new->utf8->canonical->encode (
3785 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3786 );
3787
3788 cf::face::set
3789 "res/spell_paths" => FT_RSRC,
3790 JSON::XS->new->utf8->canonical->encode (
3791 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3792 );
3793
3794 # command completion
3795 my @commands;
3796
3797 for (0..cf::arch::skillvec_size - 1) {
3798 my $skill = cf::arch::skillvec $_;
3799 my $name = $skill->name;
3800 my $flags = cf::skill_flags $skill->subtype;
3801
3802 push @commands, "ready_skill $name" if $flags & (SF_COMBAT | SF_RANGED | SF_GRACE);
3803 push @commands, "use_skill $name" if $flags & (SF_USE | SF_AUTARK | SF_GRACE);
3804 }
3805
3806 cf::client::set_command_face skill => \@commands;
3569} 3807}
3570 3808
3571sub reload_treasures { 3809sub reload_treasures {
3572 load_resource_file "$DATADIR/treasures" 3810 load_resource_file "$DATADIR/treasures"
3573 or die "unable to load treasurelists\n"; 3811 or die "unable to load treasurelists\n";
3594} 3832}
3595 3833
3596sub reload_resources { 3834sub reload_resources {
3597 trace "reloading resource files...\n"; 3835 trace "reloading resource files...\n";
3598 3836
3599 reload_exp_table;
3600 reload_materials; 3837 reload_materials;
3601 reload_facedata; 3838 reload_facedata;
3839 reload_exp_table;
3602 reload_sound; 3840 reload_sound;
3603 reload_archetypes; 3841 reload_archetypes;
3604 reload_regions; 3842 reload_regions;
3605 reload_treasures; 3843 reload_treasures;
3606 3844
3658 3896
3659sub main { 3897sub main {
3660 cf::init_globals; # initialise logging 3898 cf::init_globals; # initialise logging
3661 3899
3662 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3900 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3663 LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3901 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3664 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3902 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3665 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3903 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3666 3904
3667 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3905 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3668 3906
3669 # we must not ever block the main coroutine 3907 # we must not ever block the main coroutine
3670 local $Coro::idle = sub { 3908 $Coro::idle = sub {
3671 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3909 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3672 (async { 3910 (async {
3673 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3911 $Coro::current->{desc} = "IDLE BUG HANDLER";
3674 EV::loop EV::LOOP_ONESHOT; 3912 EV::loop EV::LOOP_ONESHOT;
3675 })->prio (Coro::PRIO_MAX); 3913 })->prio (Coro::PRIO_MAX);
3678 evthread_start IO::AIO::poll_fileno; 3916 evthread_start IO::AIO::poll_fileno;
3679 3917
3680 cf::sync_job { 3918 cf::sync_job {
3681 cf::incloader::init (); 3919 cf::incloader::init ();
3682 3920
3921 db_init;
3922
3683 cf::init_anim; 3923 cf::init_anim;
3684 cf::init_attackmess; 3924 cf::init_attackmess;
3685 cf::init_dynamic; 3925 cf::init_dynamic;
3686 3926
3687 cf::load_settings; 3927 cf::load_settings;
3688 3928
3689 reload_resources; 3929 reload_resources;
3690 reload_config; 3930 reload_config;
3691 db_init;
3692 3931
3693 cf::init_uuid; 3932 cf::init_uuid;
3694 cf::init_signals; 3933 cf::init_signals;
3695 cf::init_skills; 3934 cf::init_skills;
3696 3935
3710 }; 3949 };
3711 3950
3712 cf::object::thawer::errors_are_fatal 0; 3951 cf::object::thawer::errors_are_fatal 0;
3713 info "parse errors in files are no longer fatal from this point on.\n"; 3952 info "parse errors in files are no longer fatal from this point on.\n";
3714 3953
3715 my $free_main; $free_main = EV::idle sub { 3954 AE::postpone {
3716 undef $free_main;
3717 undef &main; # free gobs of memory :) 3955 undef &main; # free gobs of memory :)
3718 }; 3956 };
3719 3957
3720 goto &main_loop; 3958 goto &main_loop;
3721} 3959}
3878 4116
3879 cf::write_runtime_sync; # external watchdog should not bark 4117 cf::write_runtime_sync; # external watchdog should not bark
3880 4118
3881 trace "emergency_perl_save: flushing outstanding aio requests"; 4119 trace "emergency_perl_save: flushing outstanding aio requests";
3882 while (IO::AIO::nreqs || BDB::nreqs) { 4120 while (IO::AIO::nreqs || BDB::nreqs) {
3883 Coro::EV::timer_once 0.01; # let the sync_job do it's thing 4121 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
3884 } 4122 }
3885 4123
3886 cf::write_runtime_sync; # external watchdog should not bark 4124 cf::write_runtime_sync; # external watchdog should not bark
3887 }; 4125 };
3888 4126
4069 4307
4070############################################################################# 4308#############################################################################
4071 4309
4072my $bug_warning = 0; 4310my $bug_warning = 0;
4073 4311
4074our @WAIT_FOR_TICK;
4075our @WAIT_FOR_TICK_BEGIN;
4076
4077sub wait_for_tick() { 4312sub wait_for_tick() {
4078 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4313 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4079 4314
4080 my $signal = new Coro::Signal; 4315 $WAIT_FOR_TICK->wait;
4081 push @WAIT_FOR_TICK, $signal;
4082 $signal->wait;
4083} 4316}
4084 4317
4085sub wait_for_tick_begin() { 4318sub wait_for_tick_begin() {
4086 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4319 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4087 4320
4088 my $signal = new Coro::Signal; 4321 my $signal = new Coro::Signal;
4089 push @WAIT_FOR_TICK_BEGIN, $signal; 4322 push @WAIT_FOR_TICK_BEGIN, $signal;
4090 $signal->wait; 4323 $signal->wait;
4091} 4324}
4095 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4328 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4096 unless ++$bug_warning > 10; 4329 unless ++$bug_warning > 10;
4097 return; 4330 return;
4098 } 4331 }
4099 4332
4100 cf::server_tick; # one server iteration 4333 cf::one_tick; # one server iteration
4101 4334
4102 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d# 4335 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4103 4336
4104 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4337 if ($NOW >= $NEXT_RUNTIME_WRITE) {
4105 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4338 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
4111 } 4344 }
4112 4345
4113 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4346 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4114 $sig->send; 4347 $sig->send;
4115 } 4348 }
4116 while (my $sig = shift @WAIT_FOR_TICK) { 4349 $WAIT_FOR_TICK->broadcast;
4117 $sig->send;
4118 }
4119 4350
4120 $LOAD = ($NOW - $TICK_START) / $TICK; 4351 $LOAD = ($NOW - $TICK_START) / $TICK;
4121 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4352 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4122 4353
4123 if (0) { 4354 if (0) {
4129 } 4360 }
4130} 4361}
4131 4362
4132{ 4363{
4133 # configure BDB 4364 # configure BDB
4365 info "initialising database";
4134 4366
4135 BDB::min_parallel 16; 4367 BDB::min_parallel 16;
4136 BDB::max_poll_reqs $TICK * 0.1; 4368 BDB::max_poll_reqs $TICK * 0.1;
4137 $AnyEvent::BDB::WATCHER->priority (1); 4369 #$AnyEvent::BDB::WATCHER->priority (1);
4138 4370
4139 unless ($DB_ENV) { 4371 unless ($DB_ENV) {
4140 $DB_ENV = BDB::db_env_create; 4372 $DB_ENV = BDB::db_env_create;
4141 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4373 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4142 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4374 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4167 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4399 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4168 }; 4400 };
4169 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4401 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4170 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4402 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4171 }; 4403 };
4404
4405 info "database initialised";
4172} 4406}
4173 4407
4174{ 4408{
4175 # configure IO::AIO 4409 # configure IO::AIO
4176 4410
4411 info "initialising aio";
4177 IO::AIO::min_parallel 8; 4412 IO::AIO::min_parallel 8;
4178 IO::AIO::max_poll_time $TICK * 0.1; 4413 IO::AIO::max_poll_time $TICK * 0.1;
4179 undef $AnyEvent::AIO::WATCHER; 4414 undef $AnyEvent::AIO::WATCHER;
4415 info "aio initialised";
4180} 4416}
4181 4417
4182our $_log_backtrace; 4418our $_log_backtrace;
4183our $_log_backtrace_last; 4419our $_log_backtrace_last;
4184 4420

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines