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.546 by root, Thu May 6 22:57:49 2010 UTC vs.
Revision 1.589 by root, Sun Nov 4 01:01:13 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 ();
… …
93our @EVENT; 97our @EVENT;
94our @REFLECT; # set by XS 98our @REFLECT; # set by XS
95our %REFLECT; # set by us 99our %REFLECT; # set by us
96 100
97our $CONFDIR = confdir; 101our $CONFDIR = confdir;
102
98our $DATADIR = datadir; 103our $DATADIR = datadir;
99our $LIBDIR = "$DATADIR/ext"; 104our $LIBDIR = "$DATADIR/ext";
100our $PODDIR = "$DATADIR/pod"; 105our $PODDIR = "$DATADIR/pod";
101our $MAPDIR = "$DATADIR/" . mapdir; 106our $MAPDIR = "$DATADIR/" . mapdir;
107
102our $LOCALDIR = localdir; 108our $LOCALDIR = localdir;
103our $TMPDIR = "$LOCALDIR/" . tmpdir; 109our $TMPDIR = "$LOCALDIR/" . tmpdir;
104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 110our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
105our $PLAYERDIR = "$LOCALDIR/" . playerdir; 111our $PLAYERDIR = "$LOCALDIR/" . playerdir;
106our $RANDOMDIR = "$LOCALDIR/random"; 112our $RANDOMDIR = "$LOCALDIR/random";
107our $BDBDIR = "$LOCALDIR/db"; 113our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid"; 114our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime"; 115our $RUNTIMEFILE = "$LOCALDIR/runtime";
110 116
111our %RESOURCE; # unused 117#our %RESOURCE; # unused
112 118
113our $OUTPUT_RATE_MIN = 3000; 119our $OUTPUT_RATE_MIN = 3000;
114our $OUTPUT_RATE_MAX = 1000000; 120our $OUTPUT_RATE_MAX = 1000000;
115 121
116our $MAX_LINKS = 32; # how many chained exits to follow 122our $MAX_LINKS = 32; # how many chained exits to follow
… …
127our $DB_ENV; 133our $DB_ENV;
128 134
129our @EXTRA_MODULES = qw(pod match mapscript incloader); 135our @EXTRA_MODULES = qw(pod match mapscript incloader);
130 136
131our %CFG; 137our %CFG;
138our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
132 139
133our $UPTIME; $UPTIME ||= time; 140our $UPTIME; $UPTIME ||= time;
134our $RUNTIME; 141our $RUNTIME = 0;
142our $SERVER_TICK = 0;
135our $NOW; 143our $NOW;
136 144
137our (%PLAYER, %PLAYER_LOADING); # all users 145our (%PLAYER, %PLAYER_LOADING); # all users
138our (%MAP, %MAP_LOADING ); # all maps 146our (%MAP, %MAP_LOADING ); # all maps
139our $LINK_MAP; # the special {link} map, which is always available 147our $LINK_MAP; # the special {link} map, which is always available
… …
148 156
149our @POST_INIT; 157our @POST_INIT;
150 158
151our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow) 159our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
152our $REALLY_UNLOOP; # never set to true, please :) 160our $REALLY_UNLOOP; # never set to true, please :)
161
162our $WAIT_FOR_TICK = new Coro::Signal;
163our @WAIT_FOR_TICK_BEGIN;
153 164
154binmode STDOUT; 165binmode STDOUT;
155binmode STDERR; 166binmode STDERR;
156 167
157# read virtual server time, if available 168# read virtual server time, if available
… …
191 202
192=over 4 203=over 4
193 204
194=item $cf::UPTIME 205=item $cf::UPTIME
195 206
196The timestamp of the server start (so not actually an uptime). 207The timestamp of the server start (so not actually an "uptime").
208
209=item $cf::SERVER_TICK
210
211An unsigned integer that starts at zero when the server is started and is
212incremented on every tick.
213
214=item $cf::NOW
215
216The (real) time of the last (current) server tick - updated before and
217after tick processing, so this is useful only as a rough "what time is it
218now" estimate.
219
220=item $cf::TICK
221
222The interval between each server tick, in seconds.
197 223
198=item $cf::RUNTIME 224=item $cf::RUNTIME
199 225
200The time this server has run, starts at 0 and is increased by $cf::TICK on 226The time this server has run, starts at 0 and is increased by $cf::TICK on
201every server tick. 227every server tick.
… …
207Various directories - "/etc", read-only install directory, perl-library 233Various directories - "/etc", read-only install directory, perl-library
208directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 234directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
209unique-items directory, player file directory, random maps directory and 235unique-items directory, player file directory, random maps directory and
210database environment. 236database environment.
211 237
212=item $cf::NOW
213
214The time of the last (current) server tick.
215
216=item $cf::TICK
217
218The interval between server ticks, in seconds.
219
220=item $cf::LOADAVG 238=item $cf::LOADAVG
221 239
222The current CPU load on the server (alpha-smoothed), as a value between 0 240The current CPU load on the server (alpha-smoothed), as a value between 0
223(none) and 1 (overloaded), indicating how much time is spent on processing 241(none) and 1 (overloaded), indicating how much time is spent on processing
224objects per tick. Healthy values are < 0.5. 242objects per tick. Healthy values are < 0.5.
… …
235=item cf::wait_for_tick, cf::wait_for_tick_begin 253=item cf::wait_for_tick, cf::wait_for_tick_begin
236 254
237These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 255These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
238returns directly I<after> the tick processing (and consequently, can only wake one thread 256returns directly I<after> the tick processing (and consequently, can only wake one thread
239per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 257per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
258
259Note that cf::Wait_for_tick will immediately return when the server is not
260ticking, making it suitable for small pauses in threads that need to run
261when the server is paused. If that is not applicable (i.e. you I<really>
262want to wait, use C<$cf::WAIT_FOR_TICK>).
263
264=item $cf::WAIT_FOR_TICK
265
266Note that C<cf::wait_for_tick> is probably the correct thing to use. This
267variable contains a L<Coro::Signal> that is broadcats after every server
268tick. Calling C<< ->wait >> on it will suspend the caller until after the
269next server tick.
240 270
241=cut 271=cut
242 272
243sub wait_for_tick(); 273sub wait_for_tick();
244sub wait_for_tick_begin(); 274sub wait_for_tick_begin();
… …
310)) { 340)) {
311 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 341 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
312} 342}
313 343
314$EV::DIED = sub { 344$EV::DIED = sub {
315 Carp::cluck "error in event callback: @_"; 345 warn "error in event callback: $@";
316}; 346};
347
348#############################################################################
349
350sub fork_call(&@);
351sub get_slot($;$$);
317 352
318############################################################################# 353#############################################################################
319 354
320=head2 UTILITY FUNCTIONS 355=head2 UTILITY FUNCTIONS
321 356
… …
342 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 377 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
343 $d 378 $d
344 } || "[unable to dump $_[0]: '$@']"; 379 } || "[unable to dump $_[0]: '$@']";
345} 380}
346 381
382=item $scalar = cf::load_file $path
383
384Loads the given file from path and returns its contents. Croaks on error
385and can block.
386
387=cut
388
389sub load_file($) {
390 0 <= aio_load $_[0], my $data
391 or Carp::croak "$_[0]: $!";
392
393 $data
394}
395
396=item $success = cf::replace_file $path, $data, $sync
397
398Atomically replaces the file at the given $path with new $data, and
399optionally $sync the data to disk before replacing the file.
400
401=cut
402
403sub replace_file($$;$) {
404 my ($path, $data, $sync) = @_;
405
406 my $lock = cf::lock_acquire ("replace_file:$path");
407
408 my $fh = aio_open "$path~", Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_TRUNC, 0644
409 or return;
410
411 $data = $data->() if ref $data;
412
413 length $data == aio_write $fh, 0, (length $data), $data, 0
414 or return;
415
416 !$sync
417 or !aio_fsync $fh
418 or return;
419
420 aio_close $fh
421 and return;
422
423 aio_rename "$path~", $path
424 and return;
425
426 if ($sync) {
427 $path =~ s%/[^/]*$%%;
428 aio_pathsync $path;
429 }
430
431 1
432}
433
347=item $ref = cf::decode_json $json 434=item $ref = cf::decode_json $json
348 435
349Converts a JSON string into the corresponding perl data structure. 436Converts a JSON string into the corresponding perl data structure.
350 437
351=item $json = cf::encode_json $ref 438=item $json = cf::encode_json $ref
… …
357our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 444our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
358 445
359sub encode_json($) { $json_coder->encode ($_[0]) } 446sub encode_json($) { $json_coder->encode ($_[0]) }
360sub decode_json($) { $json_coder->decode ($_[0]) } 447sub decode_json($) { $json_coder->decode ($_[0]) }
361 448
449=item $ref = cf::decode_storable $scalar
450
451Same as Coro::Storable::thaw, so blocks.
452
453=cut
454
455BEGIN { *decode_storable = \&Coro::Storable::thaw }
456
457=item $ref = cf::decode_yaml $scalar
458
459Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
460
461=cut
462
463sub decode_yaml($) {
464 fork_call { YAML::XS::Load $_[0] } @_
465}
466
467=item $scalar = cf::unlzf $scalar
468
469Same as Compress::LZF::compress, but takes server ticks into account, so
470blocks.
471
472=cut
473
474sub unlzf($) {
475 # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
476 cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
477 Compress::LZF::decompress $_[0]
478}
479
362=item cf::post_init { BLOCK } 480=item cf::post_init { BLOCK }
363 481
364Execute the given codeblock, I<after> all extensions have been (re-)loaded, 482Execute the given codeblock, I<after> all extensions have been (re-)loaded,
365but I<before> the server starts ticking again. 483but I<before> the server starts ticking again.
366 484
367The cdoeblock will have a single boolean argument to indicate whether this 485The codeblock will have a single boolean argument to indicate whether this
368is a reload or not. 486is a reload or not.
369 487
370=cut 488=cut
371 489
372sub post_init(&) { 490sub post_init(&) {
373 push @POST_INIT, shift; 491 push @POST_INIT, shift;
492}
493
494sub _post_init {
495 trace "running post_init jobs";
496
497 # run them in parallel...
498
499 my @join;
500
501 while () {
502 push @join, map &Coro::async ($_, 0), @POST_INIT;
503 @POST_INIT = ();
504
505 @join or last;
506
507 (pop @join)->join;
508 }
374} 509}
375 510
376=item cf::lock_wait $string 511=item cf::lock_wait $string
377 512
378Wait until the given lock is available. See cf::lock_acquire. 513Wait until the given lock is available. See cf::lock_acquire.
… …
431 EV::periodic $start, $interval, 0, $cb 566 EV::periodic $start, $interval, 0, $cb
432} 567}
433 568
434=item cf::get_slot $time[, $priority[, $name]] 569=item cf::get_slot $time[, $priority[, $name]]
435 570
436Allocate $time seconds of blocking CPU time at priority C<$priority>: 571Allocate $time seconds of blocking CPU time at priority C<$priority>
437This call blocks and returns only when you have at least C<$time> seconds 572(default: 0): This call blocks and returns only when you have at least
438of cpu time till the next tick. The slot is only valid till the next cede. 573C<$time> seconds of cpu time till the next tick. The slot is only valid
574till the next cede.
575
576Background jobs should use a priority les than zero, interactive jobs
577should use 100 or more.
439 578
440The optional C<$name> can be used to identify the job to run. It might be 579The optional C<$name> can be used to identify the job to run. It might be
441used for statistical purposes and should identify the same time-class. 580used for statistical purposes and should identify the same time-class.
442 581
443Useful for short background jobs. 582Useful for short background jobs.
… …
472 } 611 }
473 } 612 }
474 613
475 if (@SLOT_QUEUE) { 614 if (@SLOT_QUEUE) {
476 # we do not use wait_for_tick() as it returns immediately when tick is inactive 615 # we do not use wait_for_tick() as it returns immediately when tick is inactive
477 push @cf::WAIT_FOR_TICK, $signal; 616 $WAIT_FOR_TICK->wait;
478 $signal->wait;
479 } else { 617 } else {
480 $busy = 0; 618 $busy = 0;
481 Coro::schedule; 619 Coro::schedule;
482 } 620 }
483 } 621 }
… …
583 $EXT_CORO{$coro+0} = $coro; 721 $EXT_CORO{$coro+0} = $coro;
584 722
585 $coro 723 $coro
586} 724}
587 725
588=item fork_call { }, $args 726=item fork_call { }, @args
589 727
590Executes the given code block with the given arguments in a seperate 728Executes the given code block with the given arguments in a seperate
591process, returning the results. Everything must be serialisable with 729process, returning the results. Everything must be serialisable with
592Coro::Storable. May, of course, block. Note that the executed sub may 730Coro::Storable. May, of course, block. Note that the executed sub may
593never block itself or use any form of event handling. 731never block itself or use any form of event handling.
594 732
595=cut 733=cut
596 734
735sub post_fork {
736 reset_signals;
737}
738
597sub fork_call(&@) { 739sub fork_call(&@) {
598 my ($cb, @args) = @_; 740 my ($cb, @args) = @_;
599 741
600 # we seemingly have to make a local copy of the whole thing, 742 # we seemingly have to make a local copy of the whole thing,
601 # otherwise perl prematurely frees the stuff :/ 743 # otherwise perl prematurely frees the stuff :/
602 # TODO: investigate and fix (likely this will be rather laborious) 744 # TODO: investigate and fix (likely this will be rather laborious)
603 745
604 my @res = Coro::Util::fork_eval { 746 my @res = Coro::Util::fork_eval {
605 reset_signals; 747 cf::post_fork;
606 &$cb 748 &$cb
607 }, @args; 749 } @args;
608 750
609 wantarray ? @res : $res[-1] 751 wantarray ? @res : $res[-1]
610} 752}
611 753
612sub objinfo { 754sub objinfo {
… …
734 876
735 my @data; 877 my @data;
736 my $md5; 878 my $md5;
737 879
738 for (0 .. $#$src) { 880 for (0 .. $#$src) {
739 0 <= aio_load $src->[$_], $data[$_] 881 $data[$_] = load_file $src->[$_];
740 or Carp::croak "$src->[$_]: $!";
741 } 882 }
742 883
743 # if processing is expensive, check 884 # if processing is expensive, check
744 # checksum first 885 # checksum first
745 if (1) { 886 if (1) {
… …
1363 my ($pl, $buf) = @_; 1504 my ($pl, $buf) = @_;
1364 1505
1365 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1506 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1366 1507
1367 if (ref $msg) { 1508 if (ref $msg) {
1368 my ($type, $reply, @payload) = 1509 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1369 "ARRAY" eq ref $msg
1370 ? @$msg
1371 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1372 1510
1373 my @reply; 1511 my @reply;
1374 1512
1375 if (my $cb = $EXTCMD{$type}) { 1513 if (my $cb = $EXTCMD{$type}) {
1376 @reply = $cb->($pl, @payload); 1514 @reply = $cb->($pl, @payload);
… …
1398 }; 1536 };
1399 1537
1400 $grp 1538 $grp
1401} 1539}
1402 1540
1541sub _ext_cfg_reg($$$$) {
1542 my ($rvar, $varname, $cfgname, $default) = @_;
1543
1544 $cfgname = lc $varname
1545 unless length $cfgname;
1546
1547 $EXT_CFG{$cfgname} = [$rvar, $default];
1548
1549 $$rvar = exists $CFG{$cfgname} ? $CFG{$cfgname} : $default;
1550}
1551
1403sub load_extensions { 1552sub load_extensions {
1404 info "loading extensions..."; 1553 info "loading extensions...";
1554
1555 %EXT_CFG = ();
1405 1556
1406 cf::sync_job { 1557 cf::sync_job {
1407 my %todo; 1558 my %todo;
1408 1559
1409 for my $path (<$LIBDIR/*.ext>) { 1560 for my $path (<$LIBDIR/*.ext>) {
… …
1452 unless exists $done{$_}; 1603 unless exists $done{$_};
1453 } 1604 }
1454 1605
1455 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n"; 1606 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1456 1607
1608 my $source = $v->{source};
1609
1610 # support "CONF varname :confname = default" pseudo-statements
1611 $source =~ s{
1612 ^ CONF \s+ ([^\s:=]+) \s* (?:: \s* ([^\s:=]+) \s* )? = ([^\n#]+)
1613 }{
1614 "our \$$1; BEGIN { cf::_ext_cfg_reg \\\$$1, q\x00$1\x00, q\x00$2\x00, $3 }";
1615 }gmxe;
1616
1457 my $active = eval $v->{source}; 1617 my $active = eval $source;
1458 1618
1459 if (length $@) { 1619 if (length $@) {
1460 error "$v->{path}: $@\n"; 1620 error "$v->{path}: $@\n";
1461 1621
1462 cf::cleanup "mandatory extension '$k' failed to load, exiting." 1622 cf::cleanup "mandatory extension '$k' failed to load, exiting."
… …
1479 1639
1480 while (my ($k, $v) = each %todo) { 1640 while (my ($k, $v) = each %todo) {
1481 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting." 1641 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1482 if exists $v->{meta}{mandatory}; 1642 if exists $v->{meta}{mandatory};
1483 } 1643 }
1644
1645 last;
1484 } 1646 }
1485 } 1647 }
1486 }; 1648 };
1487} 1649}
1488 1650
… …
1646 my $name = $pl->ob->name; 1808 my $name = $pl->ob->name;
1647 1809
1648 $pl->{deny_save} = 1; 1810 $pl->{deny_save} = 1;
1649 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1811 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1650 1812
1651 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1813 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1652 $pl->deactivate; 1814 $pl->deactivate;
1815
1653 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1816 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1654 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1817 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1818 ext::highscore::check ($pl->ob);
1819
1655 $pl->ns->destroy if $pl->ns; 1820 $pl->ns->destroy if $pl->ns;
1656 1821
1657 my $path = playerdir $pl; 1822 my $path = playerdir $pl;
1658 my $temp = "$path~$cf::RUNTIME~deleting~"; 1823 my $temp = "$path~$cf::RUNTIME~deleting~";
1659 aio_rename $path, $temp; 1824 aio_rename $path, $temp;
… …
1825sub generate_random_map { 1990sub generate_random_map {
1826 my ($self, $rmp) = @_; 1991 my ($self, $rmp) = @_;
1827 1992
1828 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1993 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1829 1994
1830 # mit "rum" bekleckern, nicht
1831 $self->_create_random_map ( 1995 $self->_create_random_map ($rmp);
1832 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1833 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1834 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1835 $rmp->{exit_on_final_map},
1836 $rmp->{xsize}, $rmp->{ysize},
1837 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1838 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1839 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1840 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1841 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1842 (cf::region::find $rmp->{region}), $rmp->{custom}
1843 )
1844} 1996}
1845 1997
1846=item cf::map->register ($regex, $prio) 1998=item cf::map->register ($regex, $prio)
1847 1999
1848Register a handler for the map path matching the given regex at the 2000Register a handler for the map path matching the given regex at the
… …
1899 $base =~ s{[^/]+/?$}{}; 2051 $base =~ s{[^/]+/?$}{};
1900 $path = "$base/$path"; 2052 $path = "$base/$path";
1901 } 2053 }
1902 2054
1903 for ($path) { 2055 for ($path) {
1904 redo if s{//}{/};
1905 redo if s{/\.?/}{/}; 2056 redo if s{/\.?/}{/};
1906 redo if s{/[^/]+/\.\./}{/}; 2057 redo if s{/[^/]+/\.\./}{/};
1907 } 2058 }
1908 2059
1909 $path 2060 $path
… …
1927 2078
1928 Carp::cluck "unable to resolve path '$path' (base '$base')"; 2079 Carp::cluck "unable to resolve path '$path' (base '$base')";
1929 () 2080 ()
1930} 2081}
1931 2082
2083# may re-bless or do other evil things
1932sub init { 2084sub init {
1933 my ($self) = @_; 2085 my ($self) = @_;
1934 2086
1935 $self 2087 $self
1936} 2088}
… …
2001 $self->{load_path} = $path; 2153 $self->{load_path} = $path;
2002 2154
2003 1 2155 1
2004} 2156}
2005 2157
2158# used to laod the header of an original map
2006sub load_header_orig { 2159sub load_header_orig {
2007 my ($self) = @_; 2160 my ($self) = @_;
2008 2161
2009 $self->load_header_from ($self->load_path) 2162 $self->load_header_from ($self->load_path)
2010} 2163}
2011 2164
2165# used to laod the header of an instantiated map
2012sub load_header_temp { 2166sub load_header_temp {
2013 my ($self) = @_; 2167 my ($self) = @_;
2014 2168
2015 $self->load_header_from ($self->save_path) 2169 $self->load_header_from ($self->save_path)
2016} 2170}
2017 2171
2172# called after loading the header from an instantiated map
2018sub prepare_temp { 2173sub prepare_temp {
2019 my ($self) = @_; 2174 my ($self) = @_;
2020 2175
2021 $self->last_access ((delete $self->{last_access}) 2176 $self->last_access ((delete $self->{last_access})
2022 || $cf::RUNTIME); #d# 2177 || $cf::RUNTIME); #d#
2023 # safety 2178 # safety
2024 $self->{instantiate_time} = $cf::RUNTIME 2179 $self->{instantiate_time} = $cf::RUNTIME
2025 if $self->{instantiate_time} > $cf::RUNTIME; 2180 if $self->{instantiate_time} > $cf::RUNTIME;
2026} 2181}
2027 2182
2183# called after loading the header from an original map
2028sub prepare_orig { 2184sub prepare_orig {
2029 my ($self) = @_; 2185 my ($self) = @_;
2030 2186
2031 $self->{load_original} = 1; 2187 $self->{load_original} = 1;
2032 $self->{instantiate_time} = $cf::RUNTIME; 2188 $self->{instantiate_time} = $cf::RUNTIME;
… …
2058sub find { 2214sub find {
2059 my ($path, $origin) = @_; 2215 my ($path, $origin) = @_;
2060 2216
2061 cf::cede_to_tick; 2217 cf::cede_to_tick;
2062 2218
2063 $path = normalise $path, $origin && $origin->path; 2219 $path = normalise $path, $origin;
2064 2220
2065 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2221 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2066 my $guard2 = cf::lock_acquire "map_find:$path"; 2222 my $guard2 = cf::lock_acquire "map_find:$path";
2067 2223
2068 $cf::MAP{$path} || do { 2224 $cf::MAP{$path} || do {
… …
2099 2255
2100 { 2256 {
2101 my $guard = cf::lock_acquire "map_data:$path"; 2257 my $guard = cf::lock_acquire "map_data:$path";
2102 2258
2103 return unless $self->valid; 2259 return unless $self->valid;
2104 return unless $self->in_memory == cf::MAP_SWAPPED; 2260 return unless $self->state == cf::MAP_SWAPPED;
2105
2106 $self->in_memory (cf::MAP_LOADING);
2107 2261
2108 $self->alloc; 2262 $self->alloc;
2109 2263
2110 $self->pre_load; 2264 $self->pre_load;
2111 cf::cede_to_tick; 2265 cf::cede_to_tick;
2112 2266
2267 if (exists $self->{load_path}) {
2113 my $f = new_from_file cf::object::thawer $self->{load_path}; 2268 my $f = new_from_file cf::object::thawer $self->{load_path};
2114 $f->skip_block; 2269 $f->skip_block;
2115 $self->_load_objects ($f) 2270 $self->_load_objects ($f)
2116 or return; 2271 or return;
2117 2272
2118 $self->post_load_original 2273 $self->post_load_original
2119 if delete $self->{load_original}; 2274 if delete $self->{load_original};
2120 2275
2121 if (my $uniq = $self->uniq_path) { 2276 if (my $uniq = $self->uniq_path) {
2122 utf8::encode $uniq; 2277 utf8::encode $uniq;
2123 unless (aio_stat $uniq) { 2278 unless (aio_stat $uniq) {
2124 if (my $f = new_from_file cf::object::thawer $uniq) { 2279 if (my $f = new_from_file cf::object::thawer $uniq) {
2125 $self->clear_unique_items; 2280 $self->clear_unique_items;
2126 $self->_load_objects ($f); 2281 $self->_load_objects ($f);
2127 $f->resolve_delayed_derefs; 2282 $f->resolve_delayed_derefs;
2283 }
2128 } 2284 }
2129 } 2285 }
2130 }
2131 2286
2132 $f->resolve_delayed_derefs; 2287 $f->resolve_delayed_derefs;
2288 } else {
2289 $self->post_load_original
2290 if delete $self->{load_original};
2291 }
2292
2293 $self->state (cf::MAP_INACTIVE);
2133 2294
2134 cf::cede_to_tick; 2295 cf::cede_to_tick;
2135 # now do the right thing for maps 2296 # now do the right thing for maps
2136 $self->link_multipart_objects; 2297 $self->link_multipart_objects;
2137 $self->difficulty ($self->estimate_difficulty) 2298 $self->difficulty ($self->estimate_difficulty)
… …
2141 unless ($self->{deny_activate}) { 2302 unless ($self->{deny_activate}) {
2142 $self->decay_objects; 2303 $self->decay_objects;
2143 $self->fix_auto_apply; 2304 $self->fix_auto_apply;
2144 $self->update_buttons; 2305 $self->update_buttons;
2145 cf::cede_to_tick; 2306 cf::cede_to_tick;
2146 $self->activate; 2307 #$self->activate; # no longer activate maps automatically
2147 } 2308 }
2148 2309
2149 $self->{last_save} = $cf::RUNTIME; 2310 $self->{last_save} = $cf::RUNTIME;
2150 $self->last_access ($cf::RUNTIME); 2311 $self->last_access ($cf::RUNTIME);
2151
2152 $self->in_memory (cf::MAP_ACTIVE);
2153 } 2312 }
2154 2313
2155 $self->post_load; 2314 $self->post_load;
2315
2316 1
2156} 2317}
2157 2318
2158# customize the map for a given player, i.e. 2319# customize the map for a given player, i.e.
2159# return the _real_ map. used by e.g. per-player 2320# return the _real_ map. used by e.g. per-player
2160# maps to change the path to ~playername/mappath 2321# maps to change the path to ~playername/mappath
… …
2168# if $self->per_party; 2329# if $self->per_party;
2169 2330
2170 $self 2331 $self
2171} 2332}
2172 2333
2173# find and load all maps in the 3x3 area around a map
2174sub load_neighbours {
2175 my ($map) = @_;
2176
2177 my @neigh; # diagonal neighbours
2178
2179 for (0 .. 3) {
2180 my $neigh = $map->tile_path ($_)
2181 or next;
2182 $neigh = find $neigh, $map
2183 or next;
2184 $neigh->load;
2185
2186 # now find the diagonal neighbours
2187 push @neigh,
2188 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2189 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2190 }
2191
2192 for (grep defined $_->[0], @neigh) {
2193 my ($path, $origin) = @$_;
2194 my $neigh = find $path, $origin
2195 or next;
2196 $neigh->load;
2197 }
2198}
2199
2200sub find_sync { 2334sub find_sync {
2201 my ($path, $origin) = @_; 2335 my ($path, $origin) = @_;
2202 2336
2337 # it's a bug to call this from the main context
2203 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync" 2338 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2204 if $Coro::current == $Coro::main; 2339 if $Coro::current == $Coro::main;
2205 2340
2206 find $path, $origin 2341 find $path, $origin
2207} 2342}
2208 2343
2209sub do_load_sync { 2344sub do_load_sync {
2210 my ($map) = @_; 2345 my ($map) = @_;
2211 2346
2347 # it's a bug to call this from the main context
2212 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync" 2348 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2213 if $Coro::current == $Coro::main; 2349 if $Coro::current == $Coro::main;
2214 2350
2215 $map->load; 2351 $map->load;
2216} 2352}
… …
2219our $MAP_PREFETCHER = undef; 2355our $MAP_PREFETCHER = undef;
2220 2356
2221sub find_async { 2357sub find_async {
2222 my ($path, $origin, $load) = @_; 2358 my ($path, $origin, $load) = @_;
2223 2359
2224 $path = normalise $path, $origin && $origin->{path}; 2360 $path = normalise $path, $origin;
2225 2361
2226 if (my $map = $cf::MAP{$path}) { 2362 if (my $map = $cf::MAP{$path}) {
2227 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2363 return $map if !$load || $map->linkable;
2228 } 2364 }
2229 2365
2230 $MAP_PREFETCH{$path} |= $load; 2366 $MAP_PREFETCH{$path} |= $load;
2231 2367
2232 $MAP_PREFETCHER ||= cf::async { 2368 $MAP_PREFETCHER ||= cf::async {
… …
2291sub swap_out { 2427sub swap_out {
2292 my ($self) = @_; 2428 my ($self) = @_;
2293 2429
2294 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2430 my $lock = cf::lock_acquire "map_data:$self->{path}";
2295 2431
2296 return if $self->in_memory != cf::MAP_ACTIVE; 2432 return if !$self->linkable;
2297 return if $self->{deny_save}; 2433 return if $self->{deny_save};
2298 return if $self->players; 2434 return if $self->players;
2299 2435
2300 # first deactivate the map and "unlink" it from the core 2436 # first deactivate the map and "unlink" it from the core
2301 $self->deactivate; 2437 $self->deactivate;
2302 $_->clear_links_to ($self) for values %cf::MAP; 2438 $_->clear_links_to ($self) for values %cf::MAP;
2303 $self->in_memory (cf::MAP_SWAPPED); 2439 $self->state (cf::MAP_SWAPPED);
2304 2440
2305 # then atomically save 2441 # then atomically save
2306 $self->_save; 2442 $self->_save;
2307 2443
2308 # then free the map 2444 # then free the map
… …
2334 2470
2335 return if $self->players; 2471 return if $self->players;
2336 2472
2337 cf::trace "resetting map ", $self->path, "\n"; 2473 cf::trace "resetting map ", $self->path, "\n";
2338 2474
2339 $self->in_memory (cf::MAP_SWAPPED); 2475 $self->state (cf::MAP_SWAPPED);
2340 2476
2341 # need to save uniques path 2477 # need to save uniques path
2342 unless ($self->{deny_save}) { 2478 unless ($self->{deny_save}) {
2343 my $uniq = $self->uniq_path; utf8::encode $uniq; 2479 my $uniq = $self->uniq_path; utf8::encode $uniq;
2344 2480
… …
2674 # use -1 or undef as default coordinates, not 0, 0 2810 # use -1 or undef as default coordinates, not 0, 0
2675 ($x, $y) = ($map->enter_x, $map->enter_y) 2811 ($x, $y) = ($map->enter_x, $map->enter_y)
2676 if $x <= 0 && $y <= 0; 2812 if $x <= 0 && $y <= 0;
2677 2813
2678 $map->load; 2814 $map->load;
2679 $map->load_neighbours;
2680 2815
2681 return unless $self->contr->active; 2816 return unless $self->contr->active;
2682 2817
2683 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2818 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2684 if ($self->enter_map ($map, $x, $y)) { 2819 if ($self->enter_map ($map, $x, $y)) {
… …
2740 ($path, $x, $y) = (undef, undef, undef); 2875 ($path, $x, $y) = (undef, undef, undef);
2741 } 2876 }
2742 } 2877 }
2743 2878
2744 my $map = eval { 2879 my $map = eval {
2745 my $map = defined $path ? cf::map::find $path : undef; 2880 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2746 2881
2747 if ($map) { 2882 if ($map) {
2748 $map = $map->customise_for ($self); 2883 $map = $map->customise_for ($self);
2749 $map = $check->($map, $x, $y, $self) if $check && $map; 2884 $map = $check->($map, $x, $y, $self) if $check && $map;
2750 } else { 2885 } else {
… …
2840 $Coro::current->{desc} = "enter_exit"; 2975 $Coro::current->{desc} = "enter_exit";
2841 2976
2842 unless (eval { 2977 unless (eval {
2843 $self->deactivate_recursive; # just to be sure 2978 $self->deactivate_recursive; # just to be sure
2844 2979
2845 # random map handling
2846 {
2847 my $guard = cf::lock_acquire "exit_prepare:$exit";
2848
2849 prepare_random_map $exit
2850 if $exit->slaying eq "/!";
2851 }
2852
2853 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2980 my $map = cf::map::normalise $exit->slaying, $exit->map;
2854 my $x = $exit->stats->hp; 2981 my $x = $exit->stats->hp;
2855 my $y = $exit->stats->sp; 2982 my $y = $exit->stats->sp;
2983
2984 # special map handling
2985 my $slaying = $exit->slaying;
2986
2987 # special map handling
2988 if ($slaying eq "/!") {
2989 my $guard = cf::lock_acquire "exit_prepare:$exit";
2990
2991 prepare_random_map $exit
2992 if $exit->slaying eq "/!"; # need to re-check after getting the lock
2993
2994 $map = $exit->slaying;
2995
2996 } elsif ($slaying eq '!up') {
2997 $map = $exit->map->tile_path (cf::TILE_UP);
2998 $x = $exit->x;
2999 $y = $exit->y;
3000
3001 } elsif ($slaying eq '!down') {
3002 $map = $exit->map->tile_path (cf::TILE_DOWN);
3003 $x = $exit->x;
3004 $y = $exit->y;
3005 }
2856 3006
2857 $self->goto ($map, $x, $y); 3007 $self->goto ($map, $x, $y);
2858 3008
2859 # if exit is damned, update players death & WoR home-position 3009 # if exit is damned, update players death & WoR home-position
2860 $self->contr->savebed ($map, $x, $y) 3010 $self->contr->savebed ($map, $x, $y)
… …
3102=cut 3252=cut
3103 3253
3104sub cf::client::ext_reply($$@) { 3254sub cf::client::ext_reply($$@) {
3105 my ($self, $id, @msg) = @_; 3255 my ($self, $id, @msg) = @_;
3106 3256
3107 if ($self->extcmd == 2) { 3257 return unless $self->extcmd == 2;
3258
3108 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3259 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3109 } elsif ($self->extcmd == 1) {
3110 #TODO: version 1, remove
3111 unshift @msg, msgtype => "reply", msgid => $id;
3112 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3113 }
3114} 3260}
3115 3261
3116=item $success = $client->query ($flags, "text", \&cb) 3262=item $success = $client->query ($flags, "text", \&cb)
3117 3263
3118Queues a query to the client, calling the given callback with 3264Queues a query to the client, calling the given callback with
… …
3173 my ($ns, $buf) = @_; 3319 my ($ns, $buf) = @_;
3174 3320
3175 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3321 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3176 3322
3177 if (ref $msg) { 3323 if (ref $msg) {
3178 my ($type, $reply, @payload) = 3324 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3179 "ARRAY" eq ref $msg
3180 ? @$msg
3181 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3182 3325
3183 my @reply; 3326 my @reply;
3184 3327
3185 if (my $cb = $EXTICMD{$type}) { 3328 if (my $cb = $EXTICMD{$type}) {
3186 @reply = $cb->($ns, @payload); 3329 @reply = $cb->($ns, @payload);
… …
3364=cut 3507=cut
3365 3508
3366############################################################################# 3509#############################################################################
3367# the server's init and main functions 3510# the server's init and main functions
3368 3511
3512our %FACEHASH; # hash => idx, #d# HACK for http server
3513
3514# internal api, not fianlised
3515sub add_face {
3516 my ($name, $type, $data) = @_;
3517
3518 my $idx = cf::face::find $name;
3519
3520 if ($idx) {
3521 delete $FACEHASH{cf::face::get_chksum $idx};
3522 } else {
3523 $idx = cf::face::alloc $name;
3524 }
3525
3526 my $hash = cf::face::mangle_chksum Digest::MD5::md5 $data;
3527
3528 cf::face::set_type $idx, $type;
3529 cf::face::set_data $idx, 0, $data, $hash;
3530 cf::face::set_meta $idx, $type & 1 ? undef : undef;
3531 $FACEHASH{$hash} = $idx;#d#
3532
3533 $idx
3534}
3535
3369sub load_facedata($) { 3536sub load_facedata($) {
3370 my ($path) = @_; 3537 my ($path) = @_;
3371 3538
3372 # HACK to clear player env face cache, we need some signal framework 3539 # HACK to clear player env face cache, we need some signal framework
3373 # for this (global event?) 3540 # for this (global event?)
… …
3375 3542
3376 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3543 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3377 3544
3378 trace "loading facedata from $path\n"; 3545 trace "loading facedata from $path\n";
3379 3546
3380 0 < aio_load $path, my $facedata 3547 my $facedata = decode_storable load_file $path;
3381 or die "$path: $!";
3382
3383 $facedata = Coro::Storable::thaw $facedata;
3384 3548
3385 $facedata->{version} == 2 3549 $facedata->{version} == 2
3386 or cf::cleanup "$path: version mismatch, cannot proceed."; 3550 or cf::cleanup "$path: version mismatch, cannot proceed.";
3387 3551
3388 # patch in the exptable
3389 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3390 $facedata->{resource}{"res/exp_table"} = {
3391 type => FT_RSRC,
3392 data => $exp_table,
3393 hash => (Digest::MD5::md5 $exp_table),
3394 };
3395 cf::cede_to_tick; 3552 cf::cede_to_tick;
3396 3553
3397 { 3554 {
3398 my $faces = $facedata->{faceinfo}; 3555 my $faces = $facedata->{faceinfo};
3399 3556
3400 while (my ($face, $info) = each %$faces) { 3557 for my $face (sort keys %$faces) {
3558 my $info = $faces->{$face};
3401 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3559 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3402 3560
3403 cf::face::set_visibility $idx, $info->{visibility}; 3561 cf::face::set_visibility $idx, $info->{visibility};
3404 cf::face::set_magicmap $idx, $info->{magicmap}; 3562 cf::face::set_magicmap $idx, $info->{magicmap};
3405 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3563 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3406 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3564 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3565 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3566 $FACEHASH{$info->{hash64}} = $idx;#d#
3407 3567
3408 cf::cede_to_tick; 3568 cf::cede_to_tick;
3409 } 3569 }
3410 3570
3411 while (my ($face, $info) = each %$faces) { 3571 while (my ($face, $info) = each %$faces) {
… …
3438 3598
3439 { 3599 {
3440 my $res = $facedata->{resource}; 3600 my $res = $facedata->{resource};
3441 3601
3442 while (my ($name, $info) = each %$res) { 3602 while (my ($name, $info) = each %$res) {
3443 if (defined $info->{type}) { 3603 if (defined (my $type = $info->{type})) {
3604 # TODO: different hash - must free and use new index, or cache ixface data queue
3444 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3605 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3445 3606
3607 cf::face::set_type $idx, $type;
3446 cf::face::set_data $idx, 0, $info->{data}, $info->{hash}; 3608 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3447 cf::face::set_type $idx, $info->{type}; 3609 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3610 $FACEHASH{$info->{hash}} = $idx;#d#
3448 } else { 3611 } else {
3449 $RESOURCE{$name} = $info; # unused 3612# $RESOURCE{$name} = $info; # unused
3450 } 3613 }
3451 3614
3452 cf::cede_to_tick; 3615 cf::cede_to_tick;
3453 } 3616 }
3454 } 3617 }
… …
3472 my $status = load_resource_file_ $_[0]; 3635 my $status = load_resource_file_ $_[0];
3473 get_slot 0.1, 100; 3636 get_slot 0.1, 100;
3474 cf::arch::commit_load; 3637 cf::arch::commit_load;
3475 3638
3476 $status 3639 $status
3640}
3641
3642sub reload_exp_table {
3643 _reload_exp_table;
3644
3645 add_face "res/exp_table" => FT_RSRC,
3646 JSON::XS->new->utf8->canonical->encode (
3647 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3648 );
3649}
3650
3651sub reload_materials {
3652 _reload_materials;
3477} 3653}
3478 3654
3479sub reload_regions { 3655sub reload_regions {
3480 # HACK to clear player env face cache, we need some signal framework 3656 # HACK to clear player env face cache, we need some signal framework
3481 # for this (global event?) 3657 # for this (global event?)
… …
3496} 3672}
3497 3673
3498sub reload_archetypes { 3674sub reload_archetypes {
3499 load_resource_file "$DATADIR/archetypes" 3675 load_resource_file "$DATADIR/archetypes"
3500 or die "unable to load archetypes\n"; 3676 or die "unable to load archetypes\n";
3677
3678 add_face "res/skill_info" => FT_RSRC,
3679 JSON::XS->new->utf8->canonical->encode (
3680 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3681 );
3682 add_face "res/spell_paths" => FT_RSRC,
3683 JSON::XS->new->utf8->canonical->encode (
3684 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3685 );
3501} 3686}
3502 3687
3503sub reload_treasures { 3688sub reload_treasures {
3504 load_resource_file "$DATADIR/treasures" 3689 load_resource_file "$DATADIR/treasures"
3505 or die "unable to load treasurelists\n"; 3690 or die "unable to load treasurelists\n";
3506} 3691}
3507 3692
3508sub reload_sound { 3693sub reload_sound {
3509 trace "loading sound config from $DATADIR/sound\n"; 3694 trace "loading sound config from $DATADIR/sound\n";
3510 3695
3511 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3512 or die "$DATADIR/sound $!";
3513
3514 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data); 3696 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3515 3697
3516 for (0 .. SOUND_CAST_SPELL_0 - 1) { 3698 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3517 my $sound = $soundconf->{compat}[$_] 3699 my $sound = $soundconf->{compat}[$_]
3518 or next; 3700 or next;
3519 3701
… …
3529} 3711}
3530 3712
3531sub reload_resources { 3713sub reload_resources {
3532 trace "reloading resource files...\n"; 3714 trace "reloading resource files...\n";
3533 3715
3534 reload_exp_table;
3535 reload_materials; 3716 reload_materials;
3536 reload_facedata; 3717 reload_facedata;
3718 reload_exp_table;
3537 reload_sound; 3719 reload_sound;
3538 reload_archetypes; 3720 reload_archetypes;
3539 reload_regions; 3721 reload_regions;
3540 reload_treasures; 3722 reload_treasures;
3541 3723
… …
3543} 3725}
3544 3726
3545sub reload_config { 3727sub reload_config {
3546 trace "reloading config file...\n"; 3728 trace "reloading config file...\n";
3547 3729
3548 0 < aio_load "$CONFDIR/config", my $config 3730 my $config = load_file "$CONFDIR/config";
3549 or die "$CONFDIR/config: $!";
3550
3551 utf8::decode $config; 3731 utf8::decode $config;
3552 3732 *CFG = decode_yaml $config;
3553 cf::get_slot 0.1, 10, "reload_config"; # yaml might be slow...
3554 *CFG = YAML::XS::Load $config;
3555 3733
3556 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38]; 3734 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3557 3735
3558 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3736 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3559 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3737 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3597 3775
3598sub main { 3776sub main {
3599 cf::init_globals; # initialise logging 3777 cf::init_globals; # initialise logging
3600 3778
3601 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3779 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3602 LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3780 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3603 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3781 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3604 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3782 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3605 3783
3606 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3784 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3607 3785
3608 # we must not ever block the main coroutine 3786 # we must not ever block the main coroutine
3609 local $Coro::idle = sub { 3787 $Coro::idle = sub {
3610 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3788 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3611 (async { 3789 (async {
3612 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3790 $Coro::current->{desc} = "IDLE BUG HANDLER";
3613 EV::loop EV::LOOP_ONESHOT; 3791 EV::loop EV::LOOP_ONESHOT;
3614 })->prio (Coro::PRIO_MAX); 3792 })->prio (Coro::PRIO_MAX);
… …
3643 3821
3644 # no (long-running) fork's whatsoever before this point(!) 3822 # no (long-running) fork's whatsoever before this point(!)
3645 use POSIX (); 3823 use POSIX ();
3646 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3824 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3647 3825
3648 (pop @POST_INIT)->(0) while @POST_INIT; 3826 cf::_post_init 0;
3649 }; 3827 };
3650 3828
3651 cf::object::thawer::errors_are_fatal 0; 3829 cf::object::thawer::errors_are_fatal 0;
3652 info "parse errors in files are no longer fatal from this point on.\n"; 3830 info "parse errors in files are no longer fatal from this point on.\n";
3653 3831
3654 my $free_main; $free_main = EV::idle sub { 3832 AE::postpone {
3655 undef $free_main;
3656 undef &main; # free gobs of memory :) 3833 undef &main; # free gobs of memory :)
3657 }; 3834 };
3658 3835
3659 goto &main_loop; 3836 goto &main_loop;
3660} 3837}
… …
3817 3994
3818 cf::write_runtime_sync; # external watchdog should not bark 3995 cf::write_runtime_sync; # external watchdog should not bark
3819 3996
3820 trace "emergency_perl_save: flushing outstanding aio requests"; 3997 trace "emergency_perl_save: flushing outstanding aio requests";
3821 while (IO::AIO::nreqs || BDB::nreqs) { 3998 while (IO::AIO::nreqs || BDB::nreqs) {
3822 Coro::EV::timer_once 0.01; # let the sync_job do it's thing 3999 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
3823 } 4000 }
3824 4001
3825 cf::write_runtime_sync; # external watchdog should not bark 4002 cf::write_runtime_sync; # external watchdog should not bark
3826 }; 4003 };
3827 4004
… …
3876 4053
3877 my $t1 = AE::time; 4054 my $t1 = AE::time;
3878 4055
3879 while ($RELOAD) { 4056 while ($RELOAD) {
3880 cf::get_slot 0.1, -1, "reload_perl"; 4057 cf::get_slot 0.1, -1, "reload_perl";
3881 info "reloading..."; 4058 info "perl_reload: reloading...";
3882 4059
3883 trace "entering sync_job"; 4060 trace "perl_reload: entering sync_job";
3884 4061
3885 cf::sync_job { 4062 cf::sync_job {
3886 #cf::emergency_save; 4063 #cf::emergency_save;
3887 4064
3888 trace "cancelling all extension coros"; 4065 trace "perl_reload: cancelling all extension coros";
3889 $_->cancel for values %EXT_CORO; 4066 $_->cancel for values %EXT_CORO;
3890 %EXT_CORO = (); 4067 %EXT_CORO = ();
3891 4068
3892 trace "removing commands"; 4069 trace "perl_reload: removing commands";
3893 %COMMAND = (); 4070 %COMMAND = ();
3894 4071
3895 trace "removing ext/exti commands"; 4072 trace "perl_reload: removing ext/exti commands";
3896 %EXTCMD = (); 4073 %EXTCMD = ();
3897 %EXTICMD = (); 4074 %EXTICMD = ();
3898 4075
3899 trace "unloading/nuking all extensions"; 4076 trace "perl_reload: unloading/nuking all extensions";
3900 for my $pkg (@EXTS) { 4077 for my $pkg (@EXTS) {
3901 trace "... unloading $pkg"; 4078 trace "... unloading $pkg";
3902 4079
3903 if (my $cb = $pkg->can ("unload")) { 4080 if (my $cb = $pkg->can ("unload")) {
3904 eval { 4081 eval {
… …
3909 4086
3910 trace "... clearing $pkg"; 4087 trace "... clearing $pkg";
3911 clear_package $pkg; 4088 clear_package $pkg;
3912 } 4089 }
3913 4090
3914 trace "unloading all perl modules loaded from $LIBDIR"; 4091 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3915 while (my ($k, $v) = each %INC) { 4092 while (my ($k, $v) = each %INC) {
3916 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 4093 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3917 4094
3918 trace "... unloading $k"; 4095 trace "... unloading $k";
3919 delete $INC{$k}; 4096 delete $INC{$k};
… …
3926 } 4103 }
3927 4104
3928 clear_package $k; 4105 clear_package $k;
3929 } 4106 }
3930 4107
3931 trace "getting rid of safe::, as good as possible"; 4108 trace "perl_reload: getting rid of safe::, as good as possible";
3932 clear_package "safe::$_" 4109 clear_package "safe::$_"
3933 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 4110 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3934 4111
3935 trace "unloading cf.pm \"a bit\""; 4112 trace "perl_reload: unloading cf.pm \"a bit\"";
3936 delete $INC{"cf.pm"}; 4113 delete $INC{"cf.pm"};
3937 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 4114 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3938 4115
3939 # don't, removes xs symbols, too, 4116 # don't, removes xs symbols, too,
3940 # and global variables created in xs 4117 # and global variables created in xs
3941 #clear_package __PACKAGE__; 4118 #clear_package __PACKAGE__;
3942 4119
3943 info "unload completed, starting to reload now"; 4120 info "perl_reload: unload completed, starting to reload now";
3944 4121
3945 trace "reloading cf.pm"; 4122 trace "perl_reload: reloading cf.pm";
3946 require cf; 4123 require cf;
3947 cf::_connect_to_perl_1; 4124 cf::_connect_to_perl_1;
3948 4125
3949 trace "loading config and database again"; 4126 trace "perl_reload: loading config and database again";
3950 cf::reload_config; 4127 cf::reload_config;
3951 4128
3952 trace "loading extensions"; 4129 trace "perl_reload: loading extensions";
3953 cf::load_extensions; 4130 cf::load_extensions;
3954 4131
3955 if ($REATTACH_ON_RELOAD) { 4132 if ($REATTACH_ON_RELOAD) {
3956 trace "reattaching attachments to objects/players"; 4133 trace "perl_reload: reattaching attachments to objects/players";
3957 _global_reattach; # objects, sockets 4134 _global_reattach; # objects, sockets
3958 trace "reattaching attachments to maps"; 4135 trace "perl_reload: reattaching attachments to maps";
3959 reattach $_ for values %MAP; 4136 reattach $_ for values %MAP;
3960 trace "reattaching attachments to players"; 4137 trace "perl_reload: reattaching attachments to players";
3961 reattach $_ for values %PLAYER; 4138 reattach $_ for values %PLAYER;
3962 } 4139 }
3963 4140
3964 trace "running post_init jobs"; 4141 cf::_post_init 1;
3965 (pop @POST_INIT)->(1) while @POST_INIT;
3966 4142
3967 trace "leaving sync_job"; 4143 trace "perl_reload: leaving sync_job";
3968 4144
3969 1 4145 1
3970 } or do { 4146 } or do {
3971 error $@; 4147 error $@;
3972 cf::cleanup "error while reloading, exiting."; 4148 cf::cleanup "perl_reload: error, exiting.";
3973 }; 4149 };
3974 4150
3975 info "reloaded";
3976 --$RELOAD; 4151 --$RELOAD;
3977 } 4152 }
3978 4153
3979 $t1 = AE::time - $t1; 4154 $t1 = AE::time - $t1;
3980 info "reload completed in ${t1}s\n"; 4155 info "perl_reload: completed in ${t1}s\n";
3981}; 4156};
3982 4157
3983our $RELOAD_WATCHER; # used only during reload 4158our $RELOAD_WATCHER; # used only during reload
3984 4159
3985sub reload_perl() { 4160sub reload_perl() {
… …
4010 4185
4011############################################################################# 4186#############################################################################
4012 4187
4013my $bug_warning = 0; 4188my $bug_warning = 0;
4014 4189
4015our @WAIT_FOR_TICK;
4016our @WAIT_FOR_TICK_BEGIN;
4017
4018sub wait_for_tick() { 4190sub wait_for_tick() {
4019 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4191 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4020 4192
4021 my $signal = new Coro::Signal; 4193 $WAIT_FOR_TICK->wait;
4022 push @WAIT_FOR_TICK, $signal;
4023 $signal->wait;
4024} 4194}
4025 4195
4026sub wait_for_tick_begin() { 4196sub wait_for_tick_begin() {
4027 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4197 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4028 4198
4029 my $signal = new Coro::Signal; 4199 my $signal = new Coro::Signal;
4030 push @WAIT_FOR_TICK_BEGIN, $signal; 4200 push @WAIT_FOR_TICK_BEGIN, $signal;
4031 $signal->wait; 4201 $signal->wait;
4032} 4202}
… …
4036 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4206 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4037 unless ++$bug_warning > 10; 4207 unless ++$bug_warning > 10;
4038 return; 4208 return;
4039 } 4209 }
4040 4210
4041 cf::server_tick; # one server iteration 4211 cf::one_tick; # one server iteration
4042 4212
4043 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d# 4213 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4044 4214
4045 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4215 if ($NOW >= $NEXT_RUNTIME_WRITE) {
4046 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4216 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
… …
4052 } 4222 }
4053 4223
4054 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4224 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4055 $sig->send; 4225 $sig->send;
4056 } 4226 }
4057 while (my $sig = shift @WAIT_FOR_TICK) { 4227 $WAIT_FOR_TICK->broadcast;
4058 $sig->send;
4059 }
4060 4228
4061 $LOAD = ($NOW - $TICK_START) / $TICK; 4229 $LOAD = ($NOW - $TICK_START) / $TICK;
4062 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4230 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4063 4231
4064 if (0) { 4232 if (0) {
… …
4073{ 4241{
4074 # configure BDB 4242 # configure BDB
4075 4243
4076 BDB::min_parallel 16; 4244 BDB::min_parallel 16;
4077 BDB::max_poll_reqs $TICK * 0.1; 4245 BDB::max_poll_reqs $TICK * 0.1;
4078 $AnyEvent::BDB::WATCHER->priority (1); 4246 #$AnyEvent::BDB::WATCHER->priority (1);
4079 4247
4080 unless ($DB_ENV) { 4248 unless ($DB_ENV) {
4081 $DB_ENV = BDB::db_env_create; 4249 $DB_ENV = BDB::db_env_create;
4082 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); 4250 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4083 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4251 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
… …
4118 IO::AIO::min_parallel 8; 4286 IO::AIO::min_parallel 8;
4119 IO::AIO::max_poll_time $TICK * 0.1; 4287 IO::AIO::max_poll_time $TICK * 0.1;
4120 undef $AnyEvent::AIO::WATCHER; 4288 undef $AnyEvent::AIO::WATCHER;
4121} 4289}
4122 4290
4123my $_log_backtrace; 4291our $_log_backtrace;
4292our $_log_backtrace_last;
4124 4293
4125sub _log_backtrace { 4294sub _log_backtrace {
4126 my ($msg, @addr) = @_; 4295 my ($msg, @addr) = @_;
4127 4296
4128 $msg =~ s/\n//; 4297 $msg =~ s/\n$//;
4129 4298
4299 if ($_log_backtrace_last eq $msg) {
4300 LOG llevInfo, "[ABT] $msg\n";
4301 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
4130 # limit the # of concurrent backtraces 4302 # limit the # of concurrent backtraces
4131 if ($_log_backtrace < 2) { 4303 } elsif ($_log_backtrace < 2) {
4304 $_log_backtrace_last = $msg;
4132 ++$_log_backtrace; 4305 ++$_log_backtrace;
4133 my $perl_bt = Carp::longmess $msg; 4306 my $perl_bt = Carp::longmess $msg;
4134 async { 4307 async {
4135 $Coro::current->{desc} = "abt $msg"; 4308 $Coro::current->{desc} = "abt $msg";
4136 4309
… …
4156 LOG llevInfo, "[ABT] $_\n" for @bt; 4329 LOG llevInfo, "[ABT] $_\n" for @bt;
4157 --$_log_backtrace; 4330 --$_log_backtrace;
4158 }; 4331 };
4159 } else { 4332 } else {
4160 LOG llevInfo, "[ABT] $msg\n"; 4333 LOG llevInfo, "[ABT] $msg\n";
4161 LOG llevInfo, "[ABT] [suppressed]\n"; 4334 LOG llevInfo, "[ABT] [overload, suppressed]\n";
4162 } 4335 }
4163} 4336}
4164 4337
4165# load additional modules 4338# load additional modules
4166require "cf/$_.pm" for @EXTRA_MODULES; 4339require "cf/$_.pm" for @EXTRA_MODULES;

Diff Legend

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