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.478 by root, Thu Sep 17 01:57:31 2009 UTC vs.
Revision 1.551 by root, Sun May 16 13:48:07 2010 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 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify 6# Deliantra is free software: you can redistribute it and/or modify it under
7# it under the terms of the GNU General Public License as published by 7# the terms of the Affero GNU General Public License as published by the
8# the Free Software Foundation, either version 3 of the License, or 8# Free Software Foundation, either version 3 of the License, or (at your
9# (at your 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 GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>. 17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
18# 19#
19# 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>
20# 21#
21 22
22package cf; 23package cf;
23 24
24use 5.10.0; 25use common::sense;
25use utf8;
26use strict qw(vars subs);
27 26
28use Symbol; 27use Symbol;
29use List::Util; 28use List::Util;
30use Socket; 29use Socket;
31use EV; 30use EV;
32use Opcode; 31use Opcode;
33use Safe; 32use Safe;
34use Safe::Hole; 33use Safe::Hole;
35use Storable (); 34use Storable ();
35use Carp ();
36 36
37use Guard (); 37use Guard ();
38use Coro (); 38use Coro ();
39use Coro::State; 39use Coro::State;
40use Coro::Handle; 40use Coro::Handle;
… …
51use Coro::Util (); 51use Coro::Util ();
52 52
53use JSON::XS 2.01 (); 53use JSON::XS 2.01 ();
54use BDB (); 54use BDB ();
55use Data::Dumper; 55use Data::Dumper;
56use Digest::MD5;
57use Fcntl; 56use Fcntl;
58use YAML (); 57use YAML::XS ();
59use IO::AIO (); 58use IO::AIO ();
60use Time::HiRes; 59use Time::HiRes;
61use Compress::LZF; 60use Compress::LZF;
62use Digest::MD5 (); 61use Digest::MD5 ();
63 62
… …
76 75
77# strictly for debugging 76# strictly for debugging
78$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" }; 77$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
79 78
80sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
80
81our @ORIG_INC;
81 82
82our %COMMAND = (); 83our %COMMAND = ();
83our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
84 85
85our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
… …
88our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
89our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
90 91
91our $RELOAD; # number of reloads so far, non-zero while in reload 92our $RELOAD; # number of reloads so far, non-zero while in reload
92our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
93 96
94our $CONFDIR = confdir; 97our $CONFDIR = confdir;
95our $DATADIR = datadir; 98our $DATADIR = datadir;
96our $LIBDIR = "$DATADIR/ext"; 99our $LIBDIR = "$DATADIR/ext";
97our $PODDIR = "$DATADIR/pod"; 100our $PODDIR = "$DATADIR/pod";
… …
103our $RANDOMDIR = "$LOCALDIR/random"; 106our $RANDOMDIR = "$LOCALDIR/random";
104our $BDBDIR = "$LOCALDIR/db"; 107our $BDBDIR = "$LOCALDIR/db";
105our $PIDFILE = "$LOCALDIR/pid"; 108our $PIDFILE = "$LOCALDIR/pid";
106our $RUNTIMEFILE = "$LOCALDIR/runtime"; 109our $RUNTIMEFILE = "$LOCALDIR/runtime";
107 110
108our %RESOURCE; 111our %RESOURCE; # unused
112
113our $OUTPUT_RATE_MIN = 3000;
114our $OUTPUT_RATE_MAX = 1000000;
115
116our $MAX_LINKS = 32; # how many chained exits to follow
117our $VERBOSE_IO = 1;
109 118
110our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 119our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
111our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
112our $NEXT_TICK; 121our $NEXT_TICK;
113our $USE_FSYNC = 1; # use fsync to write maps - default on 122our $USE_FSYNC = 1; # use fsync to write maps - default on
… …
115our $BDB_DEADLOCK_WATCHER; 124our $BDB_DEADLOCK_WATCHER;
116our $BDB_CHECKPOINT_WATCHER; 125our $BDB_CHECKPOINT_WATCHER;
117our $BDB_TRICKLE_WATCHER; 126our $BDB_TRICKLE_WATCHER;
118our $DB_ENV; 127our $DB_ENV;
119 128
120our @EXTRA_MODULES = qw(pod mapscript); 129our @EXTRA_MODULES = qw(pod match mapscript incloader);
121 130
122our %CFG; 131our %CFG;
123 132
124our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
125our $RUNTIME; 134our $RUNTIME;
… …
159 168
160our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
161 170
162sub cf::map::normalise; 171sub cf::map::normalise;
163 172
173sub in_main() {
174 $Coro::current == $Coro::main
175}
176
177#############################################################################
178
179%REFLECT = ();
180for (@REFLECT) {
181 my $reflect = JSON::XS::decode_json $_;
182 $REFLECT{$reflect->{class}} = $reflect;
183}
184
185# this is decidedly evil
186$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
187
164############################################################################# 188#############################################################################
165 189
166=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
167 191
168=over 4 192=over 4
… …
209from wherever your confdir points to. 233from wherever your confdir points to.
210 234
211=item cf::wait_for_tick, cf::wait_for_tick_begin 235=item cf::wait_for_tick, cf::wait_for_tick_begin
212 236
213These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 237These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
214returns directly I<after> the tick processing (and consequently, can only wake one process 238returns directly I<after> the tick processing (and consequently, can only wake one thread
215per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 239per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
216 240
241=cut
242
243sub wait_for_tick();
244sub wait_for_tick_begin();
245
217=item @cf::INVOKE_RESULTS 246=item @cf::INVOKE_RESULTS
218 247
219This array contains the results of the last C<invoke ()> call. When 248This array contains the results of the last C<invoke ()> call. When
220C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 249C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
221that call. 250that call.
222 251
252=item %cf::REFLECT
253
254Contains, for each (C++) class name, a hash reference with information
255about object members (methods, scalars, arrays and flags) and other
256metadata, which is useful for introspection.
257
223=back 258=back
224 259
225=cut 260=cut
261
262sub error(@) { LOG llevError, join "", @_ }
263sub warn (@) { LOG llevWarn , join "", @_ }
264sub info (@) { LOG llevInfo , join "", @_ }
265sub debug(@) { LOG llevDebug, join "", @_ }
266sub trace(@) { LOG llevTrace, join "", @_ }
226 267
227$Coro::State::WARNHOOK = sub { 268$Coro::State::WARNHOOK = sub {
228 my $msg = join "", @_; 269 my $msg = join "", @_;
229 270
230 $msg .= "\n" 271 $msg .= "\n"
231 unless $msg =~ /\n$/; 272 unless $msg =~ /\n$/;
232 273
233 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 274 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
234 275
235 LOG llevError, $msg; 276 LOG llevWarn, $msg;
236}; 277};
237 278
238$Coro::State::DIEHOOK = sub { 279$Coro::State::DIEHOOK = sub {
239 return unless $^S eq 0; # "eq", not "==" 280 return unless $^S eq 0; # "eq", not "=="
240 281
241 warn Carp::longmess $_[0]; 282 error Carp::longmess $_[0];
242 283
243 if ($Coro::current == $Coro::main) {#d# 284 if (in_main) {#d#
244 warn "DIEHOOK called in main context, Coro bug?\n";#d# 285 error "DIEHOOK called in main context, Coro bug?\n";#d#
245 return;#d# 286 return;#d#
246 }#d# 287 }#d#
247 288
248 # kill coroutine otherwise 289 # kill coroutine otherwise
249 Coro::terminate 290 Coro::terminate
… …
269)) { 310)) {
270 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 311 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
271} 312}
272 313
273$EV::DIED = sub { 314$EV::DIED = sub {
274 warn "error in event callback: @_"; 315 Carp::cluck "error in event callback: @_";
275}; 316};
276 317
277############################################################################# 318#############################################################################
278 319
279=head2 UTILITY FUNCTIONS 320=head2 UTILITY FUNCTIONS
… …
316our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 357our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
317 358
318sub encode_json($) { $json_coder->encode ($_[0]) } 359sub encode_json($) { $json_coder->encode ($_[0]) }
319sub decode_json($) { $json_coder->decode ($_[0]) } 360sub decode_json($) { $json_coder->decode ($_[0]) }
320 361
362=item $ref = cf::yaml_load $scalar
363
364Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
365
366=cut
367
368sub fork_call(&@);
369
370sub yaml_load($) {
371 fork_call { YAML::XS::Load $_[0] } @_
372}
373
321=item cf::post_init { BLOCK } 374=item cf::post_init { BLOCK }
322 375
323Execute the given codeblock, I<after> all extensions have been (re-)loaded, 376Execute the given codeblock, I<after> all extensions have been (re-)loaded,
324but I<before> the server starts ticking again. 377but I<before> the server starts ticking again.
325 378
326The cdoeblock will have a single boolean argument to indicate whether this 379The codeblock will have a single boolean argument to indicate whether this
327is a reload or not. 380is a reload or not.
328 381
329=cut 382=cut
330 383
331sub post_init(&) { 384sub post_init(&) {
332 push @POST_INIT, shift; 385 push @POST_INIT, shift;
386}
387
388sub _post_init {
389 trace "running post_init jobs";
390
391 # run them in parallel...
392
393 my @join;
394
395 while () {
396 push @join, map &Coro::async ($_, 0), @POST_INIT;
397 @POST_INIT = ();
398
399 @join or last;
400
401 (pop @join)->join;
402 }
333} 403}
334 404
335=item cf::lock_wait $string 405=item cf::lock_wait $string
336 406
337Wait until the given lock is available. See cf::lock_acquire. 407Wait until the given lock is available. See cf::lock_acquire.
… …
376} 446}
377 447
378=item cf::periodic $interval, $cb 448=item cf::periodic $interval, $cb
379 449
380Like EV::periodic, but randomly selects a starting point so that the actions 450Like EV::periodic, but randomly selects a starting point so that the actions
381get spread over timer. 451get spread over time.
382 452
383=cut 453=cut
384 454
385sub periodic($$) { 455sub periodic($$) {
386 my ($interval, $cb) = @_; 456 my ($interval, $cb) = @_;
… …
403 473
404=cut 474=cut
405 475
406our @SLOT_QUEUE; 476our @SLOT_QUEUE;
407our $SLOT_QUEUE; 477our $SLOT_QUEUE;
478our $SLOT_DECAY = 0.9;
408 479
409$SLOT_QUEUE->cancel if $SLOT_QUEUE; 480$SLOT_QUEUE->cancel if $SLOT_QUEUE;
410$SLOT_QUEUE = Coro::async { 481$SLOT_QUEUE = Coro::async {
411 $Coro::current->desc ("timeslot manager"); 482 $Coro::current->desc ("timeslot manager");
412 483
413 my $signal = new Coro::Signal; 484 my $signal = new Coro::Signal;
485 my $busy;
414 486
415 while () { 487 while () {
416 next_job: 488 next_job:
489
417 my $avail = cf::till_tick; 490 my $avail = cf::till_tick;
418 if ($avail > 0.01) { 491
419 for (0 .. $#SLOT_QUEUE) { 492 for (0 .. $#SLOT_QUEUE) {
420 if ($SLOT_QUEUE[$_][0] < $avail) { 493 if ($SLOT_QUEUE[$_][0] <= $avail) {
494 $busy = 0;
421 my $job = splice @SLOT_QUEUE, $_, 1, (); 495 my $job = splice @SLOT_QUEUE, $_, 1, ();
422 $job->[2]->send; 496 $job->[2]->send;
423 Coro::cede; 497 Coro::cede;
424 goto next_job; 498 goto next_job;
425 } 499 } else {
500 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
426 } 501 }
427 } 502 }
428 503
429 if (@SLOT_QUEUE) { 504 if (@SLOT_QUEUE) {
430 # we do not use wait_for_tick() as it returns immediately when tick is inactive 505 # we do not use wait_for_tick() as it returns immediately when tick is inactive
431 push @cf::WAIT_FOR_TICK, $signal; 506 push @cf::WAIT_FOR_TICK, $signal;
432 $signal->wait; 507 $signal->wait;
433 } else { 508 } else {
509 $busy = 0;
434 Coro::schedule; 510 Coro::schedule;
435 } 511 }
436 } 512 }
437}; 513};
438 514
439sub get_slot($;$$) { 515sub get_slot($;$$) {
440 return if tick_inhibit || $Coro::current == $Coro::main; 516 return if tick_inhibit || $Coro::current == $Coro::main;
441 517
442 my ($time, $pri, $name) = @_; 518 my ($time, $pri, $name) = @_;
443 519
444 $time = $TICK * .6 if $time > $TICK * .6; 520 $time = clamp $time, 0.01, $TICK * .6;
521
445 my $sig = new Coro::Signal; 522 my $sig = new Coro::Signal;
446 523
447 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 524 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
448 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 525 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
449 $SLOT_QUEUE->ready; 526 $SLOT_QUEUE->ready;
… …
475=cut 552=cut
476 553
477sub sync_job(&) { 554sub sync_job(&) {
478 my ($job) = @_; 555 my ($job) = @_;
479 556
480 if ($Coro::current == $Coro::main) { 557 if (in_main) {
481 my $time = EV::time; 558 my $time = AE::time;
482 559
483 # this is the main coro, too bad, we have to block 560 # this is the main coro, too bad, we have to block
484 # till the operation succeeds, freezing the server :/ 561 # till the operation succeeds, freezing the server :/
485 562
486 LOG llevError, Carp::longmess "sync job";#d# 563 #LOG llevError, Carp::longmess "sync job";#d#
487 564
488 my $freeze_guard = freeze_mainloop; 565 my $freeze_guard = freeze_mainloop;
489 566
490 my $busy = 1; 567 my $busy = 1;
491 my @res; 568 my @res;
492 569
493 (async { 570 (async {
494 $Coro::current->desc ("sync job coro"); 571 $Coro::current->desc ("sync job coro");
495 @res = eval { $job->() }; 572 @res = eval { $job->() };
496 warn $@ if $@; 573 error $@ if $@;
497 undef $busy; 574 undef $busy;
498 })->prio (Coro::PRIO_MAX); 575 })->prio (Coro::PRIO_MAX);
499 576
500 while ($busy) { 577 while ($busy) {
501 if (Coro::nready) { 578 if (Coro::nready) {
… …
503 } else { 580 } else {
504 EV::loop EV::LOOP_ONESHOT; 581 EV::loop EV::LOOP_ONESHOT;
505 } 582 }
506 } 583 }
507 584
508 my $time = EV::time - $time; 585 my $time = AE::time - $time;
509 586
510 $TICK_START += $time; # do not account sync jobs to server load 587 $TICK_START += $time; # do not account sync jobs to server load
511 588
512 wantarray ? @res : $res[0] 589 wantarray ? @res : $res[0]
513 } else { 590 } else {
… …
535 $EXT_CORO{$coro+0} = $coro; 612 $EXT_CORO{$coro+0} = $coro;
536 613
537 $coro 614 $coro
538} 615}
539 616
540=item fork_call { }, $args 617=item fork_call { }, @args
541 618
542Executes the given code block with the given arguments in a seperate 619Executes the given code block with the given arguments in a seperate
543process, returning the results. Everything must be serialisable with 620process, returning the results. Everything must be serialisable with
544Coro::Storable. May, of course, block. Note that the executed sub may 621Coro::Storable. May, of course, block. Note that the executed sub may
545never block itself or use any form of event handling. 622never block itself or use any form of event handling.
546 623
547=cut 624=cut
548 625
626sub post_fork {
627 reset_signals;
628}
629
549sub fork_call(&@) { 630sub fork_call(&@) {
550 my ($cb, @args) = @_; 631 my ($cb, @args) = @_;
551 632
552 # we seemingly have to make a local copy of the whole thing, 633 # we seemingly have to make a local copy of the whole thing,
553 # otherwise perl prematurely frees the stuff :/ 634 # otherwise perl prematurely frees the stuff :/
554 # TODO: investigate and fix (likely this will be rather laborious) 635 # TODO: investigate and fix (likely this will be rather laborious)
555 636
556 my @res = Coro::Util::fork_eval { 637 my @res = Coro::Util::fork_eval {
557 reset_signals; 638 cf::post_fork;
558 &$cb 639 &$cb
559 }, @args; 640 } @args;
560 641
561 wantarray ? @res : $res[-1] 642 wantarray ? @res : $res[-1]
643}
644
645sub objinfo {
646 (
647 "counter value" => cf::object::object_count,
648 "objects created" => cf::object::create_count,
649 "objects destroyed" => cf::object::destroy_count,
650 "freelist size" => cf::object::free_count,
651 "allocated objects" => cf::object::objects_size,
652 "active objects" => cf::object::actives_size,
653 )
562} 654}
563 655
564=item $coin = coin_from_name $name 656=item $coin = coin_from_name $name
565 657
566=cut 658=cut
… …
603within each server. 695within each server.
604 696
605=cut 697=cut
606 698
607sub db_table($) { 699sub db_table($) {
700 cf::error "db_get called from main context"
701 if $Coro::current == $Coro::main;
702
608 my ($name) = @_; 703 my ($name) = @_;
609 my $db = BDB::db_create $DB_ENV; 704 my $db = BDB::db_create $DB_ENV;
610 705
611 eval { 706 eval {
612 $db->set_flags (BDB::CHKSUM); 707 $db->set_flags (BDB::CHKSUM);
… …
622} 717}
623 718
624our $DB; 719our $DB;
625 720
626sub db_init { 721sub db_init {
627 cf::sync_job {
628 $DB ||= db_table "db"; 722 $DB ||= db_table "db";
629 };
630} 723}
631 724
632sub db_get($$) { 725sub db_get($$) {
633 my $key = "$_[0]/$_[1]"; 726 my $key = "$_[0]/$_[1]";
634 727
635 cf::sync_job { 728 cf::error "db_get called from main context"
729 if $Coro::current == $Coro::main;
730
636 BDB::db_get $DB, undef, $key, my $data; 731 BDB::db_get $DB, undef, $key, my $data;
637 732
638 $! ? () 733 $! ? ()
639 : $data 734 : $data
640 }
641} 735}
642 736
643sub db_put($$$) { 737sub db_put($$$) {
644 BDB::dbreq_pri 4; 738 BDB::dbreq_pri 4;
645 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 739 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
701 795
702 my $t1 = Time::HiRes::time; 796 my $t1 = Time::HiRes::time;
703 my $data = $process->(\@data); 797 my $data = $process->(\@data);
704 my $t2 = Time::HiRes::time; 798 my $t2 = Time::HiRes::time;
705 799
706 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 800 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
707 801
708 db_put cache => "$id/data", $data; 802 db_put cache => "$id/data", $data;
709 db_put cache => "$id/md5" , $md5; 803 db_put cache => "$id/md5" , $md5;
710 db_put cache => "$id/meta", $meta; 804 db_put cache => "$id/meta", $meta;
711 805
… …
721 815
722=cut 816=cut
723 817
724sub datalog($@) { 818sub datalog($@) {
725 my ($type, %kv) = @_; 819 my ($type, %kv) = @_;
726 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 820 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
727} 821}
728 822
729=back 823=back
730 824
731=cut 825=cut
… …
926 1020
927 } elsif (exists $cb_id{$type}) { 1021 } elsif (exists $cb_id{$type}) {
928 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 1022 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
929 1023
930 } elsif (ref $type) { 1024 } elsif (ref $type) {
931 warn "attaching objects not supported, ignoring.\n"; 1025 error "attaching objects not supported, ignoring.\n";
932 1026
933 } else { 1027 } else {
934 shift @arg; 1028 shift @arg;
935 warn "attach argument '$type' not supported, ignoring.\n"; 1029 error "attach argument '$type' not supported, ignoring.\n";
936 } 1030 }
937 } 1031 }
938} 1032}
939 1033
940sub _object_attach { 1034sub _object_attach {
… …
950 _attach $registry, $klass, @attach; 1044 _attach $registry, $klass, @attach;
951 } 1045 }
952 1046
953 $obj->{$name} = \%arg; 1047 $obj->{$name} = \%arg;
954 } else { 1048 } else {
955 warn "object uses attachment '$name' which is not available, postponing.\n"; 1049 info "object uses attachment '$name' which is not available, postponing.\n";
956 } 1050 }
957 1051
958 $obj->{_attachment}{$name} = undef; 1052 $obj->{_attachment}{$name} = undef;
959} 1053}
960 1054
… …
1019 1113
1020 for (@$callbacks) { 1114 for (@$callbacks) {
1021 eval { &{$_->[1]} }; 1115 eval { &{$_->[1]} };
1022 1116
1023 if ($@) { 1117 if ($@) {
1024 warn "$@";
1025 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1118 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1026 override; 1119 override;
1027 } 1120 }
1028 1121
1029 return 1 if $override; 1122 return 1 if $override;
1030 } 1123 }
… …
1109 for (@$attach) { 1202 for (@$attach) {
1110 my ($klass, @attach) = @$_; 1203 my ($klass, @attach) = @$_;
1111 _attach $registry, $klass, @attach; 1204 _attach $registry, $klass, @attach;
1112 } 1205 }
1113 } else { 1206 } else {
1114 warn "object uses attachment '$name' that is not available, postponing.\n"; 1207 info "object uses attachment '$name' that is not available, postponing.\n";
1115 } 1208 }
1116 } 1209 }
1117} 1210}
1118 1211
1119cf::attachable->attach ( 1212cf::attachable->attach (
… …
1146 my ($filename, $rdata, $objs) = @_; 1239 my ($filename, $rdata, $objs) = @_;
1147 1240
1148 sync_job { 1241 sync_job {
1149 if (length $$rdata) { 1242 if (length $$rdata) {
1150 utf8::decode (my $decname = $filename); 1243 utf8::decode (my $decname = $filename);
1151 warn sprintf "saving %s (%d,%d)\n", 1244 trace sprintf "saving %s (%d,%d)\n",
1152 $decname, length $$rdata, scalar @$objs; 1245 $decname, length $$rdata, scalar @$objs
1246 if $VERBOSE_IO;
1153 1247
1154 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1248 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1155 aio_chmod $fh, SAVE_MODE; 1249 aio_chmod $fh, SAVE_MODE;
1156 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1250 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1157 if ($cf::USE_FSYNC) { 1251 if ($cf::USE_FSYNC) {
… …
1179 aio_rename "$filename~", $filename; 1273 aio_rename "$filename~", $filename;
1180 1274
1181 $filename =~ s%/[^/]+$%%; 1275 $filename =~ s%/[^/]+$%%;
1182 aio_pathsync $filename if $cf::USE_FSYNC; 1276 aio_pathsync $filename if $cf::USE_FSYNC;
1183 } else { 1277 } else {
1184 warn "unable to save objects: $filename~: $!\n"; 1278 error "unable to save objects: $filename~: $!\n";
1185 } 1279 }
1186 } else { 1280 } else {
1187 aio_unlink $filename; 1281 aio_unlink $filename;
1188 aio_unlink "$filename.pst"; 1282 aio_unlink "$filename.pst";
1189 } 1283 }
… …
1213 my $st = eval { Coro::Storable::thaw $av }; 1307 my $st = eval { Coro::Storable::thaw $av };
1214 $av = $st->{objs}; 1308 $av = $st->{objs};
1215 } 1309 }
1216 1310
1217 utf8::decode (my $decname = $filename); 1311 utf8::decode (my $decname = $filename);
1218 warn sprintf "loading %s (%d,%d)\n", 1312 trace sprintf "loading %s (%d,%d)\n",
1219 $decname, length $data, scalar @{$av || []}; 1313 $decname, length $data, scalar @{$av || []}
1314 if $VERBOSE_IO;
1220 1315
1221 ($data, $av) 1316 ($data, $av)
1222} 1317}
1223 1318
1224=head2 COMMAND CALLBACKS 1319=head2 COMMAND CALLBACKS
… …
1283} 1378}
1284 1379
1285use File::Glob (); 1380use File::Glob ();
1286 1381
1287cf::player->attach ( 1382cf::player->attach (
1288 on_command => sub { 1383 on_unknown_command => sub {
1289 my ($pl, $name, $params) = @_; 1384 my ($pl, $name, $params) = @_;
1290 1385
1291 my $cb = $COMMAND{$name} 1386 my $cb = $COMMAND{$name}
1292 or return; 1387 or return;
1293 1388
… …
1316 1411
1317 $pl->ext_reply ($reply, @reply) 1412 $pl->ext_reply ($reply, @reply)
1318 if $reply; 1413 if $reply;
1319 1414
1320 } else { 1415 } else {
1321 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1416 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1322 } 1417 }
1323 1418
1324 cf::override; 1419 cf::override;
1325 }, 1420 },
1326); 1421);
… …
1337 1432
1338 $grp 1433 $grp
1339} 1434}
1340 1435
1341sub load_extensions { 1436sub load_extensions {
1437 info "loading extensions...";
1438
1342 cf::sync_job { 1439 cf::sync_job {
1343 my %todo; 1440 my %todo;
1344 1441
1345 for my $path (<$LIBDIR/*.ext>) { 1442 for my $path (<$LIBDIR/*.ext>) {
1346 next unless -r $path; 1443 next unless -r $path;
… …
1364 1461
1365 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1462 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1366 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1463 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1367 1464
1368 $ext{source} = 1465 $ext{source} =
1369 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" 1466 "package $pkg; use common::sense;\n"
1370 . "#line 1 \"$path\"\n{\n" 1467 . "#line 1 \"$path\"\n{\n"
1371 . $source 1468 . $source
1372 . "\n};\n1"; 1469 . "\n};\n1";
1373 1470
1374 $todo{$base} = \%ext; 1471 $todo{$base} = \%ext;
1375 } 1472 }
1376 1473
1474 my $pass = 0;
1377 my %done; 1475 my %done;
1378 while (%todo) { 1476 while (%todo) {
1379 my $progress; 1477 my $progress;
1380 1478
1479 ++$pass;
1480
1481 ext:
1381 while (my ($k, $v) = each %todo) { 1482 while (my ($k, $v) = each %todo) {
1382 for (split /,\s*/, $v->{meta}{depends}) { 1483 for (split /,\s*/, $v->{meta}{depends}) {
1383 goto skip 1484 next ext
1384 unless exists $done{$_}; 1485 unless exists $done{$_};
1385 } 1486 }
1386 1487
1387 warn "... loading '$k' into '$v->{pkg}'\n"; 1488 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1388 1489
1389 unless (eval $v->{source}) { 1490 my $active = eval $v->{source};
1491
1492 if (length $@) {
1390 my $msg = $@ ? "$v->{path}: $@\n" 1493 error "$v->{path}: $@\n";
1391 : "$v->{base}: extension inactive.\n";
1392 1494
1393 if (exists $v->{meta}{mandatory}) {
1394 warn $msg;
1395 cf::cleanup "mandatory extension failed to load, exiting."; 1495 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1396 } 1496 if exists $v->{meta}{mandatory};
1397 1497
1398 warn $msg; 1498 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1499 delete $todo{$k};
1500 } else {
1501 $done{$k} = delete $todo{$k};
1502 push @EXTS, $v->{pkg};
1503 $progress = 1;
1504
1505 info "$v->{base}: extension inactive.\n"
1506 unless $active;
1399 } 1507 }
1400
1401 $done{$k} = delete $todo{$k};
1402 push @EXTS, $v->{pkg};
1403 $progress = 1;
1404 } 1508 }
1405 1509
1406 skip: 1510 unless ($progress) {
1407 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1511 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1408 unless $progress; 1512
1513 while (my ($k, $v) = each %todo) {
1514 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1515 if exists $v->{meta}{mandatory};
1516 }
1517 }
1409 } 1518 }
1410 }; 1519 };
1411} 1520}
1412 1521
1413############################################################################# 1522#############################################################################
… …
1497 $cf::PLAYER{$login} = $pl 1606 $cf::PLAYER{$login} = $pl
1498 } 1607 }
1499 } 1608 }
1500} 1609}
1501 1610
1611cf::player->attach (
1612 on_load => sub {
1613 my ($pl, $path) = @_;
1614
1615 # restore slots saved in save, below
1616 my $slots = delete $pl->{_slots};
1617
1618 $pl->ob->current_weapon ($slots->[0]);
1619 $pl->combat_ob ($slots->[1]);
1620 $pl->ranged_ob ($slots->[2]);
1621 },
1622);
1623
1502sub save($) { 1624sub save($) {
1503 my ($pl) = @_; 1625 my ($pl) = @_;
1504 1626
1505 return if $pl->{deny_save}; 1627 return if $pl->{deny_save};
1506 1628
… …
1511 1633
1512 aio_mkdir playerdir $pl, 0770; 1634 aio_mkdir playerdir $pl, 0770;
1513 $pl->{last_save} = $cf::RUNTIME; 1635 $pl->{last_save} = $cf::RUNTIME;
1514 1636
1515 cf::get_slot 0.01; 1637 cf::get_slot 0.01;
1638
1639 # save slots, to be restored later
1640 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1516 1641
1517 $pl->save_pl ($path); 1642 $pl->save_pl ($path);
1518 cf::cede_to_tick; 1643 cf::cede_to_tick;
1519} 1644}
1520 1645
… …
1554 my $name = $pl->ob->name; 1679 my $name = $pl->ob->name;
1555 1680
1556 $pl->{deny_save} = 1; 1681 $pl->{deny_save} = 1;
1557 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1682 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1558 1683
1559 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1684 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1560 $pl->deactivate; 1685 $pl->deactivate;
1686
1561 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1687 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1562 $pl->ob->check_score;
1563 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1688 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1689 ext::highscore::check ($pl->ob);
1690
1564 $pl->ns->destroy if $pl->ns; 1691 $pl->ns->destroy if $pl->ns;
1565 1692
1566 my $path = playerdir $pl; 1693 my $path = playerdir $pl;
1567 my $temp = "$path~$cf::RUNTIME~deleting~"; 1694 my $temp = "$path~$cf::RUNTIME~deleting~";
1568 aio_rename $path, $temp; 1695 aio_rename $path, $temp;
… …
1622 \@logins 1749 \@logins
1623} 1750}
1624 1751
1625=item $player->maps 1752=item $player->maps
1626 1753
1754=item cf::player::maps $login
1755
1627Returns an arrayref of map paths that are private for this 1756Returns an arrayref of map paths that are private for this
1628player. May block. 1757player. May block.
1629 1758
1630=cut 1759=cut
1631 1760
… …
1693=cut 1822=cut
1694 1823
1695sub find_by_path($) { 1824sub find_by_path($) {
1696 my ($path) = @_; 1825 my ($path) = @_;
1697 1826
1827 $path =~ s/^~[^\/]*//; # skip ~login
1828
1698 my ($match, $specificity); 1829 my ($match, $specificity);
1699 1830
1700 for my $region (list) { 1831 for my $region (list) {
1701 if ($region->{match} && $path =~ $region->{match}) { 1832 if ($region->{match} && $path =~ $region->{match}) {
1702 ($match, $specificity) = ($region, $region->specificity) 1833 ($match, $specificity) = ($region, $region->specificity)
… …
1733 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1864 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1734 1865
1735 # mit "rum" bekleckern, nicht 1866 # mit "rum" bekleckern, nicht
1736 $self->_create_random_map ( 1867 $self->_create_random_map (
1737 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1868 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1738 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1869 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1739 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1870 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1740 $rmp->{exit_on_final_map}, 1871 $rmp->{exit_on_final_map},
1741 $rmp->{xsize}, $rmp->{ysize}, 1872 $rmp->{xsize}, $rmp->{ysize},
1742 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1873 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1743 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1874 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1758 1889
1759sub register { 1890sub register {
1760 my (undef, $regex, $prio) = @_; 1891 my (undef, $regex, $prio) = @_;
1761 my $pkg = caller; 1892 my $pkg = caller;
1762 1893
1763 no strict;
1764 push @{"$pkg\::ISA"}, __PACKAGE__; 1894 push @{"$pkg\::ISA"}, __PACKAGE__;
1765 1895
1766 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1896 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1767} 1897}
1768 1898
1769# also paths starting with '/' 1899# also paths starting with '/'
1770$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1900$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1771 1901
1772sub thawer_merge { 1902sub thawer_merge {
1773 my ($self, $merge) = @_; 1903 my ($self, $merge) = @_;
1774 1904
1775 # we have to keep some variables in memory intact 1905 # we have to keep some variables in memory intact
… …
1780} 1910}
1781 1911
1782sub normalise { 1912sub normalise {
1783 my ($path, $base) = @_; 1913 my ($path, $base) = @_;
1784 1914
1785 $path = "$path"; # make sure its a string 1915 $path = "$path"; # make sure it's a string
1786 1916
1787 $path =~ s/\.map$//; 1917 $path =~ s/\.map$//;
1788 1918
1789 # map plan: 1919 # map plan:
1790 # 1920 #
… …
1805 $base =~ s{[^/]+/?$}{}; 1935 $base =~ s{[^/]+/?$}{};
1806 $path = "$base/$path"; 1936 $path = "$base/$path";
1807 } 1937 }
1808 1938
1809 for ($path) { 1939 for ($path) {
1810 redo if s{//}{/};
1811 redo if s{/\.?/}{/}; 1940 redo if s{/\.?/}{/};
1812 redo if s{/[^/]+/\.\./}{/}; 1941 redo if s{/[^/]+/\.\./}{/};
1813 } 1942 }
1814 1943
1815 $path 1944 $path
… …
1829 $self->init; # pass $1 etc. 1958 $self->init; # pass $1 etc.
1830 return $self; 1959 return $self;
1831 } 1960 }
1832 } 1961 }
1833 1962
1834 Carp::cluck "unable to resolve path '$path' (base '$base')."; 1963 Carp::cluck "unable to resolve path '$path' (base '$base')";
1835 () 1964 ()
1836} 1965}
1837 1966
1838sub init { 1967sub init {
1839 my ($self) = @_; 1968 my ($self) = @_;
… …
1961} 2090}
1962 2091
1963sub find; 2092sub find;
1964sub find { 2093sub find {
1965 my ($path, $origin) = @_; 2094 my ($path, $origin) = @_;
2095
2096 cf::cede_to_tick;
1966 2097
1967 $path = normalise $path, $origin && $origin->path; 2098 $path = normalise $path, $origin && $origin->path;
1968 2099
1969 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2100 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1970 my $guard2 = cf::lock_acquire "map_find:$path"; 2101 my $guard2 = cf::lock_acquire "map_find:$path";
… …
1989 2120
1990 $cf::MAP{$path} = $map 2121 $cf::MAP{$path} = $map
1991 } 2122 }
1992} 2123}
1993 2124
1994sub pre_load { } 2125sub pre_load { }
1995sub post_load { } 2126#sub post_load { } # XS
1996 2127
1997sub load { 2128sub load {
1998 my ($self) = @_; 2129 my ($self) = @_;
1999 2130
2000 local $self->{deny_reset} = 1; # loading can take a long time 2131 local $self->{deny_reset} = 1; # loading can take a long time
… …
2057 } 2188 }
2058 2189
2059 $self->post_load; 2190 $self->post_load;
2060} 2191}
2061 2192
2193# customize the map for a given player, i.e.
2194# return the _real_ map. used by e.g. per-player
2195# maps to change the path to ~playername/mappath
2062sub customise_for { 2196sub customise_for {
2063 my ($self, $ob) = @_; 2197 my ($self, $ob) = @_;
2064 2198
2065 return find "~" . $ob->name . "/" . $self->{path} 2199 return find "~" . $ob->name . "/" . $self->{path}
2066 if $self->per_player; 2200 if $self->per_player;
… …
2082 or next; 2216 or next;
2083 $neigh = find $neigh, $map 2217 $neigh = find $neigh, $map
2084 or next; 2218 or next;
2085 $neigh->load; 2219 $neigh->load;
2086 2220
2221 # now find the diagonal neighbours
2087 push @neigh, 2222 push @neigh,
2088 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2223 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2089 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2224 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2090 } 2225 }
2091 2226
… …
2098} 2233}
2099 2234
2100sub find_sync { 2235sub find_sync {
2101 my ($path, $origin) = @_; 2236 my ($path, $origin) = @_;
2102 2237
2103 cf::sync_job { find $path, $origin } 2238 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2239 if $Coro::current == $Coro::main;
2240
2241 find $path, $origin
2104} 2242}
2105 2243
2106sub do_load_sync { 2244sub do_load_sync {
2107 my ($map) = @_; 2245 my ($map) = @_;
2108 2246
2109 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2247 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2110 if $Coro::current == $Coro::main; 2248 if $Coro::current == $Coro::main;
2111 2249
2112 cf::sync_job { $map->load }; 2250 $map->load;
2113} 2251}
2114 2252
2115our %MAP_PREFETCH; 2253our %MAP_PREFETCH;
2116our $MAP_PREFETCHER = undef; 2254our $MAP_PREFETCHER = undef;
2117 2255
… …
2143 $MAP_PREFETCHER->prio (6); 2281 $MAP_PREFETCHER->prio (6);
2144 2282
2145 () 2283 ()
2146} 2284}
2147 2285
2286# common code, used by both ->save and ->swapout
2148sub save { 2287sub _save {
2149 my ($self) = @_; 2288 my ($self) = @_;
2150
2151 my $lock = cf::lock_acquire "map_data:$self->{path}";
2152 2289
2153 $self->{last_save} = $cf::RUNTIME; 2290 $self->{last_save} = $cf::RUNTIME;
2154 2291
2155 return unless $self->dirty; 2292 return unless $self->dirty;
2156 2293
… …
2176 } else { 2313 } else {
2177 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2314 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2178 } 2315 }
2179} 2316}
2180 2317
2318sub save {
2319 my ($self) = @_;
2320
2321 my $lock = cf::lock_acquire "map_data:$self->{path}";
2322
2323 $self->_save;
2324}
2325
2181sub swap_out { 2326sub swap_out {
2182 my ($self) = @_; 2327 my ($self) = @_;
2183 2328
2184 # save first because save cedes
2185 $self->save;
2186
2187 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2329 my $lock = cf::lock_acquire "map_data:$self->{path}";
2188 2330
2189 return if $self->players;
2190 return if $self->in_memory != cf::MAP_ACTIVE; 2331 return if $self->in_memory != cf::MAP_ACTIVE;
2191 return if $self->{deny_save}; 2332 return if $self->{deny_save};
2333 return if $self->players;
2192 2334
2335 # first deactivate the map and "unlink" it from the core
2336 $self->deactivate;
2337 $_->clear_links_to ($self) for values %cf::MAP;
2193 $self->in_memory (cf::MAP_SWAPPED); 2338 $self->in_memory (cf::MAP_SWAPPED);
2339
2340 # then atomically save
2341 $self->_save;
2342
2343 # then free the map
2344 $self->clear;
2345}
2346
2347sub reset_at {
2348 my ($self) = @_;
2349
2350 # TODO: safety, remove and allow resettable per-player maps
2351 return 1e99 if $self->{deny_reset};
2352
2353 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2354 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2355
2356 $time + $to
2357}
2358
2359sub should_reset {
2360 my ($self) = @_;
2361
2362 $self->reset_at <= $cf::RUNTIME
2363}
2364
2365sub reset {
2366 my ($self) = @_;
2367
2368 my $lock = cf::lock_acquire "map_data:$self->{path}";
2369
2370 return if $self->players;
2371
2372 cf::trace "resetting map ", $self->path, "\n";
2373
2374 $self->in_memory (cf::MAP_SWAPPED);
2375
2376 # need to save uniques path
2377 unless ($self->{deny_save}) {
2378 my $uniq = $self->uniq_path; utf8::encode $uniq;
2379
2380 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2381 if $uniq;
2382 }
2383
2384 delete $cf::MAP{$self->path};
2194 2385
2195 $self->deactivate; 2386 $self->deactivate;
2196 $_->clear_links_to ($self) for values %cf::MAP; 2387 $_->clear_links_to ($self) for values %cf::MAP;
2197 $self->clear; 2388 $self->clear;
2198}
2199
2200sub reset_at {
2201 my ($self) = @_;
2202
2203 # TODO: safety, remove and allow resettable per-player maps
2204 return 1e99 if $self->{deny_reset};
2205
2206 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2207 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2208
2209 $time + $to
2210}
2211
2212sub should_reset {
2213 my ($self) = @_;
2214
2215 $self->reset_at <= $cf::RUNTIME
2216}
2217
2218sub reset {
2219 my ($self) = @_;
2220
2221 my $lock = cf::lock_acquire "map_data:$self->{path}";
2222
2223 return if $self->players;
2224
2225 warn "resetting map ", $self->path, "\n";
2226
2227 $self->in_memory (cf::MAP_SWAPPED);
2228
2229 # need to save uniques path
2230 unless ($self->{deny_save}) {
2231 my $uniq = $self->uniq_path; utf8::encode $uniq;
2232
2233 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2234 if $uniq;
2235 }
2236
2237 delete $cf::MAP{$self->path};
2238
2239 $self->deactivate;
2240 $_->clear_links_to ($self) for values %cf::MAP;
2241 $self->clear;
2242 2389
2243 $self->unlink_save; 2390 $self->unlink_save;
2244 $self->destroy; 2391 $self->destroy;
2245} 2392}
2246 2393
… …
2254 2401
2255 delete $cf::MAP{$self->path}; 2402 delete $cf::MAP{$self->path};
2256 2403
2257 $self->unlink_save; 2404 $self->unlink_save;
2258 2405
2259 bless $self, "cf::map"; 2406 bless $self, "cf::map::wrap";
2260 delete $self->{deny_reset}; 2407 delete $self->{deny_reset};
2261 $self->{deny_save} = 1; 2408 $self->{deny_save} = 1;
2262 $self->reset_timeout (1); 2409 $self->reset_timeout (1);
2263 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2410 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2264 2411
… …
2321 : normalise $_ 2468 : normalise $_
2322 } @{ aio_readdir $UNIQUEDIR or [] } 2469 } @{ aio_readdir $UNIQUEDIR or [] }
2323 ] 2470 ]
2324} 2471}
2325 2472
2473=item cf::map::static_maps
2474
2475Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2476file in the shared directory excluding F</styles> and F</editor>). May
2477block.
2478
2479=cut
2480
2481sub static_maps() {
2482 my @dirs = "";
2483 my @maps;
2484
2485 while (@dirs) {
2486 my $dir = shift @dirs;
2487
2488 next if $dir eq "/styles" || $dir eq "/editor";
2489
2490 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2491 or return;
2492
2493 for (@$files) {
2494 s/\.map$// or next;
2495 utf8::decode $_;
2496 push @maps, "$dir/$_";
2497 }
2498
2499 push @dirs, map "$dir/$_", @$dirs;
2500 }
2501
2502 \@maps
2503}
2504
2326=back 2505=back
2327 2506
2328=head3 cf::object 2507=head3 cf::object
2329 2508
2330=cut 2509=cut
… …
2462 2641
2463Freezes the player and moves him/her to a special map (C<{link}>). 2642Freezes the player and moves him/her to a special map (C<{link}>).
2464 2643
2465The player should be reasonably safe there for short amounts of time (e.g. 2644The player should be reasonably safe there for short amounts of time (e.g.
2466for loading a map). You I<MUST> call C<leave_link> as soon as possible, 2645for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2467though, as the palyer cannot control the character while it is on the link 2646though, as the player cannot control the character while it is on the link
2468map. 2647map.
2469 2648
2470Will never block. 2649Will never block.
2471 2650
2472=item $player_object->leave_link ($map, $x, $y) 2651=item $player_object->leave_link ($map, $x, $y)
… …
2493sub cf::object::player::enter_link { 2672sub cf::object::player::enter_link {
2494 my ($self) = @_; 2673 my ($self) = @_;
2495 2674
2496 $self->deactivate_recursive; 2675 $self->deactivate_recursive;
2497 2676
2677 ++$self->{_link_recursion};
2678
2498 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2679 return if UNIVERSAL::isa $self->map, "ext::map_link";
2499 2680
2500 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2681 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2501 if $self->map && $self->map->{path} ne "{link}"; 2682 if $self->map && $self->map->{path} ne "{link}";
2502 2683
2503 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2684 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2504} 2685}
2505 2686
2506sub cf::object::player::leave_link { 2687sub cf::object::player::leave_link {
2507 my ($self, $map, $x, $y) = @_; 2688 my ($self, $map, $x, $y) = @_;
2508 2689
… …
2525 ($x, $y) = (-1, -1) 2706 ($x, $y) = (-1, -1)
2526 unless (defined $x) && (defined $y); 2707 unless (defined $x) && (defined $y);
2527 2708
2528 # use -1 or undef as default coordinates, not 0, 0 2709 # use -1 or undef as default coordinates, not 0, 0
2529 ($x, $y) = ($map->enter_x, $map->enter_y) 2710 ($x, $y) = ($map->enter_x, $map->enter_y)
2530 if $x <=0 && $y <= 0; 2711 if $x <= 0 && $y <= 0;
2531 2712
2532 $map->load; 2713 $map->load;
2533 $map->load_neighbours; 2714 $map->load_neighbours;
2534 2715
2535 return unless $self->contr->active; 2716 return unless $self->contr->active;
2536 2717
2537 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2718 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2538 $self->enter_map ($map, $x, $y); 2719 if ($self->enter_map ($map, $x, $y)) {
2539 2720 # entering was successful
2721 delete $self->{_link_recursion};
2540 # only activate afterwards, to support waiting in hooks 2722 # only activate afterwards, to support waiting in hooks
2541 $self->activate_recursive; 2723 $self->activate_recursive;
2542} 2724 }
2543 2725
2726}
2727
2544=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2728=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2545 2729
2546Moves the player to the given map-path and coordinates by first freezing 2730Moves the player to the given map-path and coordinates by first freezing
2547her, loading and preparing them map, calling the provided $check callback 2731her, loading and preparing them map, calling the provided $check callback
2548that has to return the map if sucecssful, and then unfreezes the player on 2732that has to return the map if sucecssful, and then unfreezes the player on
2549the new (success) or old (failed) map position. In either case, $done will 2733the new (success) or old (failed) map position. In either case, $done will
… …
2556 2740
2557our $GOTOGEN; 2741our $GOTOGEN;
2558 2742
2559sub cf::object::player::goto { 2743sub cf::object::player::goto {
2560 my ($self, $path, $x, $y, $check, $done) = @_; 2744 my ($self, $path, $x, $y, $check, $done) = @_;
2745
2746 if ($self->{_link_recursion} >= $MAX_LINKS) {
2747 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2748 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2749 ($path, $x, $y) = @$EMERGENCY_POSITION;
2750 }
2561 2751
2562 # do generation counting so two concurrent goto's will be executed in-order 2752 # do generation counting so two concurrent goto's will be executed in-order
2563 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2753 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2564 2754
2565 $self->enter_link; 2755 $self->enter_link;
… …
2589 my $map = eval { 2779 my $map = eval {
2590 my $map = defined $path ? cf::map::find $path : undef; 2780 my $map = defined $path ? cf::map::find $path : undef;
2591 2781
2592 if ($map) { 2782 if ($map) {
2593 $map = $map->customise_for ($self); 2783 $map = $map->customise_for ($self);
2594 $map = $check->($map) if $check && $map; 2784 $map = $check->($map, $x, $y, $self) if $check && $map;
2595 } else { 2785 } else {
2596 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2786 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2597 } 2787 }
2598 2788
2599 $map 2789 $map
… …
2607 if ($gen == $self->{_goto_generation}) { 2797 if ($gen == $self->{_goto_generation}) {
2608 delete $self->{_goto_generation}; 2798 delete $self->{_goto_generation};
2609 $self->leave_link ($map, $x, $y); 2799 $self->leave_link ($map, $x, $y);
2610 } 2800 }
2611 2801
2612 $done->() if $done; 2802 $done->($self) if $done;
2613 })->prio (1); 2803 })->prio (1);
2614} 2804}
2615 2805
2616=item $player_object->enter_exit ($exit_object) 2806=item $player_object->enter_exit ($exit_object)
2617 2807
… …
2710 $self->message ("Something went wrong deep within the deliantra server. " 2900 $self->message ("Something went wrong deep within the deliantra server. "
2711 . "I'll try to bring you back to the map you were before. " 2901 . "I'll try to bring you back to the map you were before. "
2712 . "Please report this to the dungeon master!", 2902 . "Please report this to the dungeon master!",
2713 cf::NDI_UNIQUE | cf::NDI_RED); 2903 cf::NDI_UNIQUE | cf::NDI_RED);
2714 2904
2715 warn "ERROR in enter_exit: $@"; 2905 error "ERROR in enter_exit: $@";
2716 $self->leave_link; 2906 $self->leave_link;
2717 } 2907 }
2718 })->prio (1); 2908 })->prio (1);
2719} 2909}
2720 2910
… …
2732sub cf::client::send_drawinfo { 2922sub cf::client::send_drawinfo {
2733 my ($self, $text, $flags) = @_; 2923 my ($self, $text, $flags) = @_;
2734 2924
2735 utf8::encode $text; 2925 utf8::encode $text;
2736 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2926 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2927}
2928
2929=item $client->send_big_packet ($pkt)
2930
2931Like C<send_packet>, but tries to compress large packets, and fragments
2932them as required.
2933
2934=cut
2935
2936our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2937
2938sub cf::client::send_big_packet {
2939 my ($self, $pkt) = @_;
2940
2941 # try lzf for large packets
2942 $pkt = "lzf " . Compress::LZF::compress $pkt
2943 if 1024 <= length $pkt and $self->{can_lzf};
2944
2945 # split very large packets
2946 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2947 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2948 $pkt = "frag";
2949 }
2950
2951 $self->send_packet ($pkt);
2737} 2952}
2738 2953
2739=item $client->send_msg ($channel, $msg, $color, [extra...]) 2954=item $client->send_msg ($channel, $msg, $color, [extra...])
2740 2955
2741Send a drawinfo or msg packet to the client, formatting the msg for the 2956Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2745 2960
2746=cut 2961=cut
2747 2962
2748# non-persistent channels (usually the info channel) 2963# non-persistent channels (usually the info channel)
2749our %CHANNEL = ( 2964our %CHANNEL = (
2965 "c/motd" => {
2966 id => "infobox",
2967 title => "MOTD",
2968 reply => undef,
2969 tooltip => "The message of the day",
2970 },
2750 "c/identify" => { 2971 "c/identify" => {
2751 id => "infobox", 2972 id => "infobox",
2752 title => "Identify", 2973 title => "Identify",
2753 reply => undef, 2974 reply => undef,
2754 tooltip => "Items recently identified", 2975 tooltip => "Items recently identified",
… …
2756 "c/examine" => { 2977 "c/examine" => {
2757 id => "infobox", 2978 id => "infobox",
2758 title => "Examine", 2979 title => "Examine",
2759 reply => undef, 2980 reply => undef,
2760 tooltip => "Signs and other items you examined", 2981 tooltip => "Signs and other items you examined",
2982 },
2983 "c/shopinfo" => {
2984 id => "infobox",
2985 title => "Shop Info",
2986 reply => undef,
2987 tooltip => "What your bargaining skill tells you about the shop",
2761 }, 2988 },
2762 "c/book" => { 2989 "c/book" => {
2763 id => "infobox", 2990 id => "infobox",
2764 title => "Book", 2991 title => "Book",
2765 reply => undef, 2992 reply => undef,
… …
2881 my $pkt = "msg " 3108 my $pkt = "msg "
2882 . $self->{json_coder}->encode ( 3109 . $self->{json_coder}->encode (
2883 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3110 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2884 ); 3111 );
2885 3112
2886 # try lzf for large packets
2887 $pkt = "lzf " . Compress::LZF::compress $pkt
2888 if 1024 <= length $pkt and $self->{can_lzf};
2889
2890 # split very large packets
2891 if (8192 < length $pkt and $self->{can_lzf}) {
2892 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2893 $pkt = "frag";
2894 }
2895
2896 $self->send_packet ($pkt); 3113 $self->send_big_packet ($pkt);
2897} 3114}
2898 3115
2899=item $client->ext_msg ($type, @msg) 3116=item $client->ext_msg ($type, @msg)
2900 3117
2901Sends an ext event to the client. 3118Sends an ext event to the client.
… …
2904 3121
2905sub cf::client::ext_msg($$@) { 3122sub cf::client::ext_msg($$@) {
2906 my ($self, $type, @msg) = @_; 3123 my ($self, $type, @msg) = @_;
2907 3124
2908 if ($self->extcmd == 2) { 3125 if ($self->extcmd == 2) {
2909 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3126 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2910 } elsif ($self->extcmd == 1) { # TODO: remove 3127 } elsif ($self->extcmd == 1) { # TODO: remove
2911 push @msg, msgtype => "event_$type"; 3128 push @msg, msgtype => "event_$type";
2912 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3129 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2913 } 3130 }
2914} 3131}
2915 3132
2916=item $client->ext_reply ($msgid, @msg) 3133=item $client->ext_reply ($msgid, @msg)
2917 3134
… …
2921 3138
2922sub cf::client::ext_reply($$@) { 3139sub cf::client::ext_reply($$@) {
2923 my ($self, $id, @msg) = @_; 3140 my ($self, $id, @msg) = @_;
2924 3141
2925 if ($self->extcmd == 2) { 3142 if ($self->extcmd == 2) {
2926 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3143 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2927 } elsif ($self->extcmd == 1) { 3144 } elsif ($self->extcmd == 1) {
2928 #TODO: version 1, remove 3145 #TODO: version 1, remove
2929 unshift @msg, msgtype => "reply", msgid => $id; 3146 unshift @msg, msgtype => "reply", msgid => $id;
2930 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3147 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2931 } 3148 }
2932} 3149}
2933 3150
2934=item $success = $client->query ($flags, "text", \&cb) 3151=item $success = $client->query ($flags, "text", \&cb)
2935 3152
… …
3006 3223
3007 $ns->ext_reply ($reply, @reply) 3224 $ns->ext_reply ($reply, @reply)
3008 if $reply; 3225 if $reply;
3009 3226
3010 } else { 3227 } else {
3011 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3228 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3012 } 3229 }
3013 3230
3014 cf::override; 3231 cf::override;
3015 }, 3232 },
3016); 3233);
… …
3036 3253
3037 $coro 3254 $coro
3038} 3255}
3039 3256
3040cf::client->attach ( 3257cf::client->attach (
3041 on_destroy => sub { 3258 on_client_destroy => sub {
3042 my ($ns) = @_; 3259 my ($ns) = @_;
3043 3260
3044 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3261 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3045 }, 3262 },
3046); 3263);
… …
3062our $safe_hole = new Safe::Hole; 3279our $safe_hole = new Safe::Hole;
3063 3280
3064$SIG{FPE} = 'IGNORE'; 3281$SIG{FPE} = 'IGNORE';
3065 3282
3066$safe->permit_only (Opcode::opset qw( 3283$safe->permit_only (Opcode::opset qw(
3067 :base_core :base_mem :base_orig :base_math 3284 :base_core :base_mem :base_orig :base_math :base_loop
3068 grepstart grepwhile mapstart mapwhile 3285 grepstart grepwhile mapstart mapwhile
3069 sort time 3286 sort time
3070)); 3287));
3071 3288
3072# here we export the classes and methods available to script code 3289# here we export the classes and methods available to script code
… …
3097 decrease split destroy change_exp value msg lore send_msg)], 3314 decrease split destroy change_exp value msg lore send_msg)],
3098 ["cf::object::player" => qw(player)], 3315 ["cf::object::player" => qw(player)],
3099 ["cf::player" => qw(peaceful send_msg)], 3316 ["cf::player" => qw(peaceful send_msg)],
3100 ["cf::map" => qw(trigger)], 3317 ["cf::map" => qw(trigger)],
3101) { 3318) {
3102 no strict 'refs';
3103 my ($pkg, @funs) = @$_; 3319 my ($pkg, @funs) = @$_;
3104 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3320 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3105 for @funs; 3321 for @funs;
3106} 3322}
3107 3323
… …
3124 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3340 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3125 $qcode =~ s/\n/\\n/g; 3341 $qcode =~ s/\n/\\n/g;
3126 3342
3127 %vars = (_dummy => 0) unless %vars; 3343 %vars = (_dummy => 0) unless %vars;
3128 3344
3345 my @res;
3129 local $_; 3346 local $_;
3130 local @safe::cf::_safe_eval_args = values %vars;
3131 3347
3132 my $eval = 3348 my $eval =
3133 "do {\n" 3349 "do {\n"
3134 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3350 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3135 . "#line 0 \"{$qcode}\"\n" 3351 . "#line 0 \"{$qcode}\"\n"
3136 . $code 3352 . $code
3137 . "\n}" 3353 . "\n}"
3138 ; 3354 ;
3139 3355
3356 if ($CFG{safe_eval}) {
3140 sub_generation_inc; 3357 sub_generation_inc;
3358 local @safe::cf::_safe_eval_args = values %vars;
3141 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3359 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3142 sub_generation_inc; 3360 sub_generation_inc;
3361 } else {
3362 local @cf::_safe_eval_args = values %vars;
3363 @res = wantarray ? eval eval : scalar eval $eval;
3364 }
3143 3365
3144 if ($@) { 3366 if ($@) {
3145 warn "$@"; 3367 warn "$@",
3146 warn "while executing safe code '$code'\n"; 3368 "while executing safe code '$code'\n",
3147 warn "with arguments " . (join " ", %vars) . "\n"; 3369 "with arguments " . (join " ", %vars) . "\n";
3148 } 3370 }
3149 3371
3150 wantarray ? @res : $res[0] 3372 wantarray ? @res : $res[0]
3151} 3373}
3152 3374
… …
3166=cut 3388=cut
3167 3389
3168sub register_script_function { 3390sub register_script_function {
3169 my ($fun, $cb) = @_; 3391 my ($fun, $cb) = @_;
3170 3392
3171 no strict 'refs'; 3393 $fun = "safe::$fun" if $CFG{safe_eval};
3172 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3394 *$fun = $safe_hole->wrap ($cb);
3173} 3395}
3174 3396
3175=back 3397=back
3176 3398
3177=cut 3399=cut
… …
3186 # for this (global event?) 3408 # for this (global event?)
3187 %ext::player_env::MUSIC_FACE_CACHE = (); 3409 %ext::player_env::MUSIC_FACE_CACHE = ();
3188 3410
3189 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3411 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3190 3412
3191 warn "loading facedata from $path\n"; 3413 trace "loading facedata from $path\n";
3192 3414
3193 my $facedata;
3194 0 < aio_load $path, $facedata 3415 0 < aio_load $path, my $facedata
3195 or die "$path: $!"; 3416 or die "$path: $!";
3196 3417
3197 $facedata = Coro::Storable::thaw $facedata; 3418 $facedata = Coro::Storable::thaw $facedata;
3198 3419
3199 $facedata->{version} == 2 3420 $facedata->{version} == 2
3200 or cf::cleanup "$path: version mismatch, cannot proceed."; 3421 or cf::cleanup "$path: version mismatch, cannot proceed.";
3201 3422
3202 # patch in the exptable 3423 # patch in the exptable
3424 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3203 $facedata->{resource}{"res/exp_table"} = { 3425 $facedata->{resource}{"res/exp_table"} = {
3204 type => FT_RSRC, 3426 type => FT_RSRC,
3205 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3427 data => $exp_table,
3428 hash => (Digest::MD5::md5 $exp_table),
3206 }; 3429 };
3207 cf::cede_to_tick; 3430 cf::cede_to_tick;
3208 3431
3209 { 3432 {
3210 my $faces = $facedata->{faceinfo}; 3433 my $faces = $facedata->{faceinfo};
… …
3212 while (my ($face, $info) = each %$faces) { 3435 while (my ($face, $info) = each %$faces) {
3213 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3436 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3214 3437
3215 cf::face::set_visibility $idx, $info->{visibility}; 3438 cf::face::set_visibility $idx, $info->{visibility};
3216 cf::face::set_magicmap $idx, $info->{magicmap}; 3439 cf::face::set_magicmap $idx, $info->{magicmap};
3217 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3440 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3218 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3441 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3219 3442
3220 cf::cede_to_tick; 3443 cf::cede_to_tick;
3221 } 3444 }
3222 3445
3223 while (my ($face, $info) = each %$faces) { 3446 while (my ($face, $info) = each %$faces) {
… …
3228 3451
3229 if (my $smooth = cf::face::find $info->{smooth}) { 3452 if (my $smooth = cf::face::find $info->{smooth}) {
3230 cf::face::set_smooth $idx, $smooth; 3453 cf::face::set_smooth $idx, $smooth;
3231 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3454 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3232 } else { 3455 } else {
3233 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3456 error "smooth face '$info->{smooth}' not found for face '$face'";
3234 } 3457 }
3235 3458
3236 cf::cede_to_tick; 3459 cf::cede_to_tick;
3237 } 3460 }
3238 } 3461 }
… …
3247 3470
3248 cf::anim::invalidate_all; # d'oh 3471 cf::anim::invalidate_all; # d'oh
3249 } 3472 }
3250 3473
3251 { 3474 {
3252 # TODO: for gcfclient pleasure, we should give resources
3253 # that gcfclient doesn't grok a >10000 face index.
3254 my $res = $facedata->{resource}; 3475 my $res = $facedata->{resource};
3255 3476
3256 while (my ($name, $info) = each %$res) { 3477 while (my ($name, $info) = each %$res) {
3257 if (defined $info->{type}) { 3478 if (defined $info->{type}) {
3258 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3479 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3259 my $data;
3260 3480
3261 if ($info->{type} & 1) { 3481 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3262 # prepend meta info
3263
3264 my $meta = $enc->encode ({
3265 name => $name,
3266 %{ $info->{meta} || {} },
3267 });
3268
3269 $data = pack "(w/a*)*", $meta, $info->{data};
3270 } else {
3271 $data = $info->{data};
3272 }
3273
3274 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3275 cf::face::set_type $idx, $info->{type}; 3482 cf::face::set_type $idx, $info->{type};
3276 } else { 3483 } else {
3277 $RESOURCE{$name} = $info; 3484 $RESOURCE{$name} = $info; # unused
3278 } 3485 }
3279 3486
3280 cf::cede_to_tick; 3487 cf::cede_to_tick;
3281 } 3488 }
3282 } 3489 }
3283 3490
3284 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3491 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3285 3492
3286 1 3493 1
3287} 3494}
3288
3289cf::global->attach (on_resource_update => sub {
3290 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3291 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3292
3293 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3294 my $sound = $soundconf->{compat}[$_]
3295 or next;
3296
3297 my $face = cf::face::find "sound/$sound->[1]";
3298 cf::sound::set $sound->[0] => $face;
3299 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3300 }
3301
3302 while (my ($k, $v) = each %{$soundconf->{event}}) {
3303 my $face = cf::face::find "sound/$v";
3304 cf::sound::set $k => $face;
3305 }
3306 }
3307});
3308 3495
3309register_exticmd fx_want => sub { 3496register_exticmd fx_want => sub {
3310 my ($ns, $want) = @_; 3497 my ($ns, $want) = @_;
3311 3498
3312 while (my ($k, $v) = each %$want) { 3499 while (my ($k, $v) = each %$want) {
… …
3351sub reload_treasures { 3538sub reload_treasures {
3352 load_resource_file "$DATADIR/treasures" 3539 load_resource_file "$DATADIR/treasures"
3353 or die "unable to load treasurelists\n"; 3540 or die "unable to load treasurelists\n";
3354} 3541}
3355 3542
3543sub reload_sound {
3544 trace "loading sound config from $DATADIR/sound\n";
3545
3546 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3547 or die "$DATADIR/sound $!";
3548
3549 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
3550
3551 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3552 my $sound = $soundconf->{compat}[$_]
3553 or next;
3554
3555 my $face = cf::face::find "sound/$sound->[1]";
3556 cf::sound::set $sound->[0] => $face;
3557 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3558 }
3559
3560 while (my ($k, $v) = each %{$soundconf->{event}}) {
3561 my $face = cf::face::find "sound/$v";
3562 cf::sound::set $k => $face;
3563 }
3564}
3565
3356sub reload_resources { 3566sub reload_resources {
3357 warn "reloading resource files...\n"; 3567 trace "reloading resource files...\n";
3358 3568
3569 reload_exp_table;
3570 reload_materials;
3359 reload_facedata; 3571 reload_facedata;
3572 reload_sound;
3360 reload_archetypes; 3573 reload_archetypes;
3361 reload_regions; 3574 reload_regions;
3362 reload_treasures; 3575 reload_treasures;
3363 3576
3364 warn "finished reloading resource files\n"; 3577 trace "finished reloading resource files\n";
3365} 3578}
3366 3579
3367sub reload_config { 3580sub reload_config {
3368 open my $fh, "<:utf8", "$CONFDIR/config" 3581 trace "reloading config file...\n";
3369 or return;
3370 3582
3371 local $/; 3583 0 < aio_load "$CONFDIR/config", my $config
3372 *CFG = YAML::Load <$fh>; 3584 or die "$CONFDIR/config: $!";
3373 3585
3586 utf8::decode $config;
3587 *CFG = yaml_load $config;
3588
3374 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3589 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3375 3590
3376 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3591 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3377 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3592 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3378 3593
3379 if (exists $CFG{mlockall}) { 3594 if (exists $CFG{mlockall}) {
… …
3403 seek $fh, 0, 0; 3618 seek $fh, 0, 0;
3404 print $fh $$; 3619 print $fh $$;
3405} 3620}
3406 3621
3407sub main_loop { 3622sub main_loop {
3408 warn "EV::loop starting\n"; 3623 trace "EV::loop starting\n";
3409 if (1) { 3624 if (1) {
3410 EV::loop; 3625 EV::loop;
3411 } 3626 }
3412 warn "EV::loop returned\n"; 3627 trace "EV::loop returned\n";
3413 goto &main_loop unless $REALLY_UNLOOP; 3628 goto &main_loop unless $REALLY_UNLOOP;
3414} 3629}
3415 3630
3416sub main { 3631sub main {
3417 cf::init_globals; # initialise logging 3632 cf::init_globals; # initialise logging
3418 3633
3419 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3634 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3420 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3635 LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3421 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3636 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3422 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3637 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3423
3424 cf::init_experience;
3425 cf::init_anim;
3426 cf::init_attackmess;
3427 cf::init_dynamic;
3428 3638
3429 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3639 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3430 3640
3431 # we must not ever block the main coroutine 3641 # we must not ever block the main coroutine
3432 local $Coro::idle = sub { 3642 local $Coro::idle = sub {
… …
3438 }; 3648 };
3439 3649
3440 evthread_start IO::AIO::poll_fileno; 3650 evthread_start IO::AIO::poll_fileno;
3441 3651
3442 cf::sync_job { 3652 cf::sync_job {
3653 cf::incloader::init ();
3654
3655 cf::init_anim;
3656 cf::init_attackmess;
3657 cf::init_dynamic;
3658
3659 cf::load_settings;
3660
3443 reload_resources; 3661 reload_resources;
3444 reload_config; 3662 reload_config;
3445 db_init; 3663 db_init;
3446 3664
3447 cf::load_settings;
3448 cf::load_materials;
3449 cf::init_uuid; 3665 cf::init_uuid;
3450 cf::init_signals; 3666 cf::init_signals;
3451 cf::init_commands;
3452 cf::init_skills; 3667 cf::init_skills;
3453 3668
3454 cf::init_beforeplay; 3669 cf::init_beforeplay;
3455 3670
3456 atomic; 3671 atomic;
… …
3461 3676
3462 # no (long-running) fork's whatsoever before this point(!) 3677 # no (long-running) fork's whatsoever before this point(!)
3463 use POSIX (); 3678 use POSIX ();
3464 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3679 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3465 3680
3466 (pop @POST_INIT)->(0) while @POST_INIT; 3681 cf::_post_init 0;
3467 }; 3682 };
3468 3683
3684 cf::object::thawer::errors_are_fatal 0;
3685 info "parse errors in files are no longer fatal from this point on.\n";
3686
3687 my $free_main; $free_main = EV::idle sub {
3688 undef $free_main;
3689 undef &main; # free gobs of memory :)
3690 };
3691
3469 main_loop; 3692 goto &main_loop;
3470} 3693}
3471 3694
3472############################################################################# 3695#############################################################################
3473# initialisation and cleanup 3696# initialisation and cleanup
3474 3697
3475# install some emergency cleanup handlers 3698# install some emergency cleanup handlers
3476BEGIN { 3699BEGIN {
3477 our %SIGWATCHER = (); 3700 our %SIGWATCHER = ();
3478 for my $signal (qw(INT HUP TERM)) { 3701 for my $signal (qw(INT HUP TERM)) {
3479 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3702 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3480 cf::cleanup "SIG$signal"; 3703 cf::cleanup "SIG$signal";
3481 }; 3704 };
3482 } 3705 }
3483} 3706}
3484 3707
3485sub write_runtime_sync { 3708sub write_runtime_sync {
3709 my $t0 = AE::time;
3710
3486 # first touch the runtime file to show we are still running: 3711 # first touch the runtime file to show we are still running:
3487 # the fsync below can take a very very long time. 3712 # the fsync below can take a very very long time.
3488 3713
3489 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3714 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3490 3715
3491 my $guard = cf::lock_acquire "write_runtime"; 3716 my $guard = cf::lock_acquire "write_runtime";
3492 3717
3493 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3718 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3494 or return; 3719 or return;
3495 3720
3496 my $value = $cf::RUNTIME + 90 + 10; 3721 my $value = $cf::RUNTIME + 90 + 10;
3497 # 10 is the runtime save interval, for a monotonic clock 3722 # 10 is the runtime save interval, for a monotonic clock
3498 # 60 allows for the watchdog to kill the server. 3723 # 60 allows for the watchdog to kill the server.
… …
3511 or return; 3736 or return;
3512 3737
3513 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3738 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3514 and return; 3739 and return;
3515 3740
3516 warn "runtime file written.\n"; 3741 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3517 3742
3518 1 3743 1
3519} 3744}
3520 3745
3521our $uuid_lock; 3746our $uuid_lock;
… …
3533 or return; 3758 or return;
3534 3759
3535 my $value = uuid_seq uuid_cur; 3760 my $value = uuid_seq uuid_cur;
3536 3761
3537 unless ($value) { 3762 unless ($value) {
3538 warn "cowardly refusing to write zero uuid value!\n"; 3763 info "cowardly refusing to write zero uuid value!\n";
3539 return; 3764 return;
3540 } 3765 }
3541 3766
3542 my $value = uuid_str $value + $uuid_skip; 3767 my $value = uuid_str $value + $uuid_skip;
3543 $uuid_skip = 0; 3768 $uuid_skip = 0;
… …
3553 or return; 3778 or return;
3554 3779
3555 aio_rename "$uuid~", $uuid 3780 aio_rename "$uuid~", $uuid
3556 and return; 3781 and return;
3557 3782
3558 warn "uuid file written ($value).\n"; 3783 trace "uuid file written ($value).\n";
3559 3784
3560 1 3785 1
3561 3786
3562} 3787}
3563 3788
… …
3569} 3794}
3570 3795
3571sub emergency_save() { 3796sub emergency_save() {
3572 my $freeze_guard = cf::freeze_mainloop; 3797 my $freeze_guard = cf::freeze_mainloop;
3573 3798
3574 warn "emergency_perl_save: enter\n"; 3799 info "emergency_perl_save: enter\n";
3800
3801 # this is a trade-off: we want to be very quick here, so
3802 # save all maps without fsync, and later call a global sync
3803 # (which in turn might be very very slow)
3804 local $USE_FSYNC = 0;
3575 3805
3576 cf::sync_job { 3806 cf::sync_job {
3577 # this is a trade-off: we want to be very quick here, so 3807 cf::write_runtime_sync; # external watchdog should not bark
3578 # save all maps without fsync, and later call a global sync
3579 # (which in turn might be very very slow)
3580 local $USE_FSYNC = 0;
3581 3808
3582 # use a peculiar iteration method to avoid tripping on perl 3809 # use a peculiar iteration method to avoid tripping on perl
3583 # refcount bugs in for. also avoids problems with players 3810 # refcount bugs in for. also avoids problems with players
3584 # and maps saved/destroyed asynchronously. 3811 # and maps saved/destroyed asynchronously.
3585 warn "emergency_perl_save: begin player save\n"; 3812 info "emergency_perl_save: begin player save\n";
3586 for my $login (keys %cf::PLAYER) { 3813 for my $login (keys %cf::PLAYER) {
3587 my $pl = $cf::PLAYER{$login} or next; 3814 my $pl = $cf::PLAYER{$login} or next;
3588 $pl->valid or next; 3815 $pl->valid or next;
3589 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3816 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3590 $pl->save; 3817 $pl->save;
3591 } 3818 }
3592 warn "emergency_perl_save: end player save\n"; 3819 info "emergency_perl_save: end player save\n";
3593 3820
3821 cf::write_runtime_sync; # external watchdog should not bark
3822
3594 warn "emergency_perl_save: begin map save\n"; 3823 info "emergency_perl_save: begin map save\n";
3595 for my $path (keys %cf::MAP) { 3824 for my $path (keys %cf::MAP) {
3596 my $map = $cf::MAP{$path} or next; 3825 my $map = $cf::MAP{$path} or next;
3597 $map->valid or next; 3826 $map->valid or next;
3598 $map->save; 3827 $map->save;
3599 } 3828 }
3600 warn "emergency_perl_save: end map save\n"; 3829 info "emergency_perl_save: end map save\n";
3601 3830
3831 cf::write_runtime_sync; # external watchdog should not bark
3832
3602 warn "emergency_perl_save: begin database checkpoint\n"; 3833 info "emergency_perl_save: begin database checkpoint\n";
3603 BDB::db_env_txn_checkpoint $DB_ENV; 3834 BDB::db_env_txn_checkpoint $DB_ENV;
3604 warn "emergency_perl_save: end database checkpoint\n"; 3835 info "emergency_perl_save: end database checkpoint\n";
3605 3836
3606 warn "emergency_perl_save: begin write uuid\n"; 3837 info "emergency_perl_save: begin write uuid\n";
3607 write_uuid_sync 1; 3838 write_uuid_sync 1;
3608 warn "emergency_perl_save: end write uuid\n"; 3839 info "emergency_perl_save: end write uuid\n";
3840
3841 cf::write_runtime_sync; # external watchdog should not bark
3842
3843 trace "emergency_perl_save: syncing database to disk";
3844 BDB::db_env_txn_checkpoint $DB_ENV;
3845
3846 info "emergency_perl_save: starting sync\n";
3847 IO::AIO::aio_sync sub {
3848 info "emergency_perl_save: finished sync\n";
3849 };
3850
3851 cf::write_runtime_sync; # external watchdog should not bark
3852
3853 trace "emergency_perl_save: flushing outstanding aio requests";
3854 while (IO::AIO::nreqs || BDB::nreqs) {
3855 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3856 }
3857
3858 cf::write_runtime_sync; # external watchdog should not bark
3609 }; 3859 };
3610 3860
3611 warn "emergency_perl_save: starting sync()\n";
3612 IO::AIO::aio_sync sub {
3613 warn "emergency_perl_save: finished sync()\n";
3614 };
3615
3616 warn "emergency_perl_save: leave\n"; 3861 info "emergency_perl_save: leave\n";
3617} 3862}
3618 3863
3619sub post_cleanup { 3864sub post_cleanup {
3620 my ($make_core) = @_; 3865 my ($make_core) = @_;
3621 3866
3867 IO::AIO::flush;
3868
3622 warn Carp::longmess "post_cleanup backtrace" 3869 error Carp::longmess "post_cleanup backtrace"
3623 if $make_core; 3870 if $make_core;
3624 3871
3625 my $fh = pidfile; 3872 my $fh = pidfile;
3626 unlink $PIDFILE if <$fh> == $$; 3873 unlink $PIDFILE if <$fh> == $$;
3627} 3874}
… …
3647 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3894 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3648 for my $name (keys %$leaf_symtab) { 3895 for my $name (keys %$leaf_symtab) {
3649 _gv_clear *{"$pkg$name"}; 3896 _gv_clear *{"$pkg$name"};
3650# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3897# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3651 } 3898 }
3652 warn "cleared package $pkg\n";#d#
3653} 3899}
3654 3900
3655sub do_reload_perl() { 3901sub do_reload_perl() {
3656 # can/must only be called in main 3902 # can/must only be called in main
3657 if ($Coro::current != $Coro::main) { 3903 unless (in_main) {
3658 warn "can only reload from main coroutine"; 3904 error "can only reload from main coroutine";
3659 return; 3905 return;
3660 } 3906 }
3661 3907
3662 return if $RELOAD++; 3908 return if $RELOAD++;
3663 3909
3664 my $t1 = EV::time; 3910 my $t1 = AE::time;
3665 3911
3666 while ($RELOAD) { 3912 while ($RELOAD) {
3667 warn "reloading..."; 3913 cf::get_slot 0.1, -1, "reload_perl";
3914 info "perl_reload: reloading...";
3668 3915
3669 warn "entering sync_job"; 3916 trace "perl_reload: entering sync_job";
3670 3917
3671 cf::sync_job { 3918 cf::sync_job {
3672 cf::write_runtime_sync; # external watchdog should not bark
3673 cf::emergency_save; 3919 #cf::emergency_save;
3674 cf::write_runtime_sync; # external watchdog should not bark
3675 3920
3676 warn "syncing database to disk";
3677 BDB::db_env_txn_checkpoint $DB_ENV;
3678
3679 # if anything goes wrong in here, we should simply crash as we already saved
3680
3681 warn "flushing outstanding aio requests";
3682 while (IO::AIO::nreqs || BDB::nreqs) {
3683 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3684 }
3685
3686 warn "cancelling all extension coros"; 3921 trace "perl_reload: cancelling all extension coros";
3687 $_->cancel for values %EXT_CORO; 3922 $_->cancel for values %EXT_CORO;
3688 %EXT_CORO = (); 3923 %EXT_CORO = ();
3689 3924
3690 warn "removing commands"; 3925 trace "perl_reload: removing commands";
3691 %COMMAND = (); 3926 %COMMAND = ();
3692 3927
3693 warn "removing ext/exti commands"; 3928 trace "perl_reload: removing ext/exti commands";
3694 %EXTCMD = (); 3929 %EXTCMD = ();
3695 %EXTICMD = (); 3930 %EXTICMD = ();
3696 3931
3697 warn "unloading/nuking all extensions"; 3932 trace "perl_reload: unloading/nuking all extensions";
3698 for my $pkg (@EXTS) { 3933 for my $pkg (@EXTS) {
3699 warn "... unloading $pkg"; 3934 trace "... unloading $pkg";
3700 3935
3701 if (my $cb = $pkg->can ("unload")) { 3936 if (my $cb = $pkg->can ("unload")) {
3702 eval { 3937 eval {
3703 $cb->($pkg); 3938 $cb->($pkg);
3704 1 3939 1
3705 } or warn "$pkg unloaded, but with errors: $@"; 3940 } or error "$pkg unloaded, but with errors: $@";
3706 } 3941 }
3707 3942
3708 warn "... clearing $pkg"; 3943 trace "... clearing $pkg";
3709 clear_package $pkg; 3944 clear_package $pkg;
3710 } 3945 }
3711 3946
3712 warn "unloading all perl modules loaded from $LIBDIR"; 3947 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3713 while (my ($k, $v) = each %INC) { 3948 while (my ($k, $v) = each %INC) {
3714 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3949 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3715 3950
3716 warn "... unloading $k"; 3951 trace "... unloading $k";
3717 delete $INC{$k}; 3952 delete $INC{$k};
3718 3953
3719 $k =~ s/\.pm$//; 3954 $k =~ s/\.pm$//;
3720 $k =~ s/\//::/g; 3955 $k =~ s/\//::/g;
3721 3956
… …
3724 } 3959 }
3725 3960
3726 clear_package $k; 3961 clear_package $k;
3727 } 3962 }
3728 3963
3729 warn "getting rid of safe::, as good as possible"; 3964 trace "perl_reload: getting rid of safe::, as good as possible";
3730 clear_package "safe::$_" 3965 clear_package "safe::$_"
3731 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3966 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3732 3967
3733 warn "unloading cf.pm \"a bit\""; 3968 trace "perl_reload: unloading cf.pm \"a bit\"";
3734 delete $INC{"cf.pm"}; 3969 delete $INC{"cf.pm"};
3735 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 3970 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3736 3971
3737 # don't, removes xs symbols, too, 3972 # don't, removes xs symbols, too,
3738 # and global variables created in xs 3973 # and global variables created in xs
3739 #clear_package __PACKAGE__; 3974 #clear_package __PACKAGE__;
3740 3975
3741 warn "unload completed, starting to reload now"; 3976 info "perl_reload: unload completed, starting to reload now";
3742 3977
3743 warn "reloading cf.pm"; 3978 trace "perl_reload: reloading cf.pm";
3744 require cf; 3979 require cf;
3745 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3980 cf::_connect_to_perl_1;
3746 3981
3747 warn "loading config and database again"; 3982 trace "perl_reload: loading config and database again";
3748 cf::reload_config; 3983 cf::reload_config;
3749 3984
3750 warn "loading extensions"; 3985 trace "perl_reload: loading extensions";
3751 cf::load_extensions; 3986 cf::load_extensions;
3752 3987
3753 if ($REATTACH_ON_RELOAD) { 3988 if ($REATTACH_ON_RELOAD) {
3754 warn "reattaching attachments to objects/players"; 3989 trace "perl_reload: reattaching attachments to objects/players";
3755 _global_reattach; # objects, sockets 3990 _global_reattach; # objects, sockets
3756 warn "reattaching attachments to maps"; 3991 trace "perl_reload: reattaching attachments to maps";
3757 reattach $_ for values %MAP; 3992 reattach $_ for values %MAP;
3758 warn "reattaching attachments to players"; 3993 trace "perl_reload: reattaching attachments to players";
3759 reattach $_ for values %PLAYER; 3994 reattach $_ for values %PLAYER;
3760 } 3995 }
3761 3996
3762 warn "running post_init jobs"; 3997 cf::_post_init 1;
3763 (pop @POST_INIT)->(1) while @POST_INIT;
3764 3998
3765 warn "leaving sync_job"; 3999 trace "perl_reload: leaving sync_job";
3766 4000
3767 1 4001 1
3768 } or do { 4002 } or do {
3769 warn $@; 4003 error $@;
3770 cf::cleanup "error while reloading, exiting."; 4004 cf::cleanup "perl_reload: error, exiting.";
3771 }; 4005 };
3772 4006
3773 warn "reloaded";
3774 --$RELOAD; 4007 --$RELOAD;
3775 } 4008 }
3776 4009
3777 $t1 = EV::time - $t1; 4010 $t1 = AE::time - $t1;
3778 warn "reload completed in ${t1}s\n"; 4011 info "perl_reload: completed in ${t1}s\n";
3779}; 4012};
3780 4013
3781our $RELOAD_WATCHER; # used only during reload 4014our $RELOAD_WATCHER; # used only during reload
3782 4015
3783sub reload_perl() { 4016sub reload_perl() {
… …
3785 # coro crashes during coro_state_free->destroy here. 4018 # coro crashes during coro_state_free->destroy here.
3786 4019
3787 $RELOAD_WATCHER ||= cf::async { 4020 $RELOAD_WATCHER ||= cf::async {
3788 Coro::AIO::aio_wait cache_extensions; 4021 Coro::AIO::aio_wait cache_extensions;
3789 4022
3790 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 4023 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3791 do_reload_perl; 4024 do_reload_perl;
3792 undef $RELOAD_WATCHER; 4025 undef $RELOAD_WATCHER;
3793 }; 4026 };
3794 }; 4027 };
3795} 4028}
… …
3804 reload_perl; 4037 reload_perl;
3805 }; 4038 };
3806 } 4039 }
3807}; 4040};
3808 4041
3809unshift @INC, $LIBDIR; 4042#############################################################################
3810 4043
3811my $bug_warning = 0; 4044my $bug_warning = 0;
3812 4045
3813our @WAIT_FOR_TICK; 4046our @WAIT_FOR_TICK;
3814our @WAIT_FOR_TICK_BEGIN; 4047our @WAIT_FOR_TICK_BEGIN;
3815 4048
3816sub wait_for_tick { 4049sub wait_for_tick() {
3817 return if tick_inhibit || $Coro::current == $Coro::main; 4050 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3818 4051
3819 my $signal = new Coro::Signal; 4052 my $signal = new Coro::Signal;
3820 push @WAIT_FOR_TICK, $signal; 4053 push @WAIT_FOR_TICK, $signal;
3821 $signal->wait; 4054 $signal->wait;
3822} 4055}
3823 4056
3824sub wait_for_tick_begin { 4057sub wait_for_tick_begin() {
3825 return if tick_inhibit || $Coro::current == $Coro::main; 4058 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3826 4059
3827 my $signal = new Coro::Signal; 4060 my $signal = new Coro::Signal;
3828 push @WAIT_FOR_TICK_BEGIN, $signal; 4061 push @WAIT_FOR_TICK_BEGIN, $signal;
3829 $signal->wait; 4062 $signal->wait;
3830} 4063}
… …
3836 return; 4069 return;
3837 } 4070 }
3838 4071
3839 cf::server_tick; # one server iteration 4072 cf::server_tick; # one server iteration
3840 4073
4074 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4075
3841 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4076 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3842 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4077 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3843 Coro::async_pool { 4078 Coro::async_pool {
3844 $Coro::current->{desc} = "runtime saver"; 4079 $Coro::current->{desc} = "runtime saver";
3845 write_runtime_sync 4080 write_runtime_sync
3846 or warn "ERROR: unable to write runtime file: $!"; 4081 or error "ERROR: unable to write runtime file: $!";
3847 }; 4082 };
3848 } 4083 }
3849 4084
3850 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4085 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3851 $sig->send; 4086 $sig->send;
… …
3859 4094
3860 if (0) { 4095 if (0) {
3861 if ($NEXT_TICK) { 4096 if ($NEXT_TICK) {
3862 my $jitter = $TICK_START - $NEXT_TICK; 4097 my $jitter = $TICK_START - $NEXT_TICK;
3863 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4098 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3864 warn "jitter $JITTER\n";#d# 4099 debug "jitter $JITTER\n";#d#
3865 } 4100 }
3866 } 4101 }
3867} 4102}
3868 4103
3869{ 4104{
3870 # configure BDB 4105 # configure BDB
3871 4106
3872 BDB::min_parallel 8; 4107 BDB::min_parallel 16;
3873 BDB::max_poll_reqs $TICK * 0.1; 4108 BDB::max_poll_reqs $TICK * 0.1;
3874 $AnyEvent::BDB::WATCHER->priority (1); 4109 $AnyEvent::BDB::WATCHER->priority (1);
3875 4110
3876 unless ($DB_ENV) { 4111 unless ($DB_ENV) {
3877 $DB_ENV = BDB::db_env_create; 4112 $DB_ENV = BDB::db_env_create;
… …
3958 } 4193 }
3959} 4194}
3960 4195
3961# load additional modules 4196# load additional modules
3962require "cf/$_.pm" for @EXTRA_MODULES; 4197require "cf/$_.pm" for @EXTRA_MODULES;
4198cf::_connect_to_perl_2;
3963 4199
3964END { cf::emergency_save } 4200END { cf::emergency_save }
3965 4201
39661 42021
3967 4203

Diff Legend

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