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.565 by root, Sat Apr 30 05:41:17 2011 UTC vs.
Revision 1.612 by root, Wed Nov 21 12:47:09 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; 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
… …
1954 # {... are special paths that are not being touched 2055 # {... are special paths that are not being touched
1955 # ?xxx/... are special absolute paths 2056 # ?xxx/... are special absolute paths
1956 # ?random/... random maps 2057 # ?random/... random maps
1957 # /... normal maps 2058 # /... normal maps
1958 # ~user/... per-player map of a specific user 2059 # ~user/... per-player map of a specific user
1959 # !up !down for quad maps, or other maps with up/down layers
1960 2060
1961 $path =~ s/$PATH_SEP/\//go; 2061 $path =~ s/$PATH_SEP/\//go;
1962 2062
1963 # treat it as relative path if it starts with 2063 # treat it as relative path if it starts with
1964 # something that looks reasonable 2064 # something that looks reasonable
1965 if ($path =~ m{^(?:\./|\.\./|\w)}) { 2065 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1966 $base or Carp::carp "normalise called with relative path and no base: '$path'"; 2066 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1967 2067
1968 $base =~ s{[^/]+/?$}{}; 2068 $base =~ s{[^/]+/?$}{};
1969 $path = "$base/$path"; 2069 $path = "$base/$path";
1970
1971 } elsif ($path eq '!up') {
1972 $base && ref $base
1973 or Carp::carp "normalise called with relative tile path and no base: '$path'";
1974
1975 my $uppth = $base->tile_path (cf::TILE_UP);
1976 $path = $uppth if $uppth;
1977
1978 } elsif ($path eq '!down') {
1979 $base && ref $base
1980 or Carp::carp "normalise called with relative tile path and no base: '$path'";
1981
1982 my $dpth = $base->tile_path (cf::TILE_DOWN);
1983 $path = $dpth if $dpth;
1984 } 2070 }
1985 2071
1986 for ($path) { 2072 for ($path) {
1987 redo if s{/\.?/}{/}; 2073 redo if s{/\.?/}{/};
1988 redo if s{/[^/]+/\.\./}{/}; 2074 redo if s{/[^/]+/\.\./}{/};
… …
2084 $self->{load_path} = $path; 2170 $self->{load_path} = $path;
2085 2171
2086 1 2172 1
2087} 2173}
2088 2174
2175# used to laod the header of an original map
2089sub load_header_orig { 2176sub load_header_orig {
2090 my ($self) = @_; 2177 my ($self) = @_;
2091 2178
2092 $self->load_header_from ($self->load_path) 2179 $self->load_header_from ($self->load_path)
2093} 2180}
2094 2181
2182# used to laod the header of an instantiated map
2095sub load_header_temp { 2183sub load_header_temp {
2096 my ($self) = @_; 2184 my ($self) = @_;
2097 2185
2098 $self->load_header_from ($self->save_path) 2186 $self->load_header_from ($self->save_path)
2099} 2187}
2100 2188
2189# called after loading the header from an instantiated map
2101sub prepare_temp { 2190sub prepare_temp {
2102 my ($self) = @_; 2191 my ($self) = @_;
2103 2192
2104 $self->last_access ((delete $self->{last_access}) 2193 $self->last_access ((delete $self->{last_access})
2105 || $cf::RUNTIME); #d# 2194 || $cf::RUNTIME); #d#
2106 # safety 2195 # safety
2107 $self->{instantiate_time} = $cf::RUNTIME 2196 $self->{instantiate_time} = $cf::RUNTIME
2108 if $self->{instantiate_time} > $cf::RUNTIME; 2197 if $self->{instantiate_time} > $cf::RUNTIME;
2109} 2198}
2110 2199
2200# called after loading the header from an original map
2111sub prepare_orig { 2201sub prepare_orig {
2112 my ($self) = @_; 2202 my ($self) = @_;
2113 2203
2114 $self->{load_original} = 1; 2204 $self->{load_original} = 1;
2115 $self->{instantiate_time} = $cf::RUNTIME; 2205 $self->{instantiate_time} = $cf::RUNTIME;
… …
2182 2272
2183 { 2273 {
2184 my $guard = cf::lock_acquire "map_data:$path"; 2274 my $guard = cf::lock_acquire "map_data:$path";
2185 2275
2186 return unless $self->valid; 2276 return unless $self->valid;
2187 return unless $self->in_memory == cf::MAP_SWAPPED; 2277 return unless $self->state == cf::MAP_SWAPPED;
2188
2189 $self->in_memory (cf::MAP_LOADING);
2190 2278
2191 $self->alloc; 2279 $self->alloc;
2192 2280
2193 $self->pre_load; 2281 $self->pre_load;
2194 cf::cede_to_tick; 2282 cf::cede_to_tick;
… …
2212 } 2300 }
2213 } 2301 }
2214 } 2302 }
2215 2303
2216 $f->resolve_delayed_derefs; 2304 $f->resolve_delayed_derefs;
2305 } else {
2306 $self->post_load_original
2307 if delete $self->{load_original};
2217 } 2308 }
2309
2310 $self->state (cf::MAP_INACTIVE);
2218 2311
2219 cf::cede_to_tick; 2312 cf::cede_to_tick;
2220 # now do the right thing for maps 2313 # now do the right thing for maps
2221 $self->link_multipart_objects; 2314 $self->link_multipart_objects;
2222 $self->difficulty ($self->estimate_difficulty) 2315 $self->difficulty ($self->estimate_difficulty)
… …
2226 unless ($self->{deny_activate}) { 2319 unless ($self->{deny_activate}) {
2227 $self->decay_objects; 2320 $self->decay_objects;
2228 $self->fix_auto_apply; 2321 $self->fix_auto_apply;
2229 $self->update_buttons; 2322 $self->update_buttons;
2230 cf::cede_to_tick; 2323 cf::cede_to_tick;
2231 $self->activate; 2324 #$self->activate; # no longer activate maps automatically
2232 } 2325 }
2233 2326
2234 $self->{last_save} = $cf::RUNTIME; 2327 $self->{last_save} = $cf::RUNTIME;
2235 $self->last_access ($cf::RUNTIME); 2328 $self->last_access ($cf::RUNTIME);
2236
2237 $self->in_memory (cf::MAP_ACTIVE);
2238 } 2329 }
2239 2330
2240 $self->post_load; 2331 $self->post_load;
2241 2332
2242 1 2333 1
… …
2255# if $self->per_party; 2346# if $self->per_party;
2256 2347
2257 $self 2348 $self
2258} 2349}
2259 2350
2260# find and load all maps in the 3x3 area around a map
2261sub load_neighbours {
2262 my ($map) = @_;
2263
2264 my @neigh; # diagonal neighbours
2265
2266 for (0 .. 3) {
2267 my $neigh = $map->tile_path ($_)
2268 or next;
2269 $neigh = find $neigh, $map
2270 or next;
2271 $neigh->load;
2272
2273 # now find the diagonal neighbours
2274 push @neigh,
2275 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2276 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2277 }
2278
2279 for (grep defined $_->[0], @neigh) {
2280 my ($path, $origin) = @$_;
2281 my $neigh = find $path, $origin
2282 or next;
2283 $neigh->load;
2284 }
2285}
2286
2287sub find_sync { 2351sub find_sync {
2288 my ($path, $origin) = @_; 2352 my ($path, $origin) = @_;
2289 2353
2354 # it's a bug to call this from the main context
2290 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync" 2355 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2291 if $Coro::current == $Coro::main; 2356 if $Coro::current == $Coro::main;
2292 2357
2293 find $path, $origin 2358 find $path, $origin
2294} 2359}
2295 2360
2296sub do_load_sync { 2361sub do_load_sync {
2297 my ($map) = @_; 2362 my ($map) = @_;
2298 2363
2364 # it's a bug to call this from the main context
2299 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync" 2365 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2300 if $Coro::current == $Coro::main; 2366 if $Coro::current == $Coro::main;
2301 2367
2302 $map->load; 2368 $map->load;
2303} 2369}
… …
2309 my ($path, $origin, $load) = @_; 2375 my ($path, $origin, $load) = @_;
2310 2376
2311 $path = normalise $path, $origin; 2377 $path = normalise $path, $origin;
2312 2378
2313 if (my $map = $cf::MAP{$path}) { 2379 if (my $map = $cf::MAP{$path}) {
2314 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2380 return $map if !$load || $map->linkable;
2315 } 2381 }
2316 2382
2317 $MAP_PREFETCH{$path} |= $load; 2383 $MAP_PREFETCH{$path} |= $load;
2318 2384
2319 $MAP_PREFETCHER ||= cf::async { 2385 $MAP_PREFETCHER ||= cf::async {
… …
2378sub swap_out { 2444sub swap_out {
2379 my ($self) = @_; 2445 my ($self) = @_;
2380 2446
2381 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2447 my $lock = cf::lock_acquire "map_data:$self->{path}";
2382 2448
2383 return if $self->in_memory != cf::MAP_ACTIVE; 2449 return if !$self->linkable;
2384 return if $self->{deny_save}; 2450 return if $self->{deny_save};
2385 return if $self->players; 2451 return if $self->players;
2386 2452
2387 # first deactivate the map and "unlink" it from the core 2453 # first deactivate the map and "unlink" it from the core
2388 $self->deactivate; 2454 $self->deactivate;
2389 $_->clear_links_to ($self) for values %cf::MAP; 2455 $_->clear_links_to ($self) for values %cf::MAP;
2390 $self->in_memory (cf::MAP_SWAPPED); 2456 $self->state (cf::MAP_SWAPPED);
2391 2457
2392 # then atomically save 2458 # then atomically save
2393 $self->_save; 2459 $self->_save;
2394 2460
2395 # then free the map 2461 # then free the map
… …
2421 2487
2422 return if $self->players; 2488 return if $self->players;
2423 2489
2424 cf::trace "resetting map ", $self->path, "\n"; 2490 cf::trace "resetting map ", $self->path, "\n";
2425 2491
2426 $self->in_memory (cf::MAP_SWAPPED); 2492 $self->state (cf::MAP_SWAPPED);
2427 2493
2428 # need to save uniques path 2494 # need to save uniques path
2429 unless ($self->{deny_save}) { 2495 unless ($self->{deny_save}) {
2430 my $uniq = $self->uniq_path; utf8::encode $uniq; 2496 my $uniq = $self->uniq_path; utf8::encode $uniq;
2431 2497
… …
2584 2650
2585Creates 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.
2586 2652
2587=item $ob = cf::object::deref ($refstring) 2653=item $ob = cf::object::deref ($refstring)
2588 2654
2589returns 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,
2590even if the object actually exists. May block. 2656even if the object actually exists. May block.
2591 2657
2592=cut 2658=cut
2593 2659
2594sub deref { 2660sub deref {
… …
2761 # use -1 or undef as default coordinates, not 0, 0 2827 # use -1 or undef as default coordinates, not 0, 0
2762 ($x, $y) = ($map->enter_x, $map->enter_y) 2828 ($x, $y) = ($map->enter_x, $map->enter_y)
2763 if $x <= 0 && $y <= 0; 2829 if $x <= 0 && $y <= 0;
2764 2830
2765 $map->load; 2831 $map->load;
2766 $map->load_neighbours;
2767 2832
2768 return unless $self->contr->active; 2833 return unless $self->contr->active;
2769 2834
2770 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2835 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2771 if ($self->enter_map ($map, $x, $y)) { 2836 if ($self->enter_map ($map, $x, $y)) {
… …
2927 $Coro::current->{desc} = "enter_exit"; 2992 $Coro::current->{desc} = "enter_exit";
2928 2993
2929 unless (eval { 2994 unless (eval {
2930 $self->deactivate_recursive; # just to be sure 2995 $self->deactivate_recursive; # just to be sure
2931 2996
2932 # random map handling
2933 {
2934 my $guard = cf::lock_acquire "exit_prepare:$exit";
2935
2936 prepare_random_map $exit
2937 if $exit->slaying eq "/!";
2938 }
2939
2940 my $map = cf::map::normalise $exit->slaying, $exit->map; 2997 my $map = cf::map::normalise $exit->slaying, $exit->map;
2941 my $x = $exit->stats->hp; 2998 my $x = $exit->stats->hp;
2942 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 }
2943 3023
2944 $self->goto ($map, $x, $y); 3024 $self->goto ($map, $x, $y);
2945 3025
2946 # if exit is damned, update players death & WoR home-position 3026 # if exit is damned, update players death & WoR home-position
2947 $self->contr->savebed ($map, $x, $y) 3027 $self->contr->savebed ($map, $x, $y)
… …
2962 3042
2963=head3 cf::client 3043=head3 cf::client
2964 3044
2965=over 4 3045=over 4
2966 3046
2967=item $client->send_drawinfo ($text, $flags)
2968
2969Sends a drawinfo packet to the client. Circumvents output buffering so
2970should not be used under normal circumstances.
2971
2972=cut
2973
2974sub cf::client::send_drawinfo {
2975 my ($self, $text, $flags) = @_;
2976
2977 utf8::encode $text;
2978 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2979}
2980
2981=item $client->send_big_packet ($pkt) 3047=item $client->send_big_packet ($pkt)
2982 3048
2983Like C<send_packet>, but tries to compress large packets, and fragments 3049Like C<send_packet>, but tries to compress large packets, and fragments
2984them as required. 3050them as required.
2985 3051
… …
3003 $self->send_packet ($pkt); 3069 $self->send_packet ($pkt);
3004} 3070}
3005 3071
3006=item $client->send_msg ($channel, $msg, $color, [extra...]) 3072=item $client->send_msg ($channel, $msg, $color, [extra...])
3007 3073
3008Send 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
3009client if neccessary. C<$type> should be a string identifying the type of 3075necessary. C<$type> should be a string identifying the type of the
3010the 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
3011the message unless the client supports the msg packet. 3077the message unless the client supports the msg packet.
3012 3078
3013=cut 3079=cut
3014 3080
3015# non-persistent channels (usually the info channel) 3081# non-persistent channels (usually the info channel)
… …
3120 id => "death", 3186 id => "death",
3121 title => "Death", 3187 title => "Death",
3122 reply => undef, 3188 reply => undef,
3123 tooltip => "Reason for and more info about your most recent death", 3189 tooltip => "Reason for and more info about your most recent death",
3124 }, 3190 },
3191 "c/fatal" => {
3192 id => "fatal",
3193 title => "Fatal Error",
3194 reply => undef,
3195 tooltip => "Reason for the server disconnect",
3196 },
3125 "c/say" => $SAY_CHANNEL, 3197 "c/say" => $SAY_CHANNEL,
3126 "c/chat" => $CHAT_CHANNEL, 3198 "c/chat" => $CHAT_CHANNEL,
3127); 3199);
3128 3200
3129sub cf::client::send_msg { 3201sub cf::client::send_msg {
… …
3172=cut 3244=cut
3173 3245
3174sub cf::client::ext_msg($$@) { 3246sub cf::client::ext_msg($$@) {
3175 my ($self, $type, @msg) = @_; 3247 my ($self, $type, @msg) = @_;
3176 3248
3177 if ($self->extcmd == 2) {
3178 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3249 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3179 } elsif ($self->extcmd == 1) { # TODO: remove
3180 push @msg, msgtype => "event_$type";
3181 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3182 }
3183}
3184
3185=item $client->ext_reply ($msgid, @msg)
3186
3187Sends an ext reply to the client.
3188
3189=cut
3190
3191sub cf::client::ext_reply($$@) {
3192 my ($self, $id, @msg) = @_;
3193
3194 if ($self->extcmd == 2) {
3195 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3196 } elsif ($self->extcmd == 1) {
3197 #TODO: version 1, remove
3198 unshift @msg, msgtype => "reply", msgid => $id;
3199 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3200 }
3201} 3250}
3202 3251
3203=item $success = $client->query ($flags, "text", \&cb) 3252=item $success = $client->query ($flags, "text", \&cb)
3204 3253
3205Queues a query to the client, calling the given callback with 3254Queues a query to the client, calling the given callback with
… …
3225 3274
3226 $self->send_packet ($self->{query_queue}[0][0]) 3275 $self->send_packet ($self->{query_queue}[0][0])
3227 if @{ $self->{query_queue} } == 1; 3276 if @{ $self->{query_queue} } == 1;
3228 3277
3229 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{standard},
3292 $COMMAND_FACE{emote},
3293 $COMMAND_FACE{skill},
3294 $self->pl->ob->flag (cf::FLAG_WIZ) ? $COMMAND_FACE{dm} : (),
3295 ;
3296
3297 $self->send_face ($_)
3298 for @faces;
3299 $self->flush_fx;
3300
3301 $self->ext_msg (command_list => @faces);
3302}
3303
3304=item cf::client::set_command_face $type, $commands
3305
3306=cut
3307
3308sub cf::client::set_command_face {
3309 my ($type, $list) = @_;
3310
3311 my $idx = &cf::face::set ( #d# ugly forward reference
3312 "command_list/$type" => cf::FT_RSRC,
3313 JSON::XS->new->utf8->encode ([ sort @$list ])
3314 );
3315
3316 $COMMAND_FACE{$type} = $idx;
3230} 3317}
3231 3318
3232cf::client->attach ( 3319cf::client->attach (
3233 on_connect => sub { 3320 on_connect => sub {
3234 my ($ns) = @_; 3321 my ($ns) = @_;
… …
3260 my ($ns, $buf) = @_; 3347 my ($ns, $buf) = @_;
3261 3348
3262 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3349 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3263 3350
3264 if (ref $msg) { 3351 if (ref $msg) {
3265 my ($type, $reply, @payload) = 3352 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3266 "ARRAY" eq ref $msg
3267 ? @$msg
3268 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3269 3353
3270 my @reply;
3271
3272 if (my $cb = $EXTICMD{$type}) { 3354 if (my $cb = $EXTIACMD{$type}) {
3355 $cb->(
3356 $ns,
3357 sub {
3358 $ns->ext_msg ("reply-$reply", @_)
3359 if $reply;
3360 },
3361 @payload
3362 );
3363 } else {
3364 my @reply;
3365
3366 if (my $cb = $EXTICMD{$type}) {
3273 @reply = $cb->($ns, @payload); 3367 @reply = $cb->($ns, @payload);
3368 }
3369
3370 $ns->ext_msg ("reply-$reply", @reply)
3371 if $reply;
3274 } 3372 }
3275
3276 $ns->ext_reply ($reply, @reply)
3277 if $reply;
3278
3279 } else { 3373 } else {
3280 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3374 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3281 } 3375 }
3282 3376
3283 cf::override; 3377 cf::override;
… …
3451=cut 3545=cut
3452 3546
3453############################################################################# 3547#############################################################################
3454# the server's init and main functions 3548# the server's init and main functions
3455 3549
3550{
3551 package cf::face;
3552
3553 our %HASH; # hash => idx
3554 our @DATA; # dynamically-created facedata, only faceste 0 used
3555 our @FOFS; # file offset, if > 0
3556 our @SIZE; # size of face, in octets
3557 our @META; # meta hash of face, if any
3558 our $DATAFH; # facedata filehandle
3559
3560 # internal api, not finalised
3561 sub set {
3562 my ($name, $type, $data) = @_;
3563
3564 my $idx = cf::face::find $name;
3565
3566 if ($idx) {
3567 delete $HASH{cf::face::get_csum $idx};
3568 } else {
3569 $idx = cf::face::alloc $name;
3570 }
3571
3572 my $hash = cf::face::mangle_csum Digest::MD5::md5 $data;
3573
3574 cf::face::set_type $idx, $type;
3575 cf::face::set_csum $idx, 0, $hash;
3576
3577 # we need to destroy the SV itself, not just modify it, as a running ix
3578 # might hold a reference to it: "delete" achieves that.
3579 delete $FOFS[0][$idx];
3580 delete $DATA[0][$idx];
3581 $DATA[0][$idx] = $data;
3582 $SIZE[0][$idx] = length $data;
3583 delete $META[$idx];
3584 $HASH{$hash} = $idx;#d#
3585
3586 $idx
3587 }
3588
3589 sub _get_data($$$) {
3590 my ($idx, $set, $cb) = @_;
3591
3592 if (defined $DATA[$set][$idx]) {
3593 $cb->($DATA[$set][$idx]);
3594 } elsif (my $fofs = $FOFS[$set][$idx]) {
3595 my $size = $SIZE[$set][$idx];
3596 my $buf;
3597 IO::AIO::aio_read $DATAFH, $fofs, $size, $buf, 0, sub {
3598 if ($_[0] == $size) {
3599 #cf::debug "read face $idx, $size from $fofs as ", length $buf;#d#
3600 $cb->($buf);
3601 } else {
3602 cf::error "INTERNAL ERROR: unable to read facedata for face $idx#$set ($size, $fofs), ignoring request.";
3603 }
3604 };
3605 } else {
3606 cf::error "requested facedata for unknown face $idx#$set, ignoring.";
3607 }
3608 }
3609
3610 # rather ineffient
3611 sub cf::face::get_data($;$) {
3612 my ($idx, $set) = @_;
3613
3614 _get_data $idx, $set, Coro::rouse_cb;
3615 Coro::rouse_wait
3616 }
3617
3618 sub cf::face::ix {
3619 my ($ns, $set, $idx, $pri) = @_;
3620
3621 _get_data $idx, $set, sub {
3622 $ns->ix_send ($idx, $pri, $_[0]);
3623 };
3624 }
3625}
3626
3456sub load_facedata($) { 3627sub load_facedata($) {
3457 my ($path) = @_; 3628 my ($path) = @_;
3458 3629
3459 # HACK to clear player env face cache, we need some signal framework
3460 # for this (global event?)
3461 %ext::player_env::MUSIC_FACE_CACHE = ();
3462
3463 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3630 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3464 3631
3465 trace "loading facedata from $path\n"; 3632 trace "loading facedata from $path\n";
3466 3633
3467 my $facedata = decode_storable load_file $path; 3634 my $facedata = decode_storable load_file "$path/faceinfo";
3468 3635
3469 $facedata->{version} == 2 3636 $facedata->{version} == 2
3470 or cf::cleanup "$path: version mismatch, cannot proceed."; 3637 or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";
3471 3638
3472 # patch in the exptable 3639 my $fh = aio_open "$DATADIR/facedata", IO::AIO::O_RDONLY, 0
3473 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]); 3640 or cf::cleanup "$path/facedata: $!, cannot proceed.";
3474 $facedata->{resource}{"res/exp_table"} = { 3641
3475 type => FT_RSRC, 3642 get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
3476 data => $exp_table, 3643
3477 hash => (Digest::MD5::md5 $exp_table), 3644 # BEGIN ATOMIC
3478 }; 3645 # from here on, everything must be atomic - no thread switch allowed
3479 cf::cede_to_tick; 3646 my $t1 = EV::time;
3480 3647
3481 { 3648 {
3482 my $faces = $facedata->{faceinfo}; 3649 my $faces = $facedata->{faceinfo};
3483 3650
3484 while (my ($face, $info) = each %$faces) { 3651 for my $face (sort keys %$faces) {
3652 my $info = $faces->{$face};
3485 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3653 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3486 3654
3487 cf::face::set_visibility $idx, $info->{visibility}; 3655 cf::face::set_visibility $idx, $info->{visibility};
3488 cf::face::set_magicmap $idx, $info->{magicmap}; 3656 cf::face::set_magicmap $idx, $info->{magicmap};
3489 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3657 cf::face::set_csum $idx, 0, $info->{hash64}; $cf::face::SIZE[0][$idx] = $info->{size64}; $cf::face::FOFS[0][$idx] = $info->{fofs64};
3490 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3658 cf::face::set_csum $idx, 1, $info->{hash32}; $cf::face::SIZE[1][$idx] = $info->{size32}; $cf::face::FOFS[1][$idx] = $info->{fofs32};
3491 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ; 3659 cf::face::set_csum $idx, 2, $info->{glyph}; $cf::face::DATA[2][$idx] = $info->{glyph};
3492 3660 $cf::face::HASH{$info->{hash64}} = $idx;
3493 cf::cede_to_tick; 3661 delete $cf::face::META[$idx];
3494 } 3662 }
3495 3663
3496 while (my ($face, $info) = each %$faces) { 3664 while (my ($face, $info) = each %$faces) {
3497 next unless $info->{smooth}; 3665 next unless $info->{smooth};
3498 3666
… …
3503 cf::face::set_smooth $idx, $smooth; 3671 cf::face::set_smooth $idx, $smooth;
3504 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3672 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3505 } else { 3673 } else {
3506 error "smooth face '$info->{smooth}' not found for face '$face'"; 3674 error "smooth face '$info->{smooth}' not found for face '$face'";
3507 } 3675 }
3508
3509 cf::cede_to_tick;
3510 } 3676 }
3511 } 3677 }
3512 3678
3513 { 3679 {
3514 my $anims = $facedata->{animinfo}; 3680 my $anims = $facedata->{animinfo};
3515 3681
3516 while (my ($anim, $info) = each %$anims) { 3682 while (my ($anim, $info) = each %$anims) {
3517 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3683 cf::anim::set $anim, $info->{frames}, $info->{facings};
3518 cf::cede_to_tick;
3519 } 3684 }
3520 3685
3521 cf::anim::invalidate_all; # d'oh 3686 cf::anim::invalidate_all; # d'oh
3522 } 3687 }
3523 3688
3524 { 3689 {
3525 my $res = $facedata->{resource}; 3690 my $res = $facedata->{resource};
3526 3691
3527 while (my ($name, $info) = each %$res) { 3692 while (my ($name, $info) = each %$res) {
3528 if (defined $info->{type}) { 3693 if (defined (my $type = $info->{type})) {
3694 # TODO: different hash - must free and use new index, or cache ixface data queue
3529 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3695 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3530 3696
3531 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3532 cf::face::set_type $idx, $info->{type}; 3697 cf::face::set_type $idx, $type;
3698 cf::face::set_csum $idx, 0, $info->{hash};
3699 $cf::face::SIZE[0][$idx] = $info->{size};
3700 $cf::face::FOFS[0][$idx] = $info->{fofs};
3701 $cf::face::META[$idx] = $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3702 $cf::face::HASH{$info->{hash}} = $idx;
3533 } else { 3703 } else {
3534 $RESOURCE{$name} = $info; # unused 3704# $RESOURCE{$name} = $info; # unused
3535 } 3705 }
3536
3537 cf::cede_to_tick;
3538 } 3706 }
3539 } 3707 }
3708
3709 ($fh, $cf::face::DATAFH) = ($cf::face::DATAFH, $fh);
3710
3711 # HACK to clear player env face cache, we need some signal framework
3712 # for this (global event?)
3713 %ext::player_env::MUSIC_FACE_CACHE = ();
3714
3715 # END ATOMIC
3716
3717 cf::debug "facedata atomic update time ", EV::time - $t1;
3540 3718
3541 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3719 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3720
3721 aio_close $fh if $fh; # close old facedata
3542 3722
3543 1 3723 1
3544} 3724}
3545 3725
3546register_exticmd fx_want => sub { 3726register_exticmd fx_want => sub {
… …
3557 my $status = load_resource_file_ $_[0]; 3737 my $status = load_resource_file_ $_[0];
3558 get_slot 0.1, 100; 3738 get_slot 0.1, 100;
3559 cf::arch::commit_load; 3739 cf::arch::commit_load;
3560 3740
3561 $status 3741 $status
3742}
3743
3744sub reload_exp_table {
3745 _reload_exp_table;
3746
3747 cf::face::set
3748 "res/exp_table" => FT_RSRC,
3749 JSON::XS->new->utf8->canonical->encode (
3750 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3751 );
3752}
3753
3754sub reload_materials {
3755 _reload_materials;
3562} 3756}
3563 3757
3564sub reload_regions { 3758sub reload_regions {
3565 # HACK to clear player env face cache, we need some signal framework 3759 # HACK to clear player env face cache, we need some signal framework
3566 # for this (global event?) 3760 # for this (global event?)
… …
3574 if exists $_->{match}; 3768 if exists $_->{match};
3575 } 3769 }
3576} 3770}
3577 3771
3578sub reload_facedata { 3772sub reload_facedata {
3579 load_facedata "$DATADIR/facedata" 3773 load_facedata $DATADIR
3580 or die "unable to load facedata\n"; 3774 or die "unable to load facedata\n";
3581} 3775}
3582 3776
3583sub reload_archetypes { 3777sub reload_archetypes {
3584 load_resource_file "$DATADIR/archetypes" 3778 load_resource_file "$DATADIR/archetypes"
3585 or die "unable to load archetypes\n"; 3779 or die "unable to load archetypes\n";
3780
3781 cf::face::set
3782 "res/skill_info" => FT_RSRC,
3783 JSON::XS->new->utf8->canonical->encode (
3784 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3785 );
3786
3787 cf::face::set
3788 "res/spell_paths" => FT_RSRC,
3789 JSON::XS->new->utf8->canonical->encode (
3790 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3791 );
3792
3793 # command completion
3794 my @commands;
3795
3796 for (0..cf::arch::skillvec_size - 1) {
3797 my $skill = cf::arch::skillvec $_;
3798 my $name = $skill->name;
3799 my $flags = cf::skill_flags $skill->subtype;
3800
3801 push @commands, "ready_skill $name" if $flags & (SF_COMBAT | SF_RANGED | SF_GRACE);
3802 push @commands, "use_skill $name" if $flags & (SF_USE | SF_AUTARK | SF_GRACE);
3803 }
3804
3805 cf::client::set_command_face skill => \@commands;
3586} 3806}
3587 3807
3588sub reload_treasures { 3808sub reload_treasures {
3589 load_resource_file "$DATADIR/treasures" 3809 load_resource_file "$DATADIR/treasures"
3590 or die "unable to load treasurelists\n"; 3810 or die "unable to load treasurelists\n";
… …
3611} 3831}
3612 3832
3613sub reload_resources { 3833sub reload_resources {
3614 trace "reloading resource files...\n"; 3834 trace "reloading resource files...\n";
3615 3835
3616 reload_exp_table;
3617 reload_materials; 3836 reload_materials;
3618 reload_facedata; 3837 reload_facedata;
3838 reload_exp_table;
3619 reload_sound; 3839 reload_sound;
3620 reload_archetypes; 3840 reload_archetypes;
3621 reload_regions; 3841 reload_regions;
3622 reload_treasures; 3842 reload_treasures;
3623 3843
… …
3675 3895
3676sub main { 3896sub main {
3677 cf::init_globals; # initialise logging 3897 cf::init_globals; # initialise logging
3678 3898
3679 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3899 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3680 LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3900 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3681 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3901 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3682 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3902 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3683 3903
3684 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3904 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3685 3905
3686 # we must not ever block the main coroutine 3906 # we must not ever block the main coroutine
3687 local $Coro::idle = sub { 3907 $Coro::idle = sub {
3688 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3908 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3689 (async { 3909 (async {
3690 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3910 $Coro::current->{desc} = "IDLE BUG HANDLER";
3691 EV::loop EV::LOOP_ONESHOT; 3911 EV::loop EV::LOOP_ONESHOT;
3692 })->prio (Coro::PRIO_MAX); 3912 })->prio (Coro::PRIO_MAX);
… …
3695 evthread_start IO::AIO::poll_fileno; 3915 evthread_start IO::AIO::poll_fileno;
3696 3916
3697 cf::sync_job { 3917 cf::sync_job {
3698 cf::incloader::init (); 3918 cf::incloader::init ();
3699 3919
3920 db_init;
3921
3700 cf::init_anim; 3922 cf::init_anim;
3701 cf::init_attackmess; 3923 cf::init_attackmess;
3702 cf::init_dynamic; 3924 cf::init_dynamic;
3703 3925
3704 cf::load_settings; 3926 cf::load_settings;
3705 3927
3706 reload_resources; 3928 reload_resources;
3707 reload_config; 3929 reload_config;
3708 db_init;
3709 3930
3710 cf::init_uuid; 3931 cf::init_uuid;
3711 cf::init_signals; 3932 cf::init_signals;
3712 cf::init_skills; 3933 cf::init_skills;
3713 3934
… …
3727 }; 3948 };
3728 3949
3729 cf::object::thawer::errors_are_fatal 0; 3950 cf::object::thawer::errors_are_fatal 0;
3730 info "parse errors in files are no longer fatal from this point on.\n"; 3951 info "parse errors in files are no longer fatal from this point on.\n";
3731 3952
3732 my $free_main; $free_main = EV::idle sub { 3953 AE::postpone {
3733 undef $free_main;
3734 undef &main; # free gobs of memory :) 3954 undef &main; # free gobs of memory :)
3735 }; 3955 };
3736 3956
3737 goto &main_loop; 3957 goto &main_loop;
3738} 3958}
… …
3895 4115
3896 cf::write_runtime_sync; # external watchdog should not bark 4116 cf::write_runtime_sync; # external watchdog should not bark
3897 4117
3898 trace "emergency_perl_save: flushing outstanding aio requests"; 4118 trace "emergency_perl_save: flushing outstanding aio requests";
3899 while (IO::AIO::nreqs || BDB::nreqs) { 4119 while (IO::AIO::nreqs || BDB::nreqs) {
3900 Coro::EV::timer_once 0.01; # let the sync_job do it's thing 4120 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
3901 } 4121 }
3902 4122
3903 cf::write_runtime_sync; # external watchdog should not bark 4123 cf::write_runtime_sync; # external watchdog should not bark
3904 }; 4124 };
3905 4125
… …
4086 4306
4087############################################################################# 4307#############################################################################
4088 4308
4089my $bug_warning = 0; 4309my $bug_warning = 0;
4090 4310
4091our @WAIT_FOR_TICK;
4092our @WAIT_FOR_TICK_BEGIN;
4093
4094sub wait_for_tick() { 4311sub wait_for_tick() {
4095 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4312 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4096 4313
4097 my $signal = new Coro::Signal; 4314 $WAIT_FOR_TICK->wait;
4098 push @WAIT_FOR_TICK, $signal;
4099 $signal->wait;
4100} 4315}
4101 4316
4102sub wait_for_tick_begin() { 4317sub wait_for_tick_begin() {
4103 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4318 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4104 4319
4105 my $signal = new Coro::Signal; 4320 my $signal = new Coro::Signal;
4106 push @WAIT_FOR_TICK_BEGIN, $signal; 4321 push @WAIT_FOR_TICK_BEGIN, $signal;
4107 $signal->wait; 4322 $signal->wait;
4108} 4323}
… …
4112 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4327 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4113 unless ++$bug_warning > 10; 4328 unless ++$bug_warning > 10;
4114 return; 4329 return;
4115 } 4330 }
4116 4331
4117 cf::server_tick; # one server iteration 4332 cf::one_tick; # one server iteration
4118 4333
4119 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d# 4334 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4120 4335
4121 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4336 if ($NOW >= $NEXT_RUNTIME_WRITE) {
4122 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4337 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
… …
4128 } 4343 }
4129 4344
4130 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4345 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4131 $sig->send; 4346 $sig->send;
4132 } 4347 }
4133 while (my $sig = shift @WAIT_FOR_TICK) { 4348 $WAIT_FOR_TICK->broadcast;
4134 $sig->send;
4135 }
4136 4349
4137 $LOAD = ($NOW - $TICK_START) / $TICK; 4350 $LOAD = ($NOW - $TICK_START) / $TICK;
4138 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4351 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4139 4352
4140 if (0) { 4353 if (0) {
… …
4146 } 4359 }
4147} 4360}
4148 4361
4149{ 4362{
4150 # configure BDB 4363 # configure BDB
4364 info "initialising database";
4151 4365
4152 BDB::min_parallel 16; 4366 BDB::min_parallel 16;
4153 BDB::max_poll_reqs $TICK * 0.1; 4367 BDB::max_poll_reqs $TICK * 0.1;
4154 $AnyEvent::BDB::WATCHER->priority (1); 4368 #$AnyEvent::BDB::WATCHER->priority (1);
4155 4369
4156 unless ($DB_ENV) { 4370 unless ($DB_ENV) {
4157 $DB_ENV = BDB::db_env_create; 4371 $DB_ENV = BDB::db_env_create;
4158 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4372 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4159 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4373 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
… …
4184 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4398 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4185 }; 4399 };
4186 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4400 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4187 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4401 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4188 }; 4402 };
4403
4404 info "database initialised";
4189} 4405}
4190 4406
4191{ 4407{
4192 # configure IO::AIO 4408 # configure IO::AIO
4193 4409
4410 info "initialising aio";
4194 IO::AIO::min_parallel 8; 4411 IO::AIO::min_parallel 8;
4195 IO::AIO::max_poll_time $TICK * 0.1; 4412 IO::AIO::max_poll_time $TICK * 0.1;
4196 undef $AnyEvent::AIO::WATCHER; 4413 undef $AnyEvent::AIO::WATCHER;
4414 info "aio initialised";
4197} 4415}
4198 4416
4199our $_log_backtrace; 4417our $_log_backtrace;
4200our $_log_backtrace_last; 4418our $_log_backtrace_last;
4201 4419

Diff Legend

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