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.559 by root, Sat Feb 26 12:50:27 2011 UTC vs.
Revision 1.598 by root, Sun Nov 11 02:38:10 2012 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008,2009,2010 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.
… …
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. cf::wait_for_tick_begin only
240returns directly I<after> the tick processing (and consequently, can only wake one thread 257returns directly I<after> the tick processing (and consequently, can only wake one thread
241per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 258per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
259
260Note that cf::Wait_for_tick will immediately return when the server is not
261ticking, making it suitable for small pauses in threads that need to run
262when the server is paused. If that is not applicable (i.e. you I<really>
263want to wait, use C<$cf::WAIT_FOR_TICK>).
264
265=item $cf::WAIT_FOR_TICK
266
267Note that C<cf::wait_for_tick> is probably the correct thing to use. This
268variable contains a L<Coro::Signal> that is broadcats after every server
269tick. Calling C<< ->wait >> on it will suspend the caller until after the
270next server tick.
242 271
243=cut 272=cut
244 273
245sub wait_for_tick(); 274sub wait_for_tick();
246sub wait_for_tick_begin(); 275sub wait_for_tick_begin();
… …
312)) { 341)) {
313 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 342 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
314} 343}
315 344
316$EV::DIED = sub { 345$EV::DIED = sub {
317 Carp::cluck "error in event callback: @_"; 346 warn "error in event callback: $@";
318}; 347};
348
349#############################################################################
350
351sub fork_call(&@);
352sub get_slot($;$$);
319 353
320############################################################################# 354#############################################################################
321 355
322=head2 UTILITY FUNCTIONS 356=head2 UTILITY FUNCTIONS
323 357
… …
344 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 378 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
345 $d 379 $d
346 } || "[unable to dump $_[0]: '$@']"; 380 } || "[unable to dump $_[0]: '$@']";
347} 381}
348 382
383=item $scalar = cf::load_file $path
384
385Loads the given file from path and returns its contents. Croaks on error
386and can block.
387
388=cut
389
390sub load_file($) {
391 0 <= aio_load $_[0], my $data
392 or Carp::croak "$_[0]: $!";
393
394 $data
395}
396
397=item $success = cf::replace_file $path, $data, $sync
398
399Atomically replaces the file at the given $path with new $data, and
400optionally $sync the data to disk before replacing the file.
401
402=cut
403
404sub replace_file($$;$) {
405 my ($path, $data, $sync) = @_;
406
407 my $lock = cf::lock_acquire ("replace_file:$path");
408
409 my $fh = aio_open "$path~", Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_TRUNC, 0644
410 or return;
411
412 $data = $data->() if ref $data;
413
414 length $data == aio_write $fh, 0, (length $data), $data, 0
415 or return;
416
417 !$sync
418 or !aio_fsync $fh
419 or return;
420
421 aio_close $fh
422 and return;
423
424 aio_rename "$path~", $path
425 and return;
426
427 if ($sync) {
428 $path =~ s%/[^/]*$%%;
429 aio_pathsync $path;
430 }
431
432 1
433}
434
349=item $ref = cf::decode_json $json 435=item $ref = cf::decode_json $json
350 436
351Converts a JSON string into the corresponding perl data structure. 437Converts a JSON string into the corresponding perl data structure.
352 438
353=item $json = cf::encode_json $ref 439=item $json = cf::encode_json $ref
… …
359our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 445our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
360 446
361sub encode_json($) { $json_coder->encode ($_[0]) } 447sub encode_json($) { $json_coder->encode ($_[0]) }
362sub decode_json($) { $json_coder->decode ($_[0]) } 448sub decode_json($) { $json_coder->decode ($_[0]) }
363 449
450=item $ref = cf::decode_storable $scalar
451
452Same as Coro::Storable::thaw, so blocks.
453
454=cut
455
456BEGIN { *decode_storable = \&Coro::Storable::thaw }
457
364=item $ref = cf::yaml_load $scalar 458=item $ref = cf::decode_yaml $scalar
365 459
366Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks). 460Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
367 461
368=cut 462=cut
369 463
370sub fork_call(&@); 464sub decode_yaml($) {
371
372sub yaml_load($) {
373 fork_call { YAML::XS::Load $_[0] } @_ 465 fork_call { YAML::XS::Load $_[0] } @_
466}
467
468=item $scalar = cf::unlzf $scalar
469
470Same as Compress::LZF::compress, but takes server ticks into account, so
471blocks.
472
473=cut
474
475sub unlzf($) {
476 # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
477 cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
478 Compress::LZF::decompress $_[0]
374} 479}
375 480
376=item cf::post_init { BLOCK } 481=item cf::post_init { BLOCK }
377 482
378Execute the given codeblock, I<after> all extensions have been (re-)loaded, 483Execute the given codeblock, I<after> all extensions have been (re-)loaded,
… …
462 EV::periodic $start, $interval, 0, $cb 567 EV::periodic $start, $interval, 0, $cb
463} 568}
464 569
465=item cf::get_slot $time[, $priority[, $name]] 570=item cf::get_slot $time[, $priority[, $name]]
466 571
467Allocate $time seconds of blocking CPU time at priority C<$priority>: 572Allocate $time seconds of blocking CPU time at priority C<$priority>
468This call blocks and returns only when you have at least C<$time> seconds 573(default: 0): This call blocks and returns only when you have at least
469of cpu time till the next tick. The slot is only valid till the next cede. 574C<$time> seconds of cpu time till the next tick. The slot is only valid
575till the next cede.
576
577Background jobs should use a priority les than zero, interactive jobs
578should use 100 or more.
470 579
471The optional C<$name> can be used to identify the job to run. It might be 580The optional C<$name> can be used to identify the job to run. It might be
472used for statistical purposes and should identify the same time-class. 581used for statistical purposes and should identify the same time-class.
473 582
474Useful for short background jobs. 583Useful for short background jobs.
… …
503 } 612 }
504 } 613 }
505 614
506 if (@SLOT_QUEUE) { 615 if (@SLOT_QUEUE) {
507 # we do not use wait_for_tick() as it returns immediately when tick is inactive 616 # we do not use wait_for_tick() as it returns immediately when tick is inactive
508 push @cf::WAIT_FOR_TICK, $signal; 617 $WAIT_FOR_TICK->wait;
509 $signal->wait;
510 } else { 618 } else {
511 $busy = 0; 619 $busy = 0;
512 Coro::schedule; 620 Coro::schedule;
513 } 621 }
514 } 622 }
… …
769 877
770 my @data; 878 my @data;
771 my $md5; 879 my $md5;
772 880
773 for (0 .. $#$src) { 881 for (0 .. $#$src) {
774 0 <= aio_load $src->[$_], $data[$_] 882 $data[$_] = load_file $src->[$_];
775 or Carp::croak "$src->[$_]: $!";
776 } 883 }
777 884
778 # if processing is expensive, check 885 # if processing is expensive, check
779 # checksum first 886 # checksum first
780 if (1) { 887 if (1) {
… …
793 900
794 return db_get cache => "$id/data"; 901 return db_get cache => "$id/data";
795 } 902 }
796 } 903 }
797 904
798 my $t1 = Time::HiRes::time; 905 my $t1 = EV::time;
799 my $data = $process->(\@data); 906 my $data = $process->(\@data);
800 my $t2 = Time::HiRes::time; 907 my $t2 = EV::time;
801 908
802 info "cache: '$id' processed in ", $t2 - $t1, "s\n"; 909 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
803 910
804 db_put cache => "$id/data", $data; 911 db_put cache => "$id/data", $data;
805 db_put cache => "$id/md5" , $md5; 912 db_put cache => "$id/md5" , $md5;
… …
1325=cut 1432=cut
1326 1433
1327############################################################################# 1434#############################################################################
1328# command handling &c 1435# command handling &c
1329 1436
1330=item cf::register_command $name => \&callback($ob,$args); 1437=item cf::register_command $name => \&callback($ob,$args)
1331 1438
1332Register a callback for execution when the client sends the user command 1439Register a callback for execution when the client sends the user command
1333$name. 1440$name.
1334 1441
1335=cut 1442=cut
… …
1341 #warn "registering command '$name/$time' to '$caller'"; 1448 #warn "registering command '$name/$time' to '$caller'";
1342 1449
1343 push @{ $COMMAND{$name} }, [$caller, $cb]; 1450 push @{ $COMMAND{$name} }, [$caller, $cb];
1344} 1451}
1345 1452
1346=item cf::register_extcmd $name => \&callback($pl,$packet); 1453=item cf::register_extcmd $name => \&callback($pl,@args)
1347 1454
1348Register a callback for execution when the client sends an (synchronous) 1455Register a callback for execution when the client sends an (synchronous)
1349extcmd packet. Ext commands will be processed in the order they are 1456extcmd packet. Ext commands will be processed in the order they are
1350received by the server, like other user commands. The first argument is 1457received by the server, like other user commands. The first argument is
1351the logged-in player. Ext commands can only be processed after a player 1458the logged-in player. Ext commands can only be processed after a player
1352has logged in successfully. 1459has logged in successfully.
1353 1460
1354If the callback returns something, it is sent back as if reply was being 1461The values will be sent back to the client.
1355called.
1356 1462
1463=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
1464
1465Same as C<cf::register_extcmd>, but instead of returning values, the
1466callback needs to clal the C<$reply> function.
1467
1357=item cf::register_exticmd $name => \&callback($ns,$packet); 1468=item cf::register_exticmd $name => \&callback($ns,@args)
1358 1469
1359Register a callback for execution when the client sends an (asynchronous) 1470Register a callback for execution when the client sends an (asynchronous)
1360exticmd packet. Exti commands are processed by the server as soon as they 1471exticmd packet. Exti commands are processed by the server as soon as they
1361are received, i.e. out of order w.r.t. other commands. The first argument 1472are received, i.e. out of order w.r.t. other commands. The first argument
1362is a client socket. Exti commands can be received anytime, even before 1473is a client socket. Exti commands can be received anytime, even before
1363log-in. 1474log-in.
1364 1475
1365If the callback returns something, it is sent back as if reply was being 1476The values will be sent back to the client.
1366called.
1367 1477
1368=cut 1478=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
1369 1479
1480Same as C<cf::register_extcmd>, but instead of returning values, the
1481callback needs to clal the C<$reply> function.
1482
1483=cut
1484
1370sub register_extcmd { 1485sub register_extcmd($$) {
1371 my ($name, $cb) = @_; 1486 my ($name, $cb) = @_;
1372 1487
1373 $EXTCMD{$name} = $cb; 1488 $EXTCMD{$name} = $cb;
1374} 1489}
1375 1490
1376sub register_exticmd { 1491sub register_async_extcmd($$) {
1377 my ($name, $cb) = @_; 1492 my ($name, $cb) = @_;
1378 1493
1494 $EXTACMD{$name} = $cb;
1495}
1496
1497sub register_exticmd($$) {
1498 my ($name, $cb) = @_;
1499
1379 $EXTICMD{$name} = $cb; 1500 $EXTICMD{$name} = $cb;
1501}
1502
1503sub register_async_exticmd($$) {
1504 my ($name, $cb) = @_;
1505
1506 $EXTIACMD{$name} = $cb;
1380} 1507}
1381 1508
1382use File::Glob (); 1509use File::Glob ();
1383 1510
1384cf::player->attach ( 1511cf::player->attach (
… …
1398 my ($pl, $buf) = @_; 1525 my ($pl, $buf) = @_;
1399 1526
1400 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1527 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1401 1528
1402 if (ref $msg) { 1529 if (ref $msg) {
1403 my ($type, $reply, @payload) = 1530 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1404 "ARRAY" eq ref $msg
1405 ? @$msg
1406 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1407 1531
1408 my @reply;
1409
1410 if (my $cb = $EXTCMD{$type}) { 1532 if (my $cb = $EXTACMD{$type}) {
1533 $cb->(
1534 $pl,
1535 sub {
1536 $pl->ext_msg ("reply-$reply", @_)
1537 if $reply;
1538 },
1539 @payload
1540 );
1541 } else {
1542 my @reply;
1543
1544 if (my $cb = $EXTCMD{$type}) {
1411 @reply = $cb->($pl, @payload); 1545 @reply = $cb->($pl, @payload);
1546 }
1547
1548 $pl->ext_msg ("reply-$reply", @reply)
1549 if $reply;
1412 } 1550 }
1413
1414 $pl->ext_reply ($reply, @reply)
1415 if $reply;
1416 1551
1417 } else { 1552 } else {
1418 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1553 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1419 } 1554 }
1420 1555
… …
1433 }; 1568 };
1434 1569
1435 $grp 1570 $grp
1436} 1571}
1437 1572
1573sub _ext_cfg_reg($$$$) {
1574 my ($rvar, $varname, $cfgname, $default) = @_;
1575
1576 $cfgname = lc $varname
1577 unless length $cfgname;
1578
1579 $EXT_CFG{$cfgname} = [$rvar, $default];
1580
1581 $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
1582}
1583
1438sub load_extensions { 1584sub load_extensions {
1439 info "loading extensions..."; 1585 info "loading extensions...";
1586
1587 %EXT_CFG = ();
1440 1588
1441 cf::sync_job { 1589 cf::sync_job {
1442 my %todo; 1590 my %todo;
1443 1591
1444 for my $path (<$LIBDIR/*.ext>) { 1592 for my $path (<$LIBDIR/*.ext>) {
… …
1487 unless exists $done{$_}; 1635 unless exists $done{$_};
1488 } 1636 }
1489 1637
1490 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n"; 1638 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1491 1639
1640 my $source = $v->{source};
1641
1642 # support "CONF varname :confname = default" pseudo-statements
1643 $source =~ s{
1644 ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
1645 }{
1646 "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
1647 }gmxe;
1648
1492 my $active = eval $v->{source}; 1649 my $active = eval $source;
1493 1650
1494 if (length $@) { 1651 if (length $@) {
1495 error "$v->{path}: $@\n"; 1652 error "$v->{path}: $@\n";
1496 1653
1497 cf::cleanup "mandatory extension '$k' failed to load, exiting." 1654 cf::cleanup "mandatory extension '$k' failed to load, exiting."
… …
1514 1671
1515 while (my ($k, $v) = each %todo) { 1672 while (my ($k, $v) = each %todo) {
1516 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting." 1673 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1517 if exists $v->{meta}{mandatory}; 1674 if exists $v->{meta}{mandatory};
1518 } 1675 }
1676
1677 last;
1519 } 1678 }
1520 } 1679 }
1521 }; 1680 };
1522} 1681}
1523 1682
… …
1782} 1941}
1783 1942
1784=item $protocol_xml = $player->expand_cfpod ($cfpod) 1943=item $protocol_xml = $player->expand_cfpod ($cfpod)
1785 1944
1786Expand deliantra pod fragments into protocol xml. 1945Expand deliantra pod fragments into protocol xml.
1787
1788=item $player->ext_reply ($msgid, @msg)
1789
1790Sends an ext reply to the player.
1791
1792=cut
1793
1794sub ext_reply($$@) {
1795 my ($self, $id, @msg) = @_;
1796
1797 $self->ns->ext_reply ($id, @msg)
1798}
1799 1946
1800=item $player->ext_msg ($type, @msg) 1947=item $player->ext_msg ($type, @msg)
1801 1948
1802Sends an ext event to the client. 1949Sends an ext event to the client.
1803 1950
… …
1951 2098
1952 Carp::cluck "unable to resolve path '$path' (base '$base')"; 2099 Carp::cluck "unable to resolve path '$path' (base '$base')";
1953 () 2100 ()
1954} 2101}
1955 2102
2103# may re-bless or do other evil things
1956sub init { 2104sub init {
1957 my ($self) = @_; 2105 my ($self) = @_;
1958 2106
1959 $self 2107 $self
1960} 2108}
… …
2025 $self->{load_path} = $path; 2173 $self->{load_path} = $path;
2026 2174
2027 1 2175 1
2028} 2176}
2029 2177
2178# used to laod the header of an original map
2030sub load_header_orig { 2179sub load_header_orig {
2031 my ($self) = @_; 2180 my ($self) = @_;
2032 2181
2033 $self->load_header_from ($self->load_path) 2182 $self->load_header_from ($self->load_path)
2034} 2183}
2035 2184
2185# used to laod the header of an instantiated map
2036sub load_header_temp { 2186sub load_header_temp {
2037 my ($self) = @_; 2187 my ($self) = @_;
2038 2188
2039 $self->load_header_from ($self->save_path) 2189 $self->load_header_from ($self->save_path)
2040} 2190}
2041 2191
2192# called after loading the header from an instantiated map
2042sub prepare_temp { 2193sub prepare_temp {
2043 my ($self) = @_; 2194 my ($self) = @_;
2044 2195
2045 $self->last_access ((delete $self->{last_access}) 2196 $self->last_access ((delete $self->{last_access})
2046 || $cf::RUNTIME); #d# 2197 || $cf::RUNTIME); #d#
2047 # safety 2198 # safety
2048 $self->{instantiate_time} = $cf::RUNTIME 2199 $self->{instantiate_time} = $cf::RUNTIME
2049 if $self->{instantiate_time} > $cf::RUNTIME; 2200 if $self->{instantiate_time} > $cf::RUNTIME;
2050} 2201}
2051 2202
2203# called after loading the header from an original map
2052sub prepare_orig { 2204sub prepare_orig {
2053 my ($self) = @_; 2205 my ($self) = @_;
2054 2206
2055 $self->{load_original} = 1; 2207 $self->{load_original} = 1;
2056 $self->{instantiate_time} = $cf::RUNTIME; 2208 $self->{instantiate_time} = $cf::RUNTIME;
… …
2082sub find { 2234sub find {
2083 my ($path, $origin) = @_; 2235 my ($path, $origin) = @_;
2084 2236
2085 cf::cede_to_tick; 2237 cf::cede_to_tick;
2086 2238
2087 $path = normalise $path, $origin && $origin->path; 2239 $path = normalise $path, $origin;
2088 2240
2089 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2241 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2090 my $guard2 = cf::lock_acquire "map_find:$path"; 2242 my $guard2 = cf::lock_acquire "map_find:$path";
2091 2243
2092 $cf::MAP{$path} || do { 2244 $cf::MAP{$path} || do {
… …
2123 2275
2124 { 2276 {
2125 my $guard = cf::lock_acquire "map_data:$path"; 2277 my $guard = cf::lock_acquire "map_data:$path";
2126 2278
2127 return unless $self->valid; 2279 return unless $self->valid;
2128 return unless $self->in_memory == cf::MAP_SWAPPED; 2280 return unless $self->state == cf::MAP_SWAPPED;
2129
2130 $self->in_memory (cf::MAP_LOADING);
2131 2281
2132 $self->alloc; 2282 $self->alloc;
2133 2283
2134 $self->pre_load; 2284 $self->pre_load;
2135 cf::cede_to_tick; 2285 cf::cede_to_tick;
2136 2286
2287 if (exists $self->{load_path}) {
2137 my $f = new_from_file cf::object::thawer $self->{load_path}; 2288 my $f = new_from_file cf::object::thawer $self->{load_path};
2138 $f->skip_block; 2289 $f->skip_block;
2139 $self->_load_objects ($f) 2290 $self->_load_objects ($f)
2140 or return; 2291 or return;
2141 2292
2142 $self->post_load_original 2293 $self->post_load_original
2143 if delete $self->{load_original}; 2294 if delete $self->{load_original};
2144 2295
2145 if (my $uniq = $self->uniq_path) { 2296 if (my $uniq = $self->uniq_path) {
2146 utf8::encode $uniq; 2297 utf8::encode $uniq;
2147 unless (aio_stat $uniq) { 2298 unless (aio_stat $uniq) {
2148 if (my $f = new_from_file cf::object::thawer $uniq) { 2299 if (my $f = new_from_file cf::object::thawer $uniq) {
2149 $self->clear_unique_items; 2300 $self->clear_unique_items;
2150 $self->_load_objects ($f); 2301 $self->_load_objects ($f);
2151 $f->resolve_delayed_derefs; 2302 $f->resolve_delayed_derefs;
2303 }
2152 } 2304 }
2153 } 2305 }
2154 }
2155 2306
2156 $f->resolve_delayed_derefs; 2307 $f->resolve_delayed_derefs;
2308 } else {
2309 $self->post_load_original
2310 if delete $self->{load_original};
2311 }
2312
2313 $self->state (cf::MAP_INACTIVE);
2157 2314
2158 cf::cede_to_tick; 2315 cf::cede_to_tick;
2159 # now do the right thing for maps 2316 # now do the right thing for maps
2160 $self->link_multipart_objects; 2317 $self->link_multipart_objects;
2161 $self->difficulty ($self->estimate_difficulty) 2318 $self->difficulty ($self->estimate_difficulty)
… …
2165 unless ($self->{deny_activate}) { 2322 unless ($self->{deny_activate}) {
2166 $self->decay_objects; 2323 $self->decay_objects;
2167 $self->fix_auto_apply; 2324 $self->fix_auto_apply;
2168 $self->update_buttons; 2325 $self->update_buttons;
2169 cf::cede_to_tick; 2326 cf::cede_to_tick;
2170 $self->activate; 2327 #$self->activate; # no longer activate maps automatically
2171 } 2328 }
2172 2329
2173 $self->{last_save} = $cf::RUNTIME; 2330 $self->{last_save} = $cf::RUNTIME;
2174 $self->last_access ($cf::RUNTIME); 2331 $self->last_access ($cf::RUNTIME);
2175
2176 $self->in_memory (cf::MAP_ACTIVE);
2177 } 2332 }
2178 2333
2179 $self->post_load; 2334 $self->post_load;
2180 2335
2181 1 2336 1
… …
2194# if $self->per_party; 2349# if $self->per_party;
2195 2350
2196 $self 2351 $self
2197} 2352}
2198 2353
2199# find and load all maps in the 3x3 area around a map
2200sub load_neighbours {
2201 my ($map) = @_;
2202
2203 my @neigh; # diagonal neighbours
2204
2205 for (0 .. 3) {
2206 my $neigh = $map->tile_path ($_)
2207 or next;
2208 $neigh = find $neigh, $map
2209 or next;
2210 $neigh->load;
2211
2212 # now find the diagonal neighbours
2213 push @neigh,
2214 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2215 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2216 }
2217
2218 for (grep defined $_->[0], @neigh) {
2219 my ($path, $origin) = @$_;
2220 my $neigh = find $path, $origin
2221 or next;
2222 $neigh->load;
2223 }
2224}
2225
2226sub find_sync { 2354sub find_sync {
2227 my ($path, $origin) = @_; 2355 my ($path, $origin) = @_;
2228 2356
2357 # it's a bug to call this from the main context
2229 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync" 2358 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2230 if $Coro::current == $Coro::main; 2359 if $Coro::current == $Coro::main;
2231 2360
2232 find $path, $origin 2361 find $path, $origin
2233} 2362}
2234 2363
2235sub do_load_sync { 2364sub do_load_sync {
2236 my ($map) = @_; 2365 my ($map) = @_;
2237 2366
2367 # it's a bug to call this from the main context
2238 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync" 2368 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2239 if $Coro::current == $Coro::main; 2369 if $Coro::current == $Coro::main;
2240 2370
2241 $map->load; 2371 $map->load;
2242} 2372}
… …
2245our $MAP_PREFETCHER = undef; 2375our $MAP_PREFETCHER = undef;
2246 2376
2247sub find_async { 2377sub find_async {
2248 my ($path, $origin, $load) = @_; 2378 my ($path, $origin, $load) = @_;
2249 2379
2250 $path = normalise $path, $origin && $origin->{path}; 2380 $path = normalise $path, $origin;
2251 2381
2252 if (my $map = $cf::MAP{$path}) { 2382 if (my $map = $cf::MAP{$path}) {
2253 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2383 return $map if !$load || $map->linkable;
2254 } 2384 }
2255 2385
2256 $MAP_PREFETCH{$path} |= $load; 2386 $MAP_PREFETCH{$path} |= $load;
2257 2387
2258 $MAP_PREFETCHER ||= cf::async { 2388 $MAP_PREFETCHER ||= cf::async {
… …
2317sub swap_out { 2447sub swap_out {
2318 my ($self) = @_; 2448 my ($self) = @_;
2319 2449
2320 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2450 my $lock = cf::lock_acquire "map_data:$self->{path}";
2321 2451
2322 return if $self->in_memory != cf::MAP_ACTIVE; 2452 return if !$self->linkable;
2323 return if $self->{deny_save}; 2453 return if $self->{deny_save};
2324 return if $self->players; 2454 return if $self->players;
2325 2455
2326 # first deactivate the map and "unlink" it from the core 2456 # first deactivate the map and "unlink" it from the core
2327 $self->deactivate; 2457 $self->deactivate;
2328 $_->clear_links_to ($self) for values %cf::MAP; 2458 $_->clear_links_to ($self) for values %cf::MAP;
2329 $self->in_memory (cf::MAP_SWAPPED); 2459 $self->state (cf::MAP_SWAPPED);
2330 2460
2331 # then atomically save 2461 # then atomically save
2332 $self->_save; 2462 $self->_save;
2333 2463
2334 # then free the map 2464 # then free the map
… …
2360 2490
2361 return if $self->players; 2491 return if $self->players;
2362 2492
2363 cf::trace "resetting map ", $self->path, "\n"; 2493 cf::trace "resetting map ", $self->path, "\n";
2364 2494
2365 $self->in_memory (cf::MAP_SWAPPED); 2495 $self->state (cf::MAP_SWAPPED);
2366 2496
2367 # need to save uniques path 2497 # need to save uniques path
2368 unless ($self->{deny_save}) { 2498 unless ($self->{deny_save}) {
2369 my $uniq = $self->uniq_path; utf8::encode $uniq; 2499 my $uniq = $self->uniq_path; utf8::encode $uniq;
2370 2500
… …
2700 # use -1 or undef as default coordinates, not 0, 0 2830 # use -1 or undef as default coordinates, not 0, 0
2701 ($x, $y) = ($map->enter_x, $map->enter_y) 2831 ($x, $y) = ($map->enter_x, $map->enter_y)
2702 if $x <= 0 && $y <= 0; 2832 if $x <= 0 && $y <= 0;
2703 2833
2704 $map->load; 2834 $map->load;
2705 $map->load_neighbours;
2706 2835
2707 return unless $self->contr->active; 2836 return unless $self->contr->active;
2708 2837
2709 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2838 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2710 if ($self->enter_map ($map, $x, $y)) { 2839 if ($self->enter_map ($map, $x, $y)) {
… …
2766 ($path, $x, $y) = (undef, undef, undef); 2895 ($path, $x, $y) = (undef, undef, undef);
2767 } 2896 }
2768 } 2897 }
2769 2898
2770 my $map = eval { 2899 my $map = eval {
2771 my $map = defined $path ? cf::map::find $path : undef; 2900 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2772 2901
2773 if ($map) { 2902 if ($map) {
2774 $map = $map->customise_for ($self); 2903 $map = $map->customise_for ($self);
2775 $map = $check->($map, $x, $y, $self) if $check && $map; 2904 $map = $check->($map, $x, $y, $self) if $check && $map;
2776 } else { 2905 } else {
… …
2866 $Coro::current->{desc} = "enter_exit"; 2995 $Coro::current->{desc} = "enter_exit";
2867 2996
2868 unless (eval { 2997 unless (eval {
2869 $self->deactivate_recursive; # just to be sure 2998 $self->deactivate_recursive; # just to be sure
2870 2999
2871 # random map handling
2872 {
2873 my $guard = cf::lock_acquire "exit_prepare:$exit";
2874
2875 prepare_random_map $exit
2876 if $exit->slaying eq "/!";
2877 }
2878
2879 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 3000 my $map = cf::map::normalise $exit->slaying, $exit->map;
2880 my $x = $exit->stats->hp; 3001 my $x = $exit->stats->hp;
2881 my $y = $exit->stats->sp; 3002 my $y = $exit->stats->sp;
3003
3004 # special map handling
3005 my $slaying = $exit->slaying;
3006
3007 # special map handling
3008 if ($slaying eq "/!") {
3009 my $guard = cf::lock_acquire "exit_prepare:$exit";
3010
3011 prepare_random_map $exit
3012 if $exit->slaying eq "/!"; # need to re-check after getting the lock
3013
3014 $map = $exit->slaying;
3015
3016 } elsif ($slaying eq '!up') {
3017 $map = $exit->map->tile_path (cf::TILE_UP);
3018 $x = $exit->x;
3019 $y = $exit->y;
3020
3021 } elsif ($slaying eq '!down') {
3022 $map = $exit->map->tile_path (cf::TILE_DOWN);
3023 $x = $exit->x;
3024 $y = $exit->y;
3025 }
2882 3026
2883 $self->goto ($map, $x, $y); 3027 $self->goto ($map, $x, $y);
2884 3028
2885 # if exit is damned, update players death & WoR home-position 3029 # if exit is damned, update players death & WoR home-position
2886 $self->contr->savebed ($map, $x, $y) 3030 $self->contr->savebed ($map, $x, $y)
… …
3111=cut 3255=cut
3112 3256
3113sub cf::client::ext_msg($$@) { 3257sub cf::client::ext_msg($$@) {
3114 my ($self, $type, @msg) = @_; 3258 my ($self, $type, @msg) = @_;
3115 3259
3116 if ($self->extcmd == 2) {
3117 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3260 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3118 } elsif ($self->extcmd == 1) { # TODO: remove
3119 push @msg, msgtype => "event_$type";
3120 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3121 }
3122}
3123
3124=item $client->ext_reply ($msgid, @msg)
3125
3126Sends an ext reply to the client.
3127
3128=cut
3129
3130sub cf::client::ext_reply($$@) {
3131 my ($self, $id, @msg) = @_;
3132
3133 if ($self->extcmd == 2) {
3134 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3135 } elsif ($self->extcmd == 1) {
3136 #TODO: version 1, remove
3137 unshift @msg, msgtype => "reply", msgid => $id;
3138 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3139 }
3140} 3261}
3141 3262
3142=item $success = $client->query ($flags, "text", \&cb) 3263=item $success = $client->query ($flags, "text", \&cb)
3143 3264
3144Queues a query to the client, calling the given callback with 3265Queues a query to the client, calling the given callback with
… …
3199 my ($ns, $buf) = @_; 3320 my ($ns, $buf) = @_;
3200 3321
3201 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3322 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3202 3323
3203 if (ref $msg) { 3324 if (ref $msg) {
3204 my ($type, $reply, @payload) = 3325 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3205 "ARRAY" eq ref $msg
3206 ? @$msg
3207 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3208 3326
3209 my @reply;
3210
3211 if (my $cb = $EXTICMD{$type}) { 3327 if (my $cb = $EXTIACMD{$type}) {
3328 $cb->(
3329 $ns,
3330 sub {
3331 $ns->ext_msg ("reply-$reply", @_)
3332 if $reply;
3333 },
3334 @payload
3335 );
3336 } else {
3337 my @reply;
3338
3339 if (my $cb = $EXTICMD{$type}) {
3212 @reply = $cb->($ns, @payload); 3340 @reply = $cb->($ns, @payload);
3341 }
3342
3343 $ns->ext_msg ("reply-$reply", @reply)
3344 if $reply;
3213 } 3345 }
3214
3215 $ns->ext_reply ($reply, @reply)
3216 if $reply;
3217
3218 } else { 3346 } else {
3219 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3347 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3220 } 3348 }
3221 3349
3222 cf::override; 3350 cf::override;
… …
3390=cut 3518=cut
3391 3519
3392############################################################################# 3520#############################################################################
3393# the server's init and main functions 3521# the server's init and main functions
3394 3522
3523our %FACEHASH; # hash => idx, #d# HACK for http server
3524
3525# internal api, not fianlised
3526sub set_face {
3527 my ($name, $type, $data) = @_;
3528
3529 my $idx = cf::face::find $name;
3530
3531 if ($idx) {
3532 delete $FACEHASH{cf::face::get_chksum $idx};
3533 } else {
3534 $idx = cf::face::alloc $name;
3535 }
3536
3537 my $hash = cf::face::mangle_chksum Digest::MD5::md5 $data;
3538
3539 cf::face::set_type $idx, $type;
3540 cf::face::set_data $idx, 0, $data, $hash;
3541 cf::face::set_meta $idx, $type & 1 ? undef : undef;
3542 $FACEHASH{$hash} = $idx;#d#
3543
3544 $idx
3545}
3546
3395sub load_facedata($) { 3547sub load_facedata($) {
3396 my ($path) = @_; 3548 my ($path) = @_;
3397 3549
3398 # HACK to clear player env face cache, we need some signal framework 3550 # HACK to clear player env face cache, we need some signal framework
3399 # for this (global event?) 3551 # for this (global event?)
… …
3401 3553
3402 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3554 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3403 3555
3404 trace "loading facedata from $path\n"; 3556 trace "loading facedata from $path\n";
3405 3557
3406 0 < aio_load $path, my $facedata 3558 my $facedata = decode_storable load_file $path;
3407 or die "$path: $!";
3408
3409 $facedata = Coro::Storable::thaw $facedata;
3410 3559
3411 $facedata->{version} == 2 3560 $facedata->{version} == 2
3412 or cf::cleanup "$path: version mismatch, cannot proceed."; 3561 or cf::cleanup "$path: version mismatch, cannot proceed.";
3413 3562
3414 # patch in the exptable
3415 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3416 $facedata->{resource}{"res/exp_table"} = {
3417 type => FT_RSRC,
3418 data => $exp_table,
3419 hash => (Digest::MD5::md5 $exp_table),
3420 };
3421 cf::cede_to_tick; 3563 cf::cede_to_tick;
3422 3564
3423 { 3565 {
3424 my $faces = $facedata->{faceinfo}; 3566 my $faces = delete $facedata->{faceinfo};
3425 3567
3426 while (my ($face, $info) = each %$faces) { 3568 for my $face (sort keys %$faces) {
3569 my $info = $faces->{$face};
3427 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3570 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3428 3571
3429 cf::face::set_visibility $idx, $info->{visibility}; 3572 cf::face::set_visibility $idx, $info->{visibility};
3430 cf::face::set_magicmap $idx, $info->{magicmap}; 3573 cf::face::set_magicmap $idx, $info->{magicmap};
3431 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3574 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3432 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3575 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3433 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ; 3576 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3434 3577 $FACEHASH{$info->{hash64}} = $idx;#d#
3578
3435 cf::cede_to_tick; 3579 cf::cede_to_tick;
3436 } 3580 }
3437 3581
3438 while (my ($face, $info) = each %$faces) { 3582 while (my ($face, $info) = each %$faces) {
3439 next unless $info->{smooth}; 3583 next unless $info->{smooth};
… …
3451 cf::cede_to_tick; 3595 cf::cede_to_tick;
3452 } 3596 }
3453 } 3597 }
3454 3598
3455 { 3599 {
3456 my $anims = $facedata->{animinfo}; 3600 my $anims = delete $facedata->{animinfo};
3457 3601
3458 while (my ($anim, $info) = each %$anims) { 3602 while (my ($anim, $info) = each %$anims) {
3459 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3603 cf::anim::set $anim, $info->{frames}, $info->{facings};
3460 cf::cede_to_tick; 3604 cf::cede_to_tick;
3461 } 3605 }
3462 3606
3463 cf::anim::invalidate_all; # d'oh 3607 cf::anim::invalidate_all; # d'oh
3464 } 3608 }
3465 3609
3466 { 3610 {
3467 my $res = $facedata->{resource}; 3611 my $res = delete $facedata->{resource};
3468 3612
3469 while (my ($name, $info) = each %$res) { 3613 while (my ($name, $info) = each %$res) {
3470 if (defined $info->{type}) { 3614 if (defined (my $type = $info->{type})) {
3615 # TODO: different hash - must free and use new index, or cache ixface data queue
3471 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3616 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3472 3617
3618 cf::face::set_type $idx, $type;
3473 cf::face::set_data $idx, 0, $info->{data}, $info->{hash}; 3619 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3474 cf::face::set_type $idx, $info->{type}; 3620 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3621 $FACEHASH{$info->{hash}} = $idx;#d#
3475 } else { 3622 } else {
3476 $RESOURCE{$name} = $info; # unused 3623# $RESOURCE{$name} = $info; # unused
3477 } 3624 }
3478 3625
3479 cf::cede_to_tick; 3626 cf::cede_to_tick;
3480 } 3627 }
3481 } 3628 }
… …
3499 my $status = load_resource_file_ $_[0]; 3646 my $status = load_resource_file_ $_[0];
3500 get_slot 0.1, 100; 3647 get_slot 0.1, 100;
3501 cf::arch::commit_load; 3648 cf::arch::commit_load;
3502 3649
3503 $status 3650 $status
3651}
3652
3653sub reload_exp_table {
3654 _reload_exp_table;
3655
3656 set_face "res/exp_table" => FT_RSRC,
3657 JSON::XS->new->utf8->canonical->encode (
3658 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3659 );
3660}
3661
3662sub reload_materials {
3663 _reload_materials;
3504} 3664}
3505 3665
3506sub reload_regions { 3666sub reload_regions {
3507 # HACK to clear player env face cache, we need some signal framework 3667 # HACK to clear player env face cache, we need some signal framework
3508 # for this (global event?) 3668 # for this (global event?)
… …
3523} 3683}
3524 3684
3525sub reload_archetypes { 3685sub reload_archetypes {
3526 load_resource_file "$DATADIR/archetypes" 3686 load_resource_file "$DATADIR/archetypes"
3527 or die "unable to load archetypes\n"; 3687 or die "unable to load archetypes\n";
3688
3689 set_face "res/skill_info" => FT_RSRC,
3690 JSON::XS->new->utf8->canonical->encode (
3691 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3692 );
3693 set_face "res/spell_paths" => FT_RSRC,
3694 JSON::XS->new->utf8->canonical->encode (
3695 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3696 );
3528} 3697}
3529 3698
3530sub reload_treasures { 3699sub reload_treasures {
3531 load_resource_file "$DATADIR/treasures" 3700 load_resource_file "$DATADIR/treasures"
3532 or die "unable to load treasurelists\n"; 3701 or die "unable to load treasurelists\n";
3533} 3702}
3534 3703
3535sub reload_sound { 3704sub reload_sound {
3536 trace "loading sound config from $DATADIR/sound\n"; 3705 trace "loading sound config from $DATADIR/sound\n";
3537 3706
3538 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3539 or die "$DATADIR/sound $!";
3540
3541 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data); 3707 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3542 3708
3543 for (0 .. SOUND_CAST_SPELL_0 - 1) { 3709 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3544 my $sound = $soundconf->{compat}[$_] 3710 my $sound = $soundconf->{compat}[$_]
3545 or next; 3711 or next;
3546 3712
… …
3556} 3722}
3557 3723
3558sub reload_resources { 3724sub reload_resources {
3559 trace "reloading resource files...\n"; 3725 trace "reloading resource files...\n";
3560 3726
3561 reload_exp_table;
3562 reload_materials; 3727 reload_materials;
3563 reload_facedata; 3728 reload_facedata;
3729 reload_exp_table;
3564 reload_sound; 3730 reload_sound;
3565 reload_archetypes; 3731 reload_archetypes;
3566 reload_regions; 3732 reload_regions;
3567 reload_treasures; 3733 reload_treasures;
3568 3734
… …
3570} 3736}
3571 3737
3572sub reload_config { 3738sub reload_config {
3573 trace "reloading config file...\n"; 3739 trace "reloading config file...\n";
3574 3740
3575 0 < aio_load "$CONFDIR/config", my $config 3741 my $config = load_file "$CONFDIR/config";
3576 or die "$CONFDIR/config: $!";
3577
3578 utf8::decode $config; 3742 utf8::decode $config;
3579 *CFG = yaml_load $config; 3743 *CFG = decode_yaml $config;
3580 3744
3581 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38]; 3745 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3582 3746
3583 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3747 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3584 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3748 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3622 3786
3623sub main { 3787sub main {
3624 cf::init_globals; # initialise logging 3788 cf::init_globals; # initialise logging
3625 3789
3626 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3790 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3627 LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3791 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3628 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3792 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3629 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3793 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3630 3794
3631 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3795 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3632 3796
3633 # we must not ever block the main coroutine 3797 # we must not ever block the main coroutine
3634 local $Coro::idle = sub { 3798 $Coro::idle = sub {
3635 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3799 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3636 (async { 3800 (async {
3637 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3801 $Coro::current->{desc} = "IDLE BUG HANDLER";
3638 EV::loop EV::LOOP_ONESHOT; 3802 EV::loop EV::LOOP_ONESHOT;
3639 })->prio (Coro::PRIO_MAX); 3803 })->prio (Coro::PRIO_MAX);
… …
3642 evthread_start IO::AIO::poll_fileno; 3806 evthread_start IO::AIO::poll_fileno;
3643 3807
3644 cf::sync_job { 3808 cf::sync_job {
3645 cf::incloader::init (); 3809 cf::incloader::init ();
3646 3810
3811 db_init;
3812
3647 cf::init_anim; 3813 cf::init_anim;
3648 cf::init_attackmess; 3814 cf::init_attackmess;
3649 cf::init_dynamic; 3815 cf::init_dynamic;
3650 3816
3651 cf::load_settings; 3817 cf::load_settings;
3652 3818
3653 reload_resources; 3819 reload_resources;
3654 reload_config; 3820 reload_config;
3655 db_init;
3656 3821
3657 cf::init_uuid; 3822 cf::init_uuid;
3658 cf::init_signals; 3823 cf::init_signals;
3659 cf::init_skills; 3824 cf::init_skills;
3660 3825
… …
3674 }; 3839 };
3675 3840
3676 cf::object::thawer::errors_are_fatal 0; 3841 cf::object::thawer::errors_are_fatal 0;
3677 info "parse errors in files are no longer fatal from this point on.\n"; 3842 info "parse errors in files are no longer fatal from this point on.\n";
3678 3843
3679 my $free_main; $free_main = EV::idle sub { 3844 AE::postpone {
3680 undef $free_main;
3681 undef &main; # free gobs of memory :) 3845 undef &main; # free gobs of memory :)
3682 }; 3846 };
3683 3847
3684 goto &main_loop; 3848 goto &main_loop;
3685} 3849}
… …
3842 4006
3843 cf::write_runtime_sync; # external watchdog should not bark 4007 cf::write_runtime_sync; # external watchdog should not bark
3844 4008
3845 trace "emergency_perl_save: flushing outstanding aio requests"; 4009 trace "emergency_perl_save: flushing outstanding aio requests";
3846 while (IO::AIO::nreqs || BDB::nreqs) { 4010 while (IO::AIO::nreqs || BDB::nreqs) {
3847 Coro::EV::timer_once 0.01; # let the sync_job do it's thing 4011 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
3848 } 4012 }
3849 4013
3850 cf::write_runtime_sync; # external watchdog should not bark 4014 cf::write_runtime_sync; # external watchdog should not bark
3851 }; 4015 };
3852 4016
… …
4033 4197
4034############################################################################# 4198#############################################################################
4035 4199
4036my $bug_warning = 0; 4200my $bug_warning = 0;
4037 4201
4038our @WAIT_FOR_TICK;
4039our @WAIT_FOR_TICK_BEGIN;
4040
4041sub wait_for_tick() { 4202sub wait_for_tick() {
4042 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4203 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4043 4204
4044 my $signal = new Coro::Signal; 4205 $WAIT_FOR_TICK->wait;
4045 push @WAIT_FOR_TICK, $signal;
4046 $signal->wait;
4047} 4206}
4048 4207
4049sub wait_for_tick_begin() { 4208sub wait_for_tick_begin() {
4050 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4209 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4051 4210
4052 my $signal = new Coro::Signal; 4211 my $signal = new Coro::Signal;
4053 push @WAIT_FOR_TICK_BEGIN, $signal; 4212 push @WAIT_FOR_TICK_BEGIN, $signal;
4054 $signal->wait; 4213 $signal->wait;
4055} 4214}
… …
4059 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4218 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4060 unless ++$bug_warning > 10; 4219 unless ++$bug_warning > 10;
4061 return; 4220 return;
4062 } 4221 }
4063 4222
4064 cf::server_tick; # one server iteration 4223 cf::one_tick; # one server iteration
4065 4224
4066 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d# 4225 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4067 4226
4068 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4227 if ($NOW >= $NEXT_RUNTIME_WRITE) {
4069 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4228 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
… …
4075 } 4234 }
4076 4235
4077 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4236 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4078 $sig->send; 4237 $sig->send;
4079 } 4238 }
4080 while (my $sig = shift @WAIT_FOR_TICK) { 4239 $WAIT_FOR_TICK->broadcast;
4081 $sig->send;
4082 }
4083 4240
4084 $LOAD = ($NOW - $TICK_START) / $TICK; 4241 $LOAD = ($NOW - $TICK_START) / $TICK;
4085 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4242 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4086 4243
4087 if (0) { 4244 if (0) {
… …
4093 } 4250 }
4094} 4251}
4095 4252
4096{ 4253{
4097 # configure BDB 4254 # configure BDB
4255 info "initialising database";
4098 4256
4099 BDB::min_parallel 16; 4257 BDB::min_parallel 16;
4100 BDB::max_poll_reqs $TICK * 0.1; 4258 BDB::max_poll_reqs $TICK * 0.1;
4101 $AnyEvent::BDB::WATCHER->priority (1); 4259 #$AnyEvent::BDB::WATCHER->priority (1);
4102 4260
4103 unless ($DB_ENV) { 4261 unless ($DB_ENV) {
4104 $DB_ENV = BDB::db_env_create; 4262 $DB_ENV = BDB::db_env_create;
4105 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4263 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4106 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4264 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
… …
4131 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4289 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4132 }; 4290 };
4133 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4291 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4134 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4292 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4135 }; 4293 };
4294
4295 info "database initialised";
4136} 4296}
4137 4297
4138{ 4298{
4139 # configure IO::AIO 4299 # configure IO::AIO
4140 4300
4301 info "initialising aio";
4141 IO::AIO::min_parallel 8; 4302 IO::AIO::min_parallel 8;
4142 IO::AIO::max_poll_time $TICK * 0.1; 4303 IO::AIO::max_poll_time $TICK * 0.1;
4143 undef $AnyEvent::AIO::WATCHER; 4304 undef $AnyEvent::AIO::WATCHER;
4305 info "aio initialised";
4144} 4306}
4145 4307
4146our $_log_backtrace; 4308our $_log_backtrace;
4147our $_log_backtrace_last; 4309our $_log_backtrace_last;
4148 4310

Diff Legend

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