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.600 by root, Sun Nov 11 04:31:57 2012 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008,2009,2010,2011,2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify it under 6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the 7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your 8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version. 9# option) any later version.
10# 10#
11# This program is distributed in the hope that it will be useful, 11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of 12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details. 14# GNU General Public License for more details.
15# 15#
16# You should have received a copy of the Affero GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see 17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>. 18# <http://www.gnu.org/licenses/>.
19# 19#
20# The authors can be reached via e-mail to <support@deliantra.net> 20# The authors can be reached via e-mail to <support@deliantra.net>
21# 21#
22 22
23package cf; 23package cf;
24 24
… …
32use Safe; 32use Safe;
33use Safe::Hole; 33use Safe::Hole;
34use Storable (); 34use Storable ();
35use Carp (); 35use Carp ();
36 36
37use Guard (); 37use AnyEvent ();
38use AnyEvent::IO ();
39use AnyEvent::DNS ();
40
38use Coro (); 41use Coro ();
39use Coro::State; 42use Coro::State;
40use Coro::Handle; 43use Coro::Handle;
41use Coro::EV; 44use Coro::EV;
42use Coro::AnyEvent; 45use Coro::AnyEvent;
… …
48use Coro::AIO; 51use Coro::AIO;
49use Coro::BDB 1.6; 52use Coro::BDB 1.6;
50use Coro::Storable; 53use Coro::Storable;
51use Coro::Util (); 54use Coro::Util ();
52 55
56use Guard ();
53use JSON::XS 2.01 (); 57use JSON::XS 2.01 ();
54use BDB (); 58use BDB ();
55use Data::Dumper; 59use Data::Dumper;
56use Fcntl; 60use Fcntl;
57use YAML::XS (); 61use YAML::XS ();
58use IO::AIO (); 62use IO::AIO ();
59use Time::HiRes;
60use Compress::LZF; 63use Compress::LZF;
61use Digest::MD5 (); 64use Digest::MD5 ();
62 65
63AnyEvent::detect; 66AnyEvent::detect;
64 67
… …
83our %COMMAND = (); 86our %COMMAND = ();
84our %COMMAND_TIME = (); 87our %COMMAND_TIME = ();
85 88
86our @EXTS = (); # list of extension package names 89our @EXTS = (); # list of extension package names
87our %EXTCMD = (); 90our %EXTCMD = ();
91our %EXTACMD = ();
88our %EXTICMD = (); 92our %EXTICMD = ();
93our %EXTIACMD = ();
89our %EXT_CORO = (); # coroutines bound to extensions 94our %EXT_CORO = (); # coroutines bound to extensions
90our %EXT_MAP = (); # pluggable maps 95our %EXT_MAP = (); # pluggable maps
91 96
92our $RELOAD; # number of reloads so far, non-zero while in reload 97our $RELOAD; # number of reloads so far, non-zero while in reload
93our @EVENT; 98our @EVENT;
… …
108our $RANDOMDIR = "$LOCALDIR/random"; 113our $RANDOMDIR = "$LOCALDIR/random";
109our $BDBDIR = "$LOCALDIR/db"; 114our $BDBDIR = "$LOCALDIR/db";
110our $PIDFILE = "$LOCALDIR/pid"; 115our $PIDFILE = "$LOCALDIR/pid";
111our $RUNTIMEFILE = "$LOCALDIR/runtime"; 116our $RUNTIMEFILE = "$LOCALDIR/runtime";
112 117
113our %RESOURCE; # unused 118#our %RESOURCE; # unused
114 119
115our $OUTPUT_RATE_MIN = 3000; 120our $OUTPUT_RATE_MIN = 3000;
116our $OUTPUT_RATE_MAX = 1000000; 121our $OUTPUT_RATE_MAX = 1000000;
117 122
118our $MAX_LINKS = 32; # how many chained exits to follow 123our $MAX_LINKS = 32; # how many chained exits to follow
… …
129our $DB_ENV; 134our $DB_ENV;
130 135
131our @EXTRA_MODULES = qw(pod match mapscript incloader); 136our @EXTRA_MODULES = qw(pod match mapscript incloader);
132 137
133our %CFG; 138our %CFG;
139our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
134 140
135our $UPTIME; $UPTIME ||= time; 141our $UPTIME; $UPTIME ||= time;
136our $RUNTIME; 142our $RUNTIME = 0;
143our $SERVER_TICK = 0;
137our $NOW; 144our $NOW;
138 145
139our (%PLAYER, %PLAYER_LOADING); # all users 146our (%PLAYER, %PLAYER_LOADING); # all users
140our (%MAP, %MAP_LOADING ); # all maps 147our (%MAP, %MAP_LOADING ); # all maps
141our $LINK_MAP; # the special {link} map, which is always available 148our $LINK_MAP; # the special {link} map, which is always available
… …
150 157
151our @POST_INIT; 158our @POST_INIT;
152 159
153our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow) 160our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
154our $REALLY_UNLOOP; # never set to true, please :) 161our $REALLY_UNLOOP; # never set to true, please :)
162
163our $WAIT_FOR_TICK = new Coro::Signal;
164our @WAIT_FOR_TICK_BEGIN;
155 165
156binmode STDOUT; 166binmode STDOUT;
157binmode STDERR; 167binmode STDERR;
158 168
159# read virtual server time, if available 169# read virtual server time, if available
… …
193 203
194=over 4 204=over 4
195 205
196=item $cf::UPTIME 206=item $cf::UPTIME
197 207
198The timestamp of the server start (so not actually an uptime). 208The timestamp of the server start (so not actually an "uptime").
209
210=item $cf::SERVER_TICK
211
212An unsigned integer that starts at zero when the server is started and is
213incremented on every tick.
214
215=item $cf::NOW
216
217The (real) time of the last (current) server tick - updated before and
218after tick processing, so this is useful only as a rough "what time is it
219now" estimate.
220
221=item $cf::TICK
222
223The interval between each server tick, in seconds.
199 224
200=item $cf::RUNTIME 225=item $cf::RUNTIME
201 226
202The time this server has run, starts at 0 and is increased by $cf::TICK on 227The time this server has run, starts at 0 and is increased by $cf::TICK on
203every server tick. 228every server tick.
204 229
205=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR 230=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
206$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR 231$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
207$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR 232$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
208 233
209Various directories - "/etc", read-only install directory, perl-library 234Various directories - "/etc", read-only install directory, perl-library
210directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 235directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
211unique-items directory, player file directory, random maps directory and 236unique-items directory, player file directory, random maps directory and
212database environment. 237database environment.
213 238
214=item $cf::NOW
215
216The time of the last (current) server tick.
217
218=item $cf::TICK
219
220The interval between server ticks, in seconds.
221
222=item $cf::LOADAVG 239=item $cf::LOADAVG
223 240
224The current CPU load on the server (alpha-smoothed), as a value between 0 241The current CPU load on the server (alpha-smoothed), as a value between 0
225(none) and 1 (overloaded), indicating how much time is spent on processing 242(none) and 1 (overloaded), indicating how much time is spent on processing
226objects per tick. Healthy values are < 0.5. 243objects per tick. Healthy values are < 0.5.
… …
234Configuration for the server, loaded from C</etc/deliantra-server/config>, or 251Configuration for the server, loaded from C</etc/deliantra-server/config>, or
235from wherever your confdir points to. 252from wherever your confdir points to.
236 253
237=item cf::wait_for_tick, cf::wait_for_tick_begin 254=item cf::wait_for_tick, cf::wait_for_tick_begin
238 255
239These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 256These are functions that inhibit the current coroutine one tick.
240returns directly I<after> the tick processing (and consequently, can only wake one thread 257cf::wait_for_tick_begin only returns directly I<after> the tick
258processing (and consequently, can only wake one thread per tick), while
241per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 259cf::wait_for_tick wakes up all waiters after tick processing.
260
261Note that cf::wait_for_tick will immediately return when the server is not
262ticking, making it suitable for small pauses in threads that need to run
263when the server is paused. If that is not applicable (i.e. you I<really>
264want to wait, use C<$cf::WAIT_FOR_TICK>).
265
266=item $cf::WAIT_FOR_TICK
267
268Note that C<cf::wait_for_tick> is probably the correct thing to use. This
269variable contains a L<Coro::Signal> that is broadcats after every server
270tick. Calling C<< ->wait >> on it will suspend the caller until after the
271next server tick.
242 272
243=cut 273=cut
244 274
245sub wait_for_tick(); 275sub wait_for_tick();
246sub wait_for_tick_begin(); 276sub wait_for_tick_begin();
… …
312)) { 342)) {
313 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 343 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
314} 344}
315 345
316$EV::DIED = sub { 346$EV::DIED = sub {
317 Carp::cluck "error in event callback: @_"; 347 warn "error in event callback: $@";
318}; 348};
349
350#############################################################################
351
352sub fork_call(&@);
353sub get_slot($;$$);
319 354
320############################################################################# 355#############################################################################
321 356
322=head2 UTILITY FUNCTIONS 357=head2 UTILITY FUNCTIONS
323 358
… …
344 $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;
345 $d 380 $d
346 } || "[unable to dump $_[0]: '$@']"; 381 } || "[unable to dump $_[0]: '$@']";
347} 382}
348 383
384=item $scalar = cf::load_file $path
385
386Loads the given file from path and returns its contents. Croaks on error
387and can block.
388
389=cut
390
391sub load_file($) {
392 0 <= aio_load $_[0], my $data
393 or Carp::croak "$_[0]: $!";
394
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
434}
435
349=item $ref = cf::decode_json $json 436=item $ref = cf::decode_json $json
350 437
351Converts a JSON string into the corresponding perl data structure. 438Converts a JSON string into the corresponding perl data structure.
352 439
353=item $json = cf::encode_json $ref 440=item $json = cf::encode_json $ref
… …
359our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 446our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
360 447
361sub encode_json($) { $json_coder->encode ($_[0]) } 448sub encode_json($) { $json_coder->encode ($_[0]) }
362sub decode_json($) { $json_coder->decode ($_[0]) } 449sub decode_json($) { $json_coder->decode ($_[0]) }
363 450
451=item $ref = cf::decode_storable $scalar
452
453Same as Coro::Storable::thaw, so blocks.
454
455=cut
456
457BEGIN { *decode_storable = \&Coro::Storable::thaw }
458
364=item $ref = cf::yaml_load $scalar 459=item $ref = cf::decode_yaml $scalar
365 460
366Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks). 461Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
367 462
368=cut 463=cut
369 464
370sub fork_call(&@); 465sub decode_yaml($) {
371
372sub yaml_load($) {
373 fork_call { YAML::XS::Load $_[0] } @_ 466 fork_call { YAML::XS::Load $_[0] } @_
467}
468
469=item $scalar = cf::unlzf $scalar
470
471Same as Compress::LZF::compress, but takes server ticks into account, so
472blocks.
473
474=cut
475
476sub unlzf($) {
477 # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
478 cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
479 Compress::LZF::decompress $_[0]
374} 480}
375 481
376=item cf::post_init { BLOCK } 482=item cf::post_init { BLOCK }
377 483
378Execute the given codeblock, I<after> all extensions have been (re-)loaded, 484Execute the given codeblock, I<after> all extensions have been (re-)loaded,
… …
462 EV::periodic $start, $interval, 0, $cb 568 EV::periodic $start, $interval, 0, $cb
463} 569}
464 570
465=item cf::get_slot $time[, $priority[, $name]] 571=item cf::get_slot $time[, $priority[, $name]]
466 572
467Allocate $time seconds of blocking CPU time at priority C<$priority>: 573Allocate $time seconds of blocking CPU time at priority C<$priority>
468This call blocks and returns only when you have at least C<$time> seconds 574(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. 575C<$time> seconds of cpu time till the next tick. The slot is only valid
576till the next cede.
577
578Background jobs should use a priority les than zero, interactive jobs
579should use 100 or more.
470 580
471The 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
472used for statistical purposes and should identify the same time-class. 582used for statistical purposes and should identify the same time-class.
473 583
474Useful for short background jobs. 584Useful for short background jobs.
… …
503 } 613 }
504 } 614 }
505 615
506 if (@SLOT_QUEUE) { 616 if (@SLOT_QUEUE) {
507 # we do not use wait_for_tick() as it returns immediately when tick is inactive 617 # we do not use wait_for_tick() as it returns immediately when tick is inactive
508 push @cf::WAIT_FOR_TICK, $signal; 618 $WAIT_FOR_TICK->wait;
509 $signal->wait;
510 } else { 619 } else {
511 $busy = 0; 620 $busy = 0;
512 Coro::schedule; 621 Coro::schedule;
513 } 622 }
514 } 623 }
… …
769 878
770 my @data; 879 my @data;
771 my $md5; 880 my $md5;
772 881
773 for (0 .. $#$src) { 882 for (0 .. $#$src) {
774 0 <= aio_load $src->[$_], $data[$_] 883 $data[$_] = load_file $src->[$_];
775 or Carp::croak "$src->[$_]: $!";
776 } 884 }
777 885
778 # if processing is expensive, check 886 # if processing is expensive, check
779 # checksum first 887 # checksum first
780 if (1) { 888 if (1) {
… …
793 901
794 return db_get cache => "$id/data"; 902 return db_get cache => "$id/data";
795 } 903 }
796 } 904 }
797 905
798 my $t1 = Time::HiRes::time; 906 my $t1 = EV::time;
799 my $data = $process->(\@data); 907 my $data = $process->(\@data);
800 my $t2 = Time::HiRes::time; 908 my $t2 = EV::time;
801 909
802 info "cache: '$id' processed in ", $t2 - $t1, "s\n"; 910 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
803 911
804 db_put cache => "$id/data", $data; 912 db_put cache => "$id/data", $data;
805 db_put cache => "$id/md5" , $md5; 913 db_put cache => "$id/md5" , $md5;
… …
1325=cut 1433=cut
1326 1434
1327############################################################################# 1435#############################################################################
1328# command handling &c 1436# command handling &c
1329 1437
1330=item cf::register_command $name => \&callback($ob,$args); 1438=item cf::register_command $name => \&callback($ob,$args)
1331 1439
1332Register a callback for execution when the client sends the user command 1440Register a callback for execution when the client sends the user command
1333$name. 1441$name.
1334 1442
1335=cut 1443=cut
… …
1341 #warn "registering command '$name/$time' to '$caller'"; 1449 #warn "registering command '$name/$time' to '$caller'";
1342 1450
1343 push @{ $COMMAND{$name} }, [$caller, $cb]; 1451 push @{ $COMMAND{$name} }, [$caller, $cb];
1344} 1452}
1345 1453
1346=item cf::register_extcmd $name => \&callback($pl,$packet); 1454=item cf::register_extcmd $name => \&callback($pl,@args)
1347 1455
1348Register a callback for execution when the client sends an (synchronous) 1456Register a callback for execution when the client sends an (synchronous)
1349extcmd packet. Ext commands will be processed in the order they are 1457extcmd packet. Ext commands will be processed in the order they are
1350received by the server, like other user commands. The first argument is 1458received by the server, like other user commands. The first argument is
1351the logged-in player. Ext commands can only be processed after a player 1459the logged-in player. Ext commands can only be processed after a player
1352has logged in successfully. 1460has logged in successfully.
1353 1461
1354If the callback returns something, it is sent back as if reply was being 1462The values will be sent back to the client.
1355called.
1356 1463
1464=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
1465
1466Same as C<cf::register_extcmd>, but instead of returning values, the
1467callback needs to clal the C<$reply> function.
1468
1357=item cf::register_exticmd $name => \&callback($ns,$packet); 1469=item cf::register_exticmd $name => \&callback($ns,@args)
1358 1470
1359Register a callback for execution when the client sends an (asynchronous) 1471Register a callback for execution when the client sends an (asynchronous)
1360exticmd packet. Exti commands are processed by the server as soon as they 1472exticmd 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 1473are 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 1474is a client socket. Exti commands can be received anytime, even before
1363log-in. 1475log-in.
1364 1476
1365If the callback returns something, it is sent back as if reply was being 1477The values will be sent back to the client.
1366called.
1367 1478
1368=cut 1479=item cf::register_async_exticmd $name => \&callback($ns,$reply->(...),@args)
1369 1480
1481Same as C<cf::register_extcmd>, but instead of returning values, the
1482callback needs to clal the C<$reply> function.
1483
1484=cut
1485
1370sub register_extcmd { 1486sub register_extcmd($$) {
1371 my ($name, $cb) = @_; 1487 my ($name, $cb) = @_;
1372 1488
1373 $EXTCMD{$name} = $cb; 1489 $EXTCMD{$name} = $cb;
1374} 1490}
1375 1491
1376sub register_exticmd { 1492sub register_async_extcmd($$) {
1377 my ($name, $cb) = @_; 1493 my ($name, $cb) = @_;
1378 1494
1495 $EXTACMD{$name} = $cb;
1496}
1497
1498sub register_exticmd($$) {
1499 my ($name, $cb) = @_;
1500
1379 $EXTICMD{$name} = $cb; 1501 $EXTICMD{$name} = $cb;
1502}
1503
1504sub register_async_exticmd($$) {
1505 my ($name, $cb) = @_;
1506
1507 $EXTIACMD{$name} = $cb;
1380} 1508}
1381 1509
1382use File::Glob (); 1510use File::Glob ();
1383 1511
1384cf::player->attach ( 1512cf::player->attach (
… …
1398 my ($pl, $buf) = @_; 1526 my ($pl, $buf) = @_;
1399 1527
1400 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1528 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1401 1529
1402 if (ref $msg) { 1530 if (ref $msg) {
1403 my ($type, $reply, @payload) = 1531 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 1532
1408 my @reply;
1409
1410 if (my $cb = $EXTCMD{$type}) { 1533 if (my $cb = $EXTACMD{$type}) {
1534 $cb->(
1535 $pl,
1536 sub {
1537 $pl->ext_msg ("reply-$reply", @_)
1538 if $reply;
1539 },
1540 @payload
1541 );
1542 } else {
1543 my @reply;
1544
1545 if (my $cb = $EXTCMD{$type}) {
1411 @reply = $cb->($pl, @payload); 1546 @reply = $cb->($pl, @payload);
1547 }
1548
1549 $pl->ext_msg ("reply-$reply", @reply)
1550 if $reply;
1412 } 1551 }
1413
1414 $pl->ext_reply ($reply, @reply)
1415 if $reply;
1416 1552
1417 } else { 1553 } else {
1418 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1554 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1419 } 1555 }
1420 1556
… …
1433 }; 1569 };
1434 1570
1435 $grp 1571 $grp
1436} 1572}
1437 1573
1574sub _ext_cfg_reg($$$$) {
1575 my ($rvar, $varname, $cfgname, $default) = @_;
1576
1577 $cfgname = lc $varname
1578 unless length $cfgname;
1579
1580 $EXT_CFG{$cfgname} = [$rvar, $default];
1581
1582 $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
1583}
1584
1438sub load_extensions { 1585sub load_extensions {
1439 info "loading extensions..."; 1586 info "loading extensions...";
1587
1588 %EXT_CFG = ();
1440 1589
1441 cf::sync_job { 1590 cf::sync_job {
1442 my %todo; 1591 my %todo;
1443 1592
1444 for my $path (<$LIBDIR/*.ext>) { 1593 for my $path (<$LIBDIR/*.ext>) {
… …
1487 unless exists $done{$_}; 1636 unless exists $done{$_};
1488 } 1637 }
1489 1638
1490 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n"; 1639 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1491 1640
1641 my $source = $v->{source};
1642
1643 # support "CONF varname :confname = default" pseudo-statements
1644 $source =~ s{
1645 ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
1646 }{
1647 "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
1648 }gmxe;
1649
1492 my $active = eval $v->{source}; 1650 my $active = eval $source;
1493 1651
1494 if (length $@) { 1652 if (length $@) {
1495 error "$v->{path}: $@\n"; 1653 error "$v->{path}: $@\n";
1496 1654
1497 cf::cleanup "mandatory extension '$k' failed to load, exiting." 1655 cf::cleanup "mandatory extension '$k' failed to load, exiting."
… …
1514 1672
1515 while (my ($k, $v) = each %todo) { 1673 while (my ($k, $v) = each %todo) {
1516 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting." 1674 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1517 if exists $v->{meta}{mandatory}; 1675 if exists $v->{meta}{mandatory};
1518 } 1676 }
1677
1678 last;
1519 } 1679 }
1520 } 1680 }
1521 }; 1681 };
1522} 1682}
1523 1683
… …
1782} 1942}
1783 1943
1784=item $protocol_xml = $player->expand_cfpod ($cfpod) 1944=item $protocol_xml = $player->expand_cfpod ($cfpod)
1785 1945
1786Expand deliantra pod fragments into protocol xml. 1946Expand 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 1947
1800=item $player->ext_msg ($type, @msg) 1948=item $player->ext_msg ($type, @msg)
1801 1949
1802Sends an ext event to the client. 1950Sends an ext event to the client.
1803 1951
… …
1951 2099
1952 Carp::cluck "unable to resolve path '$path' (base '$base')"; 2100 Carp::cluck "unable to resolve path '$path' (base '$base')";
1953 () 2101 ()
1954} 2102}
1955 2103
2104# may re-bless or do other evil things
1956sub init { 2105sub init {
1957 my ($self) = @_; 2106 my ($self) = @_;
1958 2107
1959 $self 2108 $self
1960} 2109}
… …
2025 $self->{load_path} = $path; 2174 $self->{load_path} = $path;
2026 2175
2027 1 2176 1
2028} 2177}
2029 2178
2179# used to laod the header of an original map
2030sub load_header_orig { 2180sub load_header_orig {
2031 my ($self) = @_; 2181 my ($self) = @_;
2032 2182
2033 $self->load_header_from ($self->load_path) 2183 $self->load_header_from ($self->load_path)
2034} 2184}
2035 2185
2186# used to laod the header of an instantiated map
2036sub load_header_temp { 2187sub load_header_temp {
2037 my ($self) = @_; 2188 my ($self) = @_;
2038 2189
2039 $self->load_header_from ($self->save_path) 2190 $self->load_header_from ($self->save_path)
2040} 2191}
2041 2192
2193# called after loading the header from an instantiated map
2042sub prepare_temp { 2194sub prepare_temp {
2043 my ($self) = @_; 2195 my ($self) = @_;
2044 2196
2045 $self->last_access ((delete $self->{last_access}) 2197 $self->last_access ((delete $self->{last_access})
2046 || $cf::RUNTIME); #d# 2198 || $cf::RUNTIME); #d#
2047 # safety 2199 # safety
2048 $self->{instantiate_time} = $cf::RUNTIME 2200 $self->{instantiate_time} = $cf::RUNTIME
2049 if $self->{instantiate_time} > $cf::RUNTIME; 2201 if $self->{instantiate_time} > $cf::RUNTIME;
2050} 2202}
2051 2203
2204# called after loading the header from an original map
2052sub prepare_orig { 2205sub prepare_orig {
2053 my ($self) = @_; 2206 my ($self) = @_;
2054 2207
2055 $self->{load_original} = 1; 2208 $self->{load_original} = 1;
2056 $self->{instantiate_time} = $cf::RUNTIME; 2209 $self->{instantiate_time} = $cf::RUNTIME;
… …
2082sub find { 2235sub find {
2083 my ($path, $origin) = @_; 2236 my ($path, $origin) = @_;
2084 2237
2085 cf::cede_to_tick; 2238 cf::cede_to_tick;
2086 2239
2087 $path = normalise $path, $origin && $origin->path; 2240 $path = normalise $path, $origin;
2088 2241
2089 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2242 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2090 my $guard2 = cf::lock_acquire "map_find:$path"; 2243 my $guard2 = cf::lock_acquire "map_find:$path";
2091 2244
2092 $cf::MAP{$path} || do { 2245 $cf::MAP{$path} || do {
… …
2123 2276
2124 { 2277 {
2125 my $guard = cf::lock_acquire "map_data:$path"; 2278 my $guard = cf::lock_acquire "map_data:$path";
2126 2279
2127 return unless $self->valid; 2280 return unless $self->valid;
2128 return unless $self->in_memory == cf::MAP_SWAPPED; 2281 return unless $self->state == cf::MAP_SWAPPED;
2129
2130 $self->in_memory (cf::MAP_LOADING);
2131 2282
2132 $self->alloc; 2283 $self->alloc;
2133 2284
2134 $self->pre_load; 2285 $self->pre_load;
2135 cf::cede_to_tick; 2286 cf::cede_to_tick;
2136 2287
2288 if (exists $self->{load_path}) {
2137 my $f = new_from_file cf::object::thawer $self->{load_path}; 2289 my $f = new_from_file cf::object::thawer $self->{load_path};
2138 $f->skip_block; 2290 $f->skip_block;
2139 $self->_load_objects ($f) 2291 $self->_load_objects ($f)
2140 or return; 2292 or return;
2141 2293
2142 $self->post_load_original 2294 $self->post_load_original
2143 if delete $self->{load_original}; 2295 if delete $self->{load_original};
2144 2296
2145 if (my $uniq = $self->uniq_path) { 2297 if (my $uniq = $self->uniq_path) {
2146 utf8::encode $uniq; 2298 utf8::encode $uniq;
2147 unless (aio_stat $uniq) { 2299 unless (aio_stat $uniq) {
2148 if (my $f = new_from_file cf::object::thawer $uniq) { 2300 if (my $f = new_from_file cf::object::thawer $uniq) {
2149 $self->clear_unique_items; 2301 $self->clear_unique_items;
2150 $self->_load_objects ($f); 2302 $self->_load_objects ($f);
2151 $f->resolve_delayed_derefs; 2303 $f->resolve_delayed_derefs;
2304 }
2152 } 2305 }
2153 } 2306 }
2154 }
2155 2307
2156 $f->resolve_delayed_derefs; 2308 $f->resolve_delayed_derefs;
2309 } else {
2310 $self->post_load_original
2311 if delete $self->{load_original};
2312 }
2313
2314 $self->state (cf::MAP_INACTIVE);
2157 2315
2158 cf::cede_to_tick; 2316 cf::cede_to_tick;
2159 # now do the right thing for maps 2317 # now do the right thing for maps
2160 $self->link_multipart_objects; 2318 $self->link_multipart_objects;
2161 $self->difficulty ($self->estimate_difficulty) 2319 $self->difficulty ($self->estimate_difficulty)
… …
2165 unless ($self->{deny_activate}) { 2323 unless ($self->{deny_activate}) {
2166 $self->decay_objects; 2324 $self->decay_objects;
2167 $self->fix_auto_apply; 2325 $self->fix_auto_apply;
2168 $self->update_buttons; 2326 $self->update_buttons;
2169 cf::cede_to_tick; 2327 cf::cede_to_tick;
2170 $self->activate; 2328 #$self->activate; # no longer activate maps automatically
2171 } 2329 }
2172 2330
2173 $self->{last_save} = $cf::RUNTIME; 2331 $self->{last_save} = $cf::RUNTIME;
2174 $self->last_access ($cf::RUNTIME); 2332 $self->last_access ($cf::RUNTIME);
2175
2176 $self->in_memory (cf::MAP_ACTIVE);
2177 } 2333 }
2178 2334
2179 $self->post_load; 2335 $self->post_load;
2180 2336
2181 1 2337 1
… …
2194# if $self->per_party; 2350# if $self->per_party;
2195 2351
2196 $self 2352 $self
2197} 2353}
2198 2354
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 { 2355sub find_sync {
2227 my ($path, $origin) = @_; 2356 my ($path, $origin) = @_;
2228 2357
2358 # it's a bug to call this from the main context
2229 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync" 2359 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2230 if $Coro::current == $Coro::main; 2360 if $Coro::current == $Coro::main;
2231 2361
2232 find $path, $origin 2362 find $path, $origin
2233} 2363}
2234 2364
2235sub do_load_sync { 2365sub do_load_sync {
2236 my ($map) = @_; 2366 my ($map) = @_;
2237 2367
2368 # it's a bug to call this from the main context
2238 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync" 2369 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2239 if $Coro::current == $Coro::main; 2370 if $Coro::current == $Coro::main;
2240 2371
2241 $map->load; 2372 $map->load;
2242} 2373}
… …
2245our $MAP_PREFETCHER = undef; 2376our $MAP_PREFETCHER = undef;
2246 2377
2247sub find_async { 2378sub find_async {
2248 my ($path, $origin, $load) = @_; 2379 my ($path, $origin, $load) = @_;
2249 2380
2250 $path = normalise $path, $origin && $origin->{path}; 2381 $path = normalise $path, $origin;
2251 2382
2252 if (my $map = $cf::MAP{$path}) { 2383 if (my $map = $cf::MAP{$path}) {
2253 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2384 return $map if !$load || $map->linkable;
2254 } 2385 }
2255 2386
2256 $MAP_PREFETCH{$path} |= $load; 2387 $MAP_PREFETCH{$path} |= $load;
2257 2388
2258 $MAP_PREFETCHER ||= cf::async { 2389 $MAP_PREFETCHER ||= cf::async {
… …
2317sub swap_out { 2448sub swap_out {
2318 my ($self) = @_; 2449 my ($self) = @_;
2319 2450
2320 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2451 my $lock = cf::lock_acquire "map_data:$self->{path}";
2321 2452
2322 return if $self->in_memory != cf::MAP_ACTIVE; 2453 return if !$self->linkable;
2323 return if $self->{deny_save}; 2454 return if $self->{deny_save};
2324 return if $self->players; 2455 return if $self->players;
2325 2456
2326 # first deactivate the map and "unlink" it from the core 2457 # first deactivate the map and "unlink" it from the core
2327 $self->deactivate; 2458 $self->deactivate;
2328 $_->clear_links_to ($self) for values %cf::MAP; 2459 $_->clear_links_to ($self) for values %cf::MAP;
2329 $self->in_memory (cf::MAP_SWAPPED); 2460 $self->state (cf::MAP_SWAPPED);
2330 2461
2331 # then atomically save 2462 # then atomically save
2332 $self->_save; 2463 $self->_save;
2333 2464
2334 # then free the map 2465 # then free the map
… …
2360 2491
2361 return if $self->players; 2492 return if $self->players;
2362 2493
2363 cf::trace "resetting map ", $self->path, "\n"; 2494 cf::trace "resetting map ", $self->path, "\n";
2364 2495
2365 $self->in_memory (cf::MAP_SWAPPED); 2496 $self->state (cf::MAP_SWAPPED);
2366 2497
2367 # need to save uniques path 2498 # need to save uniques path
2368 unless ($self->{deny_save}) { 2499 unless ($self->{deny_save}) {
2369 my $uniq = $self->uniq_path; utf8::encode $uniq; 2500 my $uniq = $self->uniq_path; utf8::encode $uniq;
2370 2501
… …
2700 # use -1 or undef as default coordinates, not 0, 0 2831 # use -1 or undef as default coordinates, not 0, 0
2701 ($x, $y) = ($map->enter_x, $map->enter_y) 2832 ($x, $y) = ($map->enter_x, $map->enter_y)
2702 if $x <= 0 && $y <= 0; 2833 if $x <= 0 && $y <= 0;
2703 2834
2704 $map->load; 2835 $map->load;
2705 $map->load_neighbours;
2706 2836
2707 return unless $self->contr->active; 2837 return unless $self->contr->active;
2708 2838
2709 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2839 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2710 if ($self->enter_map ($map, $x, $y)) { 2840 if ($self->enter_map ($map, $x, $y)) {
… …
2766 ($path, $x, $y) = (undef, undef, undef); 2896 ($path, $x, $y) = (undef, undef, undef);
2767 } 2897 }
2768 } 2898 }
2769 2899
2770 my $map = eval { 2900 my $map = eval {
2771 my $map = defined $path ? cf::map::find $path : undef; 2901 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2772 2902
2773 if ($map) { 2903 if ($map) {
2774 $map = $map->customise_for ($self); 2904 $map = $map->customise_for ($self);
2775 $map = $check->($map, $x, $y, $self) if $check && $map; 2905 $map = $check->($map, $x, $y, $self) if $check && $map;
2776 } else { 2906 } else {
… …
2866 $Coro::current->{desc} = "enter_exit"; 2996 $Coro::current->{desc} = "enter_exit";
2867 2997
2868 unless (eval { 2998 unless (eval {
2869 $self->deactivate_recursive; # just to be sure 2999 $self->deactivate_recursive; # just to be sure
2870 3000
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; 3001 my $map = cf::map::normalise $exit->slaying, $exit->map;
2880 my $x = $exit->stats->hp; 3002 my $x = $exit->stats->hp;
2881 my $y = $exit->stats->sp; 3003 my $y = $exit->stats->sp;
3004
3005 # special map handling
3006 my $slaying = $exit->slaying;
3007
3008 # special map handling
3009 if ($slaying eq "/!") {
3010 my $guard = cf::lock_acquire "exit_prepare:$exit";
3011
3012 prepare_random_map $exit
3013 if $exit->slaying eq "/!"; # need to re-check after getting the lock
3014
3015 $map = $exit->slaying;
3016
3017 } elsif ($slaying eq '!up') {
3018 $map = $exit->map->tile_path (cf::TILE_UP);
3019 $x = $exit->x;
3020 $y = $exit->y;
3021
3022 } elsif ($slaying eq '!down') {
3023 $map = $exit->map->tile_path (cf::TILE_DOWN);
3024 $x = $exit->x;
3025 $y = $exit->y;
3026 }
2882 3027
2883 $self->goto ($map, $x, $y); 3028 $self->goto ($map, $x, $y);
2884 3029
2885 # if exit is damned, update players death & WoR home-position 3030 # if exit is damned, update players death & WoR home-position
2886 $self->contr->savebed ($map, $x, $y) 3031 $self->contr->savebed ($map, $x, $y)
… …
3111=cut 3256=cut
3112 3257
3113sub cf::client::ext_msg($$@) { 3258sub cf::client::ext_msg($$@) {
3114 my ($self, $type, @msg) = @_; 3259 my ($self, $type, @msg) = @_;
3115 3260
3116 if ($self->extcmd == 2) {
3117 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3261 $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} 3262}
3141 3263
3142=item $success = $client->query ($flags, "text", \&cb) 3264=item $success = $client->query ($flags, "text", \&cb)
3143 3265
3144Queues a query to the client, calling the given callback with 3266Queues a query to the client, calling the given callback with
… …
3199 my ($ns, $buf) = @_; 3321 my ($ns, $buf) = @_;
3200 3322
3201 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3323 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3202 3324
3203 if (ref $msg) { 3325 if (ref $msg) {
3204 my ($type, $reply, @payload) = 3326 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 3327
3209 my @reply;
3210
3211 if (my $cb = $EXTICMD{$type}) { 3328 if (my $cb = $EXTIACMD{$type}) {
3329 $cb->(
3330 $ns,
3331 sub {
3332 $ns->ext_msg ("reply-$reply", @_)
3333 if $reply;
3334 },
3335 @payload
3336 );
3337 } else {
3338 my @reply;
3339
3340 if (my $cb = $EXTICMD{$type}) {
3212 @reply = $cb->($ns, @payload); 3341 @reply = $cb->($ns, @payload);
3342 }
3343
3344 $ns->ext_msg ("reply-$reply", @reply)
3345 if $reply;
3213 } 3346 }
3214
3215 $ns->ext_reply ($reply, @reply)
3216 if $reply;
3217
3218 } else { 3347 } else {
3219 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3348 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3220 } 3349 }
3221 3350
3222 cf::override; 3351 cf::override;
… …
3390=cut 3519=cut
3391 3520
3392############################################################################# 3521#############################################################################
3393# the server's init and main functions 3522# the server's init and main functions
3394 3523
3524our %FACEHASH; # hash => idx, #d# HACK for http server
3525our @FACEDATA; # dynamically-created facedata
3526
3527# internal api, not fianlised
3528sub set_face {
3529 my ($name, $type, $data) = @_;
3530
3531 my $idx = cf::face::find $name;
3532
3533 if ($idx) {
3534 delete $FACEHASH{cf::face::get_chksum $idx};
3535 } else {
3536 $idx = cf::face::alloc $name;
3537 }
3538
3539 my $hash = cf::face::mangle_chksum Digest::MD5::md5 $data;
3540
3541 cf::face::set_type $idx, $type;
3542 cf::face::set_data $idx, 0, (length $data), 0, $hash;
3543 cf::face::set_meta $idx, $type & 1 ? undef : undef;
3544
3545 # we need to destroy the SV itself, not just overwrite,
3546 # as a running ix might hold a reference to it.
3547 # delete achieves that.
3548 delete $FACEDATA[$idx];
3549 $FACEDATA[$idx] = $data;
3550 $FACEHASH{$hash} = $idx;#d#
3551
3552 $idx
3553}
3554
3555our $FACEDATA; # facedata filehandle
3556
3557sub _face_get_data($$$$) {
3558 my ($idx, $size, $fofs, $cb) = @_;
3559
3560 if (defined $FACEDATA[$idx]) {
3561 $cb->($FACEDATA[$idx]);
3562 } elsif ($fofs) {
3563 my $buf;
3564 IO::AIO::aio_read $FACEDATA, $fofs, $size, $buf, 0, sub {
3565 if ($_[0] == $size) {
3566 #cf::debug "read face $idx, $size from $fofs as ", length $buf;#d#
3567 $cb->($buf);
3568 } else {
3569 cf::error "INTERNAL ERROR: unable to read facedata for face $idx ($size, $fofs), ignoring request.";
3570 }
3571 };
3572 } else {
3573 cf::error "requested facedata for unknown face $idx ($size, $fofs), ignoring.";
3574 }
3575}
3576
3577# rather ineffient
3578sub cf::face::get_data($;$) {
3579 my ($idx, $faceset) = @_;
3580
3581 my $size = cf::face::get_size $idx, $faceset;
3582 my $fofs = cf::face::get_fofs $idx, $faceset;
3583
3584 _face_get_data $idx, $size, $fofs, Coro::rouse_cb;
3585 Coro::rouse_wait
3586}
3587
3588sub cf::face::ix {
3589 my ($ns, $idx, $pri, $size, $fofs) = @_;
3590
3591 _face_get_data $idx, $size, $fofs, sub {
3592 $ns->ix_send ($idx, $pri, $_[0]);
3593 };
3594}
3595
3395sub load_facedata($) { 3596sub load_facedata($) {
3396 my ($path) = @_; 3597 my ($path) = @_;
3397 3598
3398 # HACK to clear player env face cache, we need some signal framework
3399 # for this (global event?)
3400 %ext::player_env::MUSIC_FACE_CACHE = ();
3401
3402 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3599 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3403 3600
3404 trace "loading facedata from $path\n"; 3601 trace "loading facedata from $path\n";
3405 3602
3406 0 < aio_load $path, my $facedata 3603 my $facedata = decode_storable load_file "$path/faceinfo";
3407 or die "$path: $!";
3408
3409 $facedata = Coro::Storable::thaw $facedata;
3410 3604
3411 $facedata->{version} == 2 3605 $facedata->{version} == 2
3412 or cf::cleanup "$path: version mismatch, cannot proceed."; 3606 or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";
3413 3607
3414 # patch in the exptable 3608 my $fh = aio_open "$DATADIR/facedata", IO::AIO::O_RDONLY, 0
3415 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]); 3609 or cf::cleanup "$path/facedata: $!, cnanot proceed.";
3416 $facedata->{resource}{"res/exp_table"} = { 3610
3417 type => FT_RSRC, 3611 get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
3418 data => $exp_table, 3612
3419 hash => (Digest::MD5::md5 $exp_table), 3613 # BEGIN ATOMIC
3420 }; 3614 # from here on, everything must be atomic - no thread switch allowed
3421 cf::cede_to_tick; 3615 my $t1 = EV::time;
3422 3616
3423 { 3617 {
3424 my $faces = $facedata->{faceinfo}; 3618 my $faces = $facedata->{faceinfo};
3425 3619
3426 while (my ($face, $info) = each %$faces) { 3620 for my $face (sort keys %$faces) {
3621 my $info = $faces->{$face};
3427 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3622 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3428 3623
3429 cf::face::set_visibility $idx, $info->{visibility}; 3624 cf::face::set_visibility $idx, $info->{visibility};
3430 cf::face::set_magicmap $idx, $info->{magicmap}; 3625 cf::face::set_magicmap $idx, $info->{magicmap};
3431 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3626 cf::face::set_data $idx, 0, $info->{size32}, $info->{fofs32}, $info->{hash32};
3432 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3627 cf::face::set_data $idx, 1, $info->{size64}, $info->{fofs64}, $info->{hash64};
3433 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ; 3628 #cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph}; # glyphs no longer downloadable via ix
3434 3629 $FACEHASH{$info->{hash64}} = $idx;#d#
3435 cf::cede_to_tick;
3436 } 3630 }
3437 3631
3438 while (my ($face, $info) = each %$faces) { 3632 while (my ($face, $info) = each %$faces) {
3439 next unless $info->{smooth}; 3633 next unless $info->{smooth};
3440 3634
… …
3445 cf::face::set_smooth $idx, $smooth; 3639 cf::face::set_smooth $idx, $smooth;
3446 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3640 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3447 } else { 3641 } else {
3448 error "smooth face '$info->{smooth}' not found for face '$face'"; 3642 error "smooth face '$info->{smooth}' not found for face '$face'";
3449 } 3643 }
3450
3451 cf::cede_to_tick;
3452 } 3644 }
3453 } 3645 }
3454 3646
3455 { 3647 {
3456 my $anims = $facedata->{animinfo}; 3648 my $anims = $facedata->{animinfo};
3457 3649
3458 while (my ($anim, $info) = each %$anims) { 3650 while (my ($anim, $info) = each %$anims) {
3459 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3651 cf::anim::set $anim, $info->{frames}, $info->{facings};
3460 cf::cede_to_tick;
3461 } 3652 }
3462 3653
3463 cf::anim::invalidate_all; # d'oh 3654 cf::anim::invalidate_all; # d'oh
3464 } 3655 }
3465 3656
3466 { 3657 {
3467 my $res = $facedata->{resource}; 3658 my $res = $facedata->{resource};
3468 3659
3469 while (my ($name, $info) = each %$res) { 3660 while (my ($name, $info) = each %$res) {
3470 if (defined $info->{type}) { 3661 if (defined (my $type = $info->{type})) {
3662 # 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; 3663 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3472 3664
3473 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3474 cf::face::set_type $idx, $info->{type}; 3665 cf::face::set_type $idx, $type;
3666 cf::face::set_data $idx, 0, $info->{size}, $info->{fofs}, $info->{hash};
3667 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3668 $FACEHASH{$info->{hash}} = $idx;#d#
3475 } else { 3669 } else {
3476 $RESOURCE{$name} = $info; # unused 3670# $RESOURCE{$name} = $info; # unused
3477 } 3671 }
3478
3479 cf::cede_to_tick;
3480 } 3672 }
3481 } 3673 }
3674
3675 ($fh, $FACEDATA) = ($FACEDATA, $fh);
3676
3677 # HACK to clear player env face cache, we need some signal framework
3678 # for this (global event?)
3679 %ext::player_env::MUSIC_FACE_CACHE = ();
3680
3681 # END ATOMIC
3682
3683 cf::debug "facedata atomic update time ", EV::time - $t1;
3482 3684
3483 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3685 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3686
3687 aio_close $fh if $fh; # close old facedata
3484 3688
3485 1 3689 1
3486} 3690}
3487 3691
3488register_exticmd fx_want => sub { 3692register_exticmd fx_want => sub {
… …
3499 my $status = load_resource_file_ $_[0]; 3703 my $status = load_resource_file_ $_[0];
3500 get_slot 0.1, 100; 3704 get_slot 0.1, 100;
3501 cf::arch::commit_load; 3705 cf::arch::commit_load;
3502 3706
3503 $status 3707 $status
3708}
3709
3710sub reload_exp_table {
3711 _reload_exp_table;
3712
3713 set_face "res/exp_table" => FT_RSRC,
3714 JSON::XS->new->utf8->canonical->encode (
3715 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3716 );
3717}
3718
3719sub reload_materials {
3720 _reload_materials;
3504} 3721}
3505 3722
3506sub reload_regions { 3723sub reload_regions {
3507 # HACK to clear player env face cache, we need some signal framework 3724 # HACK to clear player env face cache, we need some signal framework
3508 # for this (global event?) 3725 # for this (global event?)
… …
3516 if exists $_->{match}; 3733 if exists $_->{match};
3517 } 3734 }
3518} 3735}
3519 3736
3520sub reload_facedata { 3737sub reload_facedata {
3521 load_facedata "$DATADIR/facedata" 3738 load_facedata $DATADIR
3522 or die "unable to load facedata\n"; 3739 or die "unable to load facedata\n";
3523} 3740}
3524 3741
3525sub reload_archetypes { 3742sub reload_archetypes {
3526 load_resource_file "$DATADIR/archetypes" 3743 load_resource_file "$DATADIR/archetypes"
3527 or die "unable to load archetypes\n"; 3744 or die "unable to load archetypes\n";
3745
3746 set_face "res/skill_info" => FT_RSRC,
3747 JSON::XS->new->utf8->canonical->encode (
3748 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3749 );
3750 set_face "res/spell_paths" => FT_RSRC,
3751 JSON::XS->new->utf8->canonical->encode (
3752 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3753 );
3528} 3754}
3529 3755
3530sub reload_treasures { 3756sub reload_treasures {
3531 load_resource_file "$DATADIR/treasures" 3757 load_resource_file "$DATADIR/treasures"
3532 or die "unable to load treasurelists\n"; 3758 or die "unable to load treasurelists\n";
3533} 3759}
3534 3760
3535sub reload_sound { 3761sub reload_sound {
3536 trace "loading sound config from $DATADIR/sound\n"; 3762 trace "loading sound config from $DATADIR/sound\n";
3537 3763
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); 3764 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3542 3765
3543 for (0 .. SOUND_CAST_SPELL_0 - 1) { 3766 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3544 my $sound = $soundconf->{compat}[$_] 3767 my $sound = $soundconf->{compat}[$_]
3545 or next; 3768 or next;
3546 3769
… …
3556} 3779}
3557 3780
3558sub reload_resources { 3781sub reload_resources {
3559 trace "reloading resource files...\n"; 3782 trace "reloading resource files...\n";
3560 3783
3561 reload_exp_table;
3562 reload_materials; 3784 reload_materials;
3563 reload_facedata; 3785 reload_facedata;
3786 reload_exp_table;
3564 reload_sound; 3787 reload_sound;
3565 reload_archetypes; 3788 reload_archetypes;
3566 reload_regions; 3789 reload_regions;
3567 reload_treasures; 3790 reload_treasures;
3568 3791
… …
3570} 3793}
3571 3794
3572sub reload_config { 3795sub reload_config {
3573 trace "reloading config file...\n"; 3796 trace "reloading config file...\n";
3574 3797
3575 0 < aio_load "$CONFDIR/config", my $config 3798 my $config = load_file "$CONFDIR/config";
3576 or die "$CONFDIR/config: $!";
3577
3578 utf8::decode $config; 3799 utf8::decode $config;
3579 *CFG = yaml_load $config; 3800 *CFG = decode_yaml $config;
3580 3801
3581 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38]; 3802 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3582 3803
3583 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3804 $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}; 3805 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3622 3843
3623sub main { 3844sub main {
3624 cf::init_globals; # initialise logging 3845 cf::init_globals; # initialise logging
3625 3846
3626 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3847 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3627 LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3848 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3628 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3849 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3629 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3850 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3630 3851
3631 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3852 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3632 3853
3633 # we must not ever block the main coroutine 3854 # we must not ever block the main coroutine
3634 local $Coro::idle = sub { 3855 $Coro::idle = sub {
3635 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3856 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3636 (async { 3857 (async {
3637 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3858 $Coro::current->{desc} = "IDLE BUG HANDLER";
3638 EV::loop EV::LOOP_ONESHOT; 3859 EV::loop EV::LOOP_ONESHOT;
3639 })->prio (Coro::PRIO_MAX); 3860 })->prio (Coro::PRIO_MAX);
… …
3642 evthread_start IO::AIO::poll_fileno; 3863 evthread_start IO::AIO::poll_fileno;
3643 3864
3644 cf::sync_job { 3865 cf::sync_job {
3645 cf::incloader::init (); 3866 cf::incloader::init ();
3646 3867
3868 db_init;
3869
3647 cf::init_anim; 3870 cf::init_anim;
3648 cf::init_attackmess; 3871 cf::init_attackmess;
3649 cf::init_dynamic; 3872 cf::init_dynamic;
3650 3873
3651 cf::load_settings; 3874 cf::load_settings;
3652 3875
3653 reload_resources; 3876 reload_resources;
3654 reload_config; 3877 reload_config;
3655 db_init;
3656 3878
3657 cf::init_uuid; 3879 cf::init_uuid;
3658 cf::init_signals; 3880 cf::init_signals;
3659 cf::init_skills; 3881 cf::init_skills;
3660 3882
… …
3674 }; 3896 };
3675 3897
3676 cf::object::thawer::errors_are_fatal 0; 3898 cf::object::thawer::errors_are_fatal 0;
3677 info "parse errors in files are no longer fatal from this point on.\n"; 3899 info "parse errors in files are no longer fatal from this point on.\n";
3678 3900
3679 my $free_main; $free_main = EV::idle sub { 3901 AE::postpone {
3680 undef $free_main;
3681 undef &main; # free gobs of memory :) 3902 undef &main; # free gobs of memory :)
3682 }; 3903 };
3683 3904
3684 goto &main_loop; 3905 goto &main_loop;
3685} 3906}
… …
3842 4063
3843 cf::write_runtime_sync; # external watchdog should not bark 4064 cf::write_runtime_sync; # external watchdog should not bark
3844 4065
3845 trace "emergency_perl_save: flushing outstanding aio requests"; 4066 trace "emergency_perl_save: flushing outstanding aio requests";
3846 while (IO::AIO::nreqs || BDB::nreqs) { 4067 while (IO::AIO::nreqs || BDB::nreqs) {
3847 Coro::EV::timer_once 0.01; # let the sync_job do it's thing 4068 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
3848 } 4069 }
3849 4070
3850 cf::write_runtime_sync; # external watchdog should not bark 4071 cf::write_runtime_sync; # external watchdog should not bark
3851 }; 4072 };
3852 4073
… …
4033 4254
4034############################################################################# 4255#############################################################################
4035 4256
4036my $bug_warning = 0; 4257my $bug_warning = 0;
4037 4258
4038our @WAIT_FOR_TICK;
4039our @WAIT_FOR_TICK_BEGIN;
4040
4041sub wait_for_tick() { 4259sub wait_for_tick() {
4042 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4260 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4043 4261
4044 my $signal = new Coro::Signal; 4262 $WAIT_FOR_TICK->wait;
4045 push @WAIT_FOR_TICK, $signal;
4046 $signal->wait;
4047} 4263}
4048 4264
4049sub wait_for_tick_begin() { 4265sub wait_for_tick_begin() {
4050 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4266 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4051 4267
4052 my $signal = new Coro::Signal; 4268 my $signal = new Coro::Signal;
4053 push @WAIT_FOR_TICK_BEGIN, $signal; 4269 push @WAIT_FOR_TICK_BEGIN, $signal;
4054 $signal->wait; 4270 $signal->wait;
4055} 4271}
… …
4059 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4275 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4060 unless ++$bug_warning > 10; 4276 unless ++$bug_warning > 10;
4061 return; 4277 return;
4062 } 4278 }
4063 4279
4064 cf::server_tick; # one server iteration 4280 cf::one_tick; # one server iteration
4065 4281
4066 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d# 4282 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4067 4283
4068 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4284 if ($NOW >= $NEXT_RUNTIME_WRITE) {
4069 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4285 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
… …
4075 } 4291 }
4076 4292
4077 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4293 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4078 $sig->send; 4294 $sig->send;
4079 } 4295 }
4080 while (my $sig = shift @WAIT_FOR_TICK) { 4296 $WAIT_FOR_TICK->broadcast;
4081 $sig->send;
4082 }
4083 4297
4084 $LOAD = ($NOW - $TICK_START) / $TICK; 4298 $LOAD = ($NOW - $TICK_START) / $TICK;
4085 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4299 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4086 4300
4087 if (0) { 4301 if (0) {
… …
4093 } 4307 }
4094} 4308}
4095 4309
4096{ 4310{
4097 # configure BDB 4311 # configure BDB
4312 info "initialising database";
4098 4313
4099 BDB::min_parallel 16; 4314 BDB::min_parallel 16;
4100 BDB::max_poll_reqs $TICK * 0.1; 4315 BDB::max_poll_reqs $TICK * 0.1;
4101 $AnyEvent::BDB::WATCHER->priority (1); 4316 #$AnyEvent::BDB::WATCHER->priority (1);
4102 4317
4103 unless ($DB_ENV) { 4318 unless ($DB_ENV) {
4104 $DB_ENV = BDB::db_env_create; 4319 $DB_ENV = BDB::db_env_create;
4105 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4320 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4106 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4321 $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 { }; 4346 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4132 }; 4347 };
4133 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub { 4348 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4134 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4349 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4135 }; 4350 };
4351
4352 info "database initialised";
4136} 4353}
4137 4354
4138{ 4355{
4139 # configure IO::AIO 4356 # configure IO::AIO
4140 4357
4358 info "initialising aio";
4141 IO::AIO::min_parallel 8; 4359 IO::AIO::min_parallel 8;
4142 IO::AIO::max_poll_time $TICK * 0.1; 4360 IO::AIO::max_poll_time $TICK * 0.1;
4143 undef $AnyEvent::AIO::WATCHER; 4361 undef $AnyEvent::AIO::WATCHER;
4362 info "aio initialised";
4144} 4363}
4145 4364
4146our $_log_backtrace; 4365our $_log_backtrace;
4147our $_log_backtrace_last; 4366our $_log_backtrace_last;
4148 4367

Diff Legend

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